—

              
#!/usr/bin/perl -w
# See copyright, etc in below POD section.
######################################################################
require 5.006_001;
use Getopt::Long;
use IO::File;
use Pod::Usage;
use strict;
use vars qw($Debug $VERSION);
# We need keywords, but haven't completely built yet, so can't use the blib
# Thus we pull in Language.pm directly
require "../Language.pm";
package main;
$VERSION = '3.482';
# xs_manual=>1,   -> The .xs file makes the handler itself
my %Cbs =
    (attribute  => {which=>'Parser', args => [text=>'string']},
     comment    => {which=>'Parser', args => [text=>'string']},
     endparse   => {which=>'Parser', args => [text=>'string']},
     keyword    => {which=>'Parser', args => [text=>'string']},
     number     => {which=>'Parser', args => [text=>'string']},
     operator   => {which=>'Parser', args => [text=>'string']},
     preproc    => {which=>'Parser', args => [text=>'string']},
     string     => {which=>'Parser', args => [text=>'string']},
     symbol     => {which=>'Parser', args => [text=>'string']},
     sysfunc    => {which=>'Parser', args => [text=>'string']},
     #
     class      => {which=>'SigParser', args => [kwd=>'string', name=>'string', virt=>'string']},
     contassign => {which=>'SigParser', args => [kwd=>'string', lhs=>'string', rhs=>'string']},
     covergroup => {which=>'SigParser', args => [kwd=>'string', name=>'string']},
     defparam   => {which=>'SigParser', args => [kwd=>'string', lhs=>'string', rhs=>'string']},
     endcell    => {which=>'SigParser', args => [kwd=>'string']},
     endclass   => {which=>'SigParser', args => [kwd=>'string']},
     endgroup   => {which=>'SigParser', args => [kwd=>'string']},
     endinterface=>{which=>'SigParser', args => [kwd=>'string']},
     endmodport => {which=>'SigParser', args => [kwd=>'string']},
     endmodule  => {which=>'SigParser', args => [kwd=>'string']},
     endpackage => {which=>'SigParser', args => [kwd=>'string']},
     endprogram => {which=>'SigParser', args => [kwd=>'string']},
     endtaskfunc=> {which=>'SigParser', args => [kwd=>'string']},
     function   => {which=>'SigParser', args => [kwd=>'string', name=>'string', data_type=>'string']},
     import     => {which=>'SigParser', args => [package=>'string', id=>'string']},
     instant    => {which=>'SigParser', args => [mod=>'string', cell=>'string', range=>'string']},
     interface  => {which=>'SigParser', args => [kwd=>'string', name=>'string']},
     modport    => {which=>'SigParser', args => [kwd=>'string', name=>'string']},
     module     => {which=>'SigParser', args => [kwd=>'string', name=>'string', ignore3=>'undef', celldefine=>'bool'],},
     package    => {which=>'SigParser', args => [kwd=>'string', name=>'string']},
     parampin   => {which=>'SigParser', args => [name=>'string', conn=>'string', index=>'int']},
     pin        => {which=>'SigParser', args => [name=>'string', conn=>'string', index=>'int']},
     pinselects => {which=>'SigParser', args => [name=>'string', conns=>'hash', index=>'int']},
     port       => {which=>'SigParser', args => [name=>'string', objof=>'string', direction=>'string',
                                                 data_type=>'string', array=>'string', index=>'int']},
     program    => {which=>'SigParser', args => [kwd=>'string', name=>'string'],},
     var        => {which=>'SigParser', args => [kwd=>'string',      name=>'string', objof=>'string', net=>'string',
                                                 data_type=>'string', array=>'string', value=>'string'],},
     task       => {which=>'SigParser', args => [kwd=>'string', name=>'string']},
    );
#======================================================================
# main
our $Opt_Debug;
autoflush STDOUT 1;
autoflush STDERR 1;
Getopt::Long::config("no_auto_abbrev");
if (! GetOptions (
          # Local options
          "help"        => \&usage,
          "version"     => sub { print "Version $VERSION\n"; exit(0); },
          "<>"            => sub { die "%Error: Unknown parameter: $_[0]\n"; },
    )) {
    die "%Error: Bad usage, try 'callbackgen --help'\n";
}
process();
#----------------------------------------------------------------------
sub usage {
    print "Version $VERSION\n";
    pod2usage(-verbose=>2, -exitval=>2, -output=>\*STDOUT, -noperldoc=>1);
    exit(1);
}
#######################################################################
sub process {
    filter("Parser.xs",0);
    filter("VParse.h",0);
    filter("Parser_callbackgen.cpp",1);
}
sub filter {
    my $filename = shift;
    my $make_xs = shift;
    my $fh = IO::File->new("<$filename");
    my @lines;
    if (!$fh) {
        if ($make_xs) {
            @lines = ("// CALLBACKGEN_XS\n");
        } else {
            die "%Error: $! $filename\n";
        }
    } else {
        @lines = $fh->getlines;
        $fh->close;
    }
    my @orig = @lines;
    my $strip;
    my @out;
    foreach my $line (@lines) {
        if ($line =~ /CALLBACKGEN_GENERATED_BEGIN/) {
            $strip = 1;
        } else {
            if (!$strip) {
                push @out, $line;
            }
            if ($line =~ /CALLBACKGEN_GENERATED_END/) {
                $strip = 0;
            }
            elsif ($line =~ /CALLBACKGEN_H_MEMBERS/) {
                push @out, "    // CALLBACKGEN_GENERATED_BEGIN - GENERATED AUTOMATICALLY by callbackgen\n";
                push @out, _h_use_cb();
                push @out, "    // CALLBACKGEN_GENERATED_END - GENERATED AUTOMATICALLY by callbackgen\n";
            }
            elsif ($line =~ /CALLBACKGEN_CB_USE/) {
                push @out, "    // CALLBACKGEN_GENERATED_BEGIN - GENERATED AUTOMATICALLY by callbackgen\n";
                push @out, _c_use_cb();
                push @out, "    // CALLBACKGEN_GENERATED_END - GENERATED AUTOMATICALLY by callbackgen\n";
            }
            elsif ($line =~ /CALLBACKGEN_H_VIRTUAL(_0)?/) {
                my $zero = (($1||"") eq "_0") ? " = 0":"";
                push @out, "    // CALLBACKGEN_GENERATED_BEGIN - GENERATED AUTOMATICALLY by callbackgen\n";
                my $last_which = "";
                foreach my $cb (sort {$Cbs{$a}{which} cmp $Cbs{$b}{which} || $a cmp $b} keys %Cbs) {
                    my $which = $Cbs{$cb}{which};
                    if ($last_which ne $which) {
                        push @out, "    // Verilog::$which Callback methods\n";
                        $last_which = $which;
                    }
                    push @out, "    virtual void "._func($cb)."("._arglist($cb).")".$zero.";\n";
                }
                push @out, "    // CALLBACKGEN_GENERATED_END - GENERATED AUTOMATICALLY by callbackgen\n";
            }
            elsif ($line =~ /CALLBACKGEN_XS/) {
                push @out, "// CALLBACKGEN_GENERATED_BEGIN - GENERATED AUTOMATICALLY by callbackgen\n";
                foreach my $cb (sort {$Cbs{$a}{which} cmp $Cbs{$b}{which} || $a cmp $b} keys %Cbs) {
                    next if $Cbs{$cb}{xs_manual};
                    push @out, _xs($cb);
                }
                push @out, _xs_use_cb();
                push @out, "// CALLBACKGEN_GENERATED_END - GENERATED AUTOMATICALLY by callbackgen\n";
            }
            elsif ($line =~ /CALLBACKGEN_KEYWORDS/) {
                push @out, "    // CALLBACKGEN_GENERATED_BEGIN - GENERATED AUTOMATICALLY by callbackgen\n";
                push @out, _h_keywords();
                push @out, "    // CALLBACKGEN_GENERATED_END - GENERATED AUTOMATICALLY by callbackgen\n";
            }
            elsif ($line =~ /CALLBACKGEN/) {
                die "%Error: callbackgen: Unknown pragma: $line";
            }
        }
    }
    @lines = @out;
    if (join('',@lines) ne join('',@orig)
        || $make_xs) {  # Generated file, so touch to apppease make
        print "callbackgen edited $filename\n";
        $fh = IO::File->new(">$filename") or die "%Error: $! writing $filename\n";
        $fh->write(join('',@lines));
        $fh->close;
    }
}
sub _func {
    my $cb = shift;
    return $cb."Cb";
}
sub _arglist {
    my $cb = shift;
    my $args = "VFileLine* fl";
    my $n=0;
    for (my $i=0; $i<=$#{$Cbs{$cb}{args}}; $i+=2) {
        my ($arg,$type) = ($Cbs{$cb}{args}[$i],$Cbs{$cb}{args}[$i+1]);
        $args .= "\n\t" if (($n++%5)==4);
        if ($type eq 'string') {
            $args .= ", const string\& $arg";
        } elsif ($type eq 'bool' || $type eq 'int') {
            $args .= ", $type $arg";
        } elsif ($type eq 'hash') {
            $args .= ", unsigned int arraycnt${n}, unsigned int elemcnt${n}, const VParseHashElem* $arg${n}";
        } elsif ($type eq 'undef') {
            $args .= ", bool";
        } else {
            die "%Error: callbackgen: Unknown type: $arg=>$type\n";
        }
    }
    return $args;
}
sub _xs {
    my $cb = shift;
    my @out;
    push @out, "// GENERATED AUTOMATICALLY by callbackgen\n";
    push @out, "void VParserXs::"._func($cb)."("._arglist($cb).") {\n";
    my $enable = "callbackMasterEna()";
    $enable .= " && m_useCb_${cb}";
    $enable .= " && $Cbs{$cb}{enable}" if $Cbs{$cb}{enable};
    push @out, "    if ($enable) {\n";
    push @out, "        cbFileline(fl);\n";
    my $callargs="";
    my $n=1;
    for (my $i=0; $i<=$#{$Cbs{$cb}{args}}; $i+=2) {
        my ($arg,$type) = ($Cbs{$cb}{args}[$i],$Cbs{$cb}{args}[$i+1]);
        if ($type eq 'string') {
            push @out, "        static string hold${n}; hold${n} = $arg;\n";
            $callargs .= ", hold${n}.c_str()";
        } elsif ($type eq 'bool') {
            push @out, "        static string hold${n}; hold${n} = $arg ? \"1\":\"0\";\n";
            $callargs .= ", hold${n}.c_str()";
        } elsif ($type eq 'int') {
            push @out, "        static string hold${n}; static char num".$n."[30]; sprintf(num${n},\"%d\",$arg); hold${n}=num${n};\n";
            $callargs .= ", hold${n}.c_str()";
        } elsif ($type eq 'hash') {
            $callargs .= ", hasharray_param, arraycnt${n}, elemcnt${n}, ${arg}${n}";
        } elsif ($type eq 'undef') {
            $callargs .= ", NULL";
        } else {
            die "%Error: callbackgen: Unknown type: $arg=>$type\n";
        }
        $n++;
    }
    my $narg = $n-1;
    push @out, "        call(NULL, $narg, \"$cb\"$callargs);\n";
    push @out, "    }\n";
    push @out, "}\n";
    return @out;
}
#######################################################################
sub _h_use_cb {
    my @out;
    push @out, "    struct {  // Bit packed to help the cache\n";
    foreach my $cb (sort {$a cmp $b} keys %Cbs) {
        push @out, "        bool m_useCb_${cb}:1;\n";
    }
    push @out, "    };\n";
    return @out;
}
sub _c_use_cb {
    my @out;
    push @out, "    void set_cb_use() {\n";
    foreach my $cb (sort {$a cmp $b} keys %Cbs) {
        push @out, "       m_useCb_${cb} = true;\n";
    }
    push @out, "   }\n";
    return @out;
}
sub _xs_use_cb {
    my @out;
    push @out, "// GENERATED AUTOMATICALLY by callbackgen\n";
    # Trailing Ena so it doesn't look like it is a callback itself
    push @out, "void VParserXs::useCbEna(const char* name, bool flag) {\n";
    push @out, "    if (0) ;\n";
    foreach my $cb (sort {$a cmp $b} keys %Cbs) {
        push @out, "    else if (0==strcmp(name,\"${cb}\")) m_useCb_${cb} = flag;\n";
    }
    push @out, "}\n";
    return @out;
}
sub _h_keywords {
    my @out;
    (keys %Verilog::Language::Keyword) or die "%Error: Keyword loading failed,";
    push @out, "    static bool isKeyword(const char* kwd, int leng) {\n";
    # If this gets slow, we can use a perfect hashing function and a table to compare
    push @out, "\tstatic set<string> s_map;\n";
    push @out, "\tif (s_map.empty()) {\n";
    my $i=0;
    push @out, "\t    const char* kwds[] = {";
    foreach my $kwd (sort keys %Verilog::Language::Keyword) {
        next if $kwd !~ /^[a-zA-Z_]/;
        push @out, "\n\t\t" if ($i++%7)==0;
        push @out, "\"$kwd\",";
    }
    push @out, "\"\"};\n";
    push @out, "\t    for (const char** k=kwds; **k; k++) s_map.insert(*k);\n";
    push @out, "\t}\n";
    push @out, "\tstring str(kwd,leng);\n";
    push @out, "\treturn s_map.end() != s_map.find(str);\n";
    push @out, "    }\n";
    return @out;
}
#######################################################################
__END__
HideShow 75 lines of Pod
=pod
=head1 NAME
callbackgen - Create callback functions for Verilog-Perl internals
=head1 SYNOPSIS
  make
  This will invoke callbackgen
=head1 DESCRIPTION
Callbackgen is an internal utility used in building Verilog::Parser.
=head1 EXTENSIONS
=over 4
=item //CALLBACKGEN_H_VIRTUAL
Creates "virtual callbackCb(...);"
=item //CALLBACKGEN_H_VIRTUAL_0
Creates "virtual callbackCb(...) = 0;"
=item //CALLBACKGEN_XS
Creates XS code for accepting the callback.
=back
=head1 ARGUMENTS
=over 4
=item --help
Displays this message and program version and exits.
=item --debug
Enable debug.
=item --version
Print the version number and exit.
=back
=head1 DISTRIBUTION
This is part of the L<https://www.veripool.org/> free Verilog EDA software
tool suite.  The latest version is available from CPAN and from
L<https://www.veripool.org/>.
Copyright 2008-2024 by Wilson Snyder.  This package is free software; you
can redistribute it and/or modify it under the terms of either the GNU
Lesser General Public License Version 3 or the Perl Artistic License Version 2.0.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
more details.
=head1 AUTHORS
Wilson Snyder <wsnyder@wsnyder.org>
=head1 SEE ALSO
=cut
######################################################################
### Local Variables:
### compile-command: "./callbackgen "
### End: