#!/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 @Types %Classes);

#======================================================================
# main

$Debug = 0;
my $opt_classes;
my @Opt_Cpt;
my @Opt_I;
Getopt::Long::config ("pass_through", "no_auto_abbrev");
if (! GetOptions (
		  "help"	=> \&usage,
		  "debug"	=> \&debug,
		  "classes!"	=> \$opt_classes,
		  "<>"		=> \&parameter,
		  )) {
    usage();
}

read_types("$Opt_I[0]/V3Ast.h");
read_types("$Opt_I[0]/V3AstNodes.h");
if ($opt_classes) {
    write_classes("V3Ast__gen_classes.h");
    write_visitor("V3Ast__gen_visitor.h");
    write_intf("V3Ast__gen_interface.h");
    write_impl("V3Ast__gen_impl.h");
    write_types("V3Ast__gen_types.h");
}
foreach my $cpt (@Opt_Cpt) {
    Cpt::process(in_filename=>"$Opt_I[0]/${cpt}.cpp", out_filename=>"${cpt}__gen.cpp");
}

#----------------------------------------------------------------------

sub usage {
    pod2usage(-verbose=>2, -exitval => 2);
    exit (1);
}

sub debug {
    $Debug = 1;
}

sub parameter {
    my $param = shift;
    if ($param =~ /^-+I(\S+)/) {
	push @Opt_I, $1;
    } elsif ($param =~ s/\.cpp$//) {
	push @Opt_Cpt, $param;
    } else {
	die "%Error: Unknown parameter: $param,";
    }
}

#######################################################################

sub read_types {
    my $filename = shift;

    my $fh = IO::File->new($filename) or die "%Error: $! $filename,";
    while (defined (my $line = $fh->getline())) {
	$line =~ s/\/\/.*$//;
	next if $line =~ /^\s*$/;
	if ($line =~ /^\s*(class|struct)\s*(\S+)/) {
	    my $class = $2;
	    my $inh = "";
	    $inh = $1 if ($line =~ /:\s*public\s+(\S+)/);
	    print "class $class : $inh\n" if $Debug;
	    $inh = "" if $class eq "AstNode";
	    if ($inh =~ /Ast/ || $class eq "AstNode") {
		$class =~ s/^Ast//;
		$inh =~ s/^Ast//;
		$Classes{$class} = $inh;
	    }
	}
    }
}

sub open_file {
    my $filename = shift;
    my $fh = IO::File->new($filename,"w") or die "%Error: $! $filename,";
    print $fh "// Generated by astgen // -*- C++ -*-\n";
    return $fh;
}

#----------------------------------------------------------------------

sub subclasses_of {
    my $type = shift;

    my @cllist;
    for (my $subclass = $::Classes{$type}; $subclass; ) {
	push @cllist, $subclass;
	$subclass = $::Classes{$subclass};
    }

    return (reverse @cllist);
}

#----------------------------------------------------------------------

sub write_classes {
    my $fh = open_file(@_);
    foreach my $type (sort (keys %Classes)) {
	printf $fh "class %-20s // ", "Ast${type};";
	foreach my $subclass (subclasses_of($type)) {
	    printf $fh "Ast%-12s ",$subclass;
	}
	printf $fh "\n";
    }
    $fh->close();
}

sub write_visitor {
    my $fh = open_file(@_);
    foreach my $type (sort (keys %Classes)) {
	my $base = $Classes{$type};
	if ($base) {
	    printf $fh "    virtual void visit(Ast${type}* nodep, AstNUser* vup) { visit((Ast${base}*)(nodep),vup); }\n";
	} else {
	    printf $fh "    virtual void visit(Ast${type}*, AstNUser*) = 0;\n";
	}
    }
    $fh->close();
}

sub write_intf {
    my $fh = open_file(@_);
    foreach my $type (sort (keys %Classes)) {
	next if $type eq "Node";	# Special, just a return (this);
	printf $fh "    Ast%-16s cast${type}();\n"
	    ,$type."*";
    }
    $fh->close();
}

sub write_impl {
    my $fh = open_file(@_);
    foreach my $type (sort (keys %Classes)) {
	next if $type eq "Node";	# Special, just a return (this);
	printf $fh "inline Ast%-16s AstNode::cast${type}() { return (dynamic_cast<Ast${type}*>(this)); }\n"
	    ,$type."*";
    }
    $fh->close();
}

sub write_types {
    my $fh = open_file(@_);

    printf $fh "    enum en {\n";
    # Add "at" prefix to avoid conflicting with FOPEN and other macros in include files
    foreach my $type (sort (keys %Classes)) {
	next if $type =~ /^Node/;
	print $fh "\tat",uc $type,",\n";
    }
    printf $fh "\t_ENUM_END\n";
    printf $fh "    };\n";
    printf $fh "    const char* ascii() const {\n";
    printf $fh "	const char* names[] = {\n";
    foreach my $type (sort (keys %Classes)) {
	next if $type =~ /^Node/;
	print $fh "\t\"", uc $type, "\",\n";
    }
    printf $fh "\t\"_ENUM_END\"\n";
    printf $fh "	};\n";
    printf $fh "	return names[m_e];\n";
    printf $fh "    };\n";
    $fh->close();
}

#######################################################################

package Cpt;

sub error {
    my $self = shift;
    my $txt = join('', @_);
    die "%Error: $self->{in_filename}:$self->{in_linenum}: $txt\n";
}

sub print {
    my $self = shift;
    my $txt = join('', @_);
    push @{$self->{out_lines}}, $txt;
}

sub output_func {
    my $self = shift;
    my $func = shift;
    push  @{$self->{out_lines}}, $func;
}

sub _output_line {
    my $self = shift;
    $self->print("#line ",$self->{out_linenum}+2," \"$self->{out_filename}\"\n");
}

sub process {
    my $self = {
	in_filename => undef,
	out_filename => undef,
	out_lines => [],
	out_linenum => 1,
	@_,
    };
    bless $self, __PACKAGE__;

    my $ln = 1;
    my $didln;

    # Read the file and parse into list of functions that generate output
    my $fhi = IO::File->new($self->{in_filename}) or die "%Error: $! $self->{in_filename},";
    while (defined(my $line = $fhi->getline)) {
	if (!$didln) {
	    $self->print("#line $. \"$self->{in_filename}\"\n");
	    $didln = 1;
	}
	if ($line =~ /^\s+(TREE.*)$/) {
	    my $func = $1;
	    $self->{in_linenum} = $.;
	    $self->print("//$line");
	    $self->output_func(sub{my $self=shift; $self->_output_line(); });
	    $self->tree_line ($func);
	    $didln = 0;
	}
	elsif ($line !~ /^\s*\/[\/\*]\s*TREE/
	       && $line =~ /\s+TREE/) {
	    $self->error("Unknown astgen line: $line");
	}
	else {
	    $self->print($line);
	}
    }
    $fhi->close;

    # Put out the resultant file, if the list has a reference to a
    # function, then call that func to generate output
    my $fho = ::open_file($self->{out_filename});
    my @togen = @{$self->{out_lines}};
    foreach my $line (@togen) {
	if (ref $line) {
	    $self->{out_lines} = [];
	    &$line($self);
	} else {
	    $self->{out_lines} = [$line];
	}
	foreach my $out (@{$self->{out_lines}}) {
	    $self->{out_linenum}++ while ($out =~ /\n/smg);
	    print $fho $out;
	}
    }
    $fho->close;
}

sub tree_line {
    my $self = shift;
    my $func = shift;

    $func =~ s!\s*//.*$!!;
    $func =~ s!\s*;\s*$!!;

    if ($func =~ /TREEOP(1?)([VC]?)\s*\(\s*  \"([^\"]*)\"  \s*,\s* \"([^\"]*)\"  \s*\)/sx) {
	my $order = $1; my $doflag = $2; my $from = $3; my $to = $4;
	#$self->print("// $from $to\n");
	if (!$self->{did_out_tree}) {
	    $self->{did_out_tree} = 1;
	    $self->output_func(sub{ my $self=shift;
				    $self->tree_match();
				    $self->tree_base();
				});
	}
	$from =~ /Ast([a-zA-Z0-9]+)\s*\{(.*)\}\s*$/
	    or $self->error("Can't parse from function: $func");
	my $type = $1;
	my $subnodes = $2;
	(::subclasses_of($type)) or $self->error("Unknown AstNode type: $type: in $func");

	my $mif;
	if ($doflag eq '') { $mif = "m_doNConst"; }
	elsif ($doflag eq 'V') { $mif = "m_doV"; }
	elsif ($doflag eq 'C') { $mif = ""; }
	else { die; }
	$subnodes =~ s/,,/__ESCAPEDCOMMA__/g;
	foreach my $subnode (split /\s*,\s*/, $subnodes) {
	    $subnode =~ s/__ESCAPEDCOMMA__/,/g;
	    next if $subnode =~ /^\$([a-z0-9]+)$/gi;   # "$lhs" is just a comment that this op has a lhs
	    $mif .= " && " if $mif;
	    my $subnodeif = $subnode;
	    $subnodeif =~ s/\$([a-zA-Z0-9]+)\.([a-zA-Z0-9]+)$/nodep->$1()->$2()/g;
	    $subnodeif = add_nodep($subnodeif);
	    $mif .= $subnodeif;
	}

	my $exec_func = treeop_exec_func($self, $to);

	$self->{treeop}{$type} ||= [];
	my $n = $#{$self->{treeop}{$type}} + 1;
	my $typefunc = {
	    order => $order,
	    comment => $func,
	    match_func => "match_${type}_${n}",
	    match_if => $mif,
	    exec_func => $exec_func,
	    uinfo_level => ($to =~ /^!/ ? 0:7),
	};
	($typefunc->{uinfo} = $func) =~ s/[ \t\"\{\}]+/ /g;
	push @{$self->{treeop}{$type}}, $typefunc;
    }
    else {
	$self->error("Unknown astgen op: $func");
    }
}

sub add_nodep {
    my $str = shift;
    $str =~ s/\$([a-zA-Z0-9]+)/nodep->$1()/g;
    return $str;
}

our %_Exec_Syms;
our $_Exec_Nsyms;
sub _exec_syms_recurse {
    my $aref = shift;
    foreach my $sym (@{$aref}) {
	if (ref $sym) { _exec_syms_recurse($sym); }
	elsif ($sym =~ /^\$.*/) {
	    if (!defined $_Exec_Syms{$sym}) {
		$_Exec_Syms{$sym} = "arg".($_Exec_Nsyms++)."p";
	    }
	}
    }
}

sub _exec_new_recurse {
    my $aref = shift;
    my $out = "new ".$aref->[0]."(nodep->fileline()";
    my $first = 1;
    foreach my $sym (@{$aref}) {
	if ($first) { $first=0; next; }
	$out .= ", ";
	if (ref $sym) { $out.=_exec_new_recurse($sym); }
	elsif ($sym =~ /^\$.*/) {
	    $out .= $_Exec_Syms{$sym};
	} else {
	    $out .= $sym;
	}
    }
    return $out.")";
}

sub treeop_exec_func {
    my $self = shift;
    my $func = shift;
    my $out = "";
    $func =~ s/^!//;
    if ($func =~ /^\s*[a-zA-Z0-9]+\s*\(/) {  # Function call
	(my $outl = $func) =~ s/\$([a-zA-Z0-9]+)/nodep->$1()/g;
	$out .= $outl.";";
    }
    elsif ($func    =~ /^\s*Ast([a-zA-Z0-9]+) \s*\{\s* (.*) \s* \}$/x) {

	my $nargs = 0;
	my %argnums;  # Number for each argument name

	my $aref = undef;	# Recursive array with structure to form
	my @astack;
	my $forming = "";
	my $argtext = $func . "\000";   # EOF character
	#print "FF $func\n" if $Debug;
	while ($argtext =~ s/^(.)//) {
	    my $tok = $1;
	    #print "TOK: $tok $forming\n" if $tok !~ /[a-zA-Z0-9]/;

	    if ($tok eq "\000") {
	    } elsif ($tok =~ /\s+/) {
	    } elsif ($tok eq "{") {
		my $newref = [$forming];
		push @{$aref}, $newref;
		push @astack, $aref if $aref;
		$aref = $newref;
		$forming = "";
	    } elsif ($tok eq "}") {
		push @{$aref}, $forming if $forming;
		$aref = pop @astack;
		$aref or $self->error("Too many } in execution function: $func\n");
		$forming = "";
	    } elsif ($tok eq ",") {
		push @{$aref}, $forming if $forming;
		$forming = "";
	    } else {
		$forming .= $tok;
	    }
	}
	($aref && ref $aref->[0] && !$aref->[1]) or $self->error("Badly formed execution function: $func\n");
	$aref = $aref->[0];
	#use Data::Dumper; print Dumper($aref),"\n";

	# Assign numbers to each $ symbol
	%_Exec_Syms = ();
	$_Exec_Nsyms = 0;
	_exec_syms_recurse($aref);

	foreach my $sym (sort {$_Exec_Syms{$a} cmp $_Exec_Syms{$b}} (keys %_Exec_Syms)) {
	    my $argnp = $_Exec_Syms{$sym};
	    my $arg = add_nodep($sym);
	    $out .= "AstNode* ${argnp} = ${arg}->unlinkFrBack();\n";
	}

	$out .= "AstNode* newp = " . _exec_new_recurse($aref).";\n";
	$out .= "nodep->replaceWith(newp);";
	$out .= "nodep->deleteTree(); nodep=NULL;";
	#print "FF $out\n" if $Debug;
    } elsif ($func eq "NEVER") {
	$out .= "nodep->v3fatalSrc(\"Executing transform that was NEVERed\");";
    } elsif ($func eq "DONE") {
    } else {
	$self->error("Unknown execution function format: $func\n");
    }
    return $out;
}

sub tree_match {
    my $self = shift;
    $self->print ("    // TREEOP functions, each return true if they matched & transformed\n");
    #use Data::Dumper; print Dumper($self);
    foreach my $base (sort (keys %{$self->{treeop}})) {
	foreach my $typefunc (@{$self->{treeop}{$base}}) {
	    $self->print("    // Generated by astgen\n");
	    $self->print("    bool $typefunc->{match_func}(Ast${base}* nodep) {\n",
			 "\t// $typefunc->{comment}\n",);
	    $self->print(	"\tif ($typefunc->{match_if}) {\n");
	    $self->print(	"\t    UINFO($typefunc->{uinfo_level},(void*)(nodep)<<\" $typefunc->{uinfo}\\n\");\n");
	    $self->print(	"\t    $typefunc->{exec_func}\n");
	    $self->print(	"\t    return true;\n");
	    $self->print(	"\t}\n");
	    $self->print(	"\treturn false;\n");
	    $self->print("    }\n",);
	}
    }
}

sub tree_base {
    my $self = shift;
    $self->print ("    // TREEOP visitors, call each base type's match\n");
    $self->print ("    // Bottom class up, as more simple transforms are generally better\n");
    foreach my $type (sort (keys %::Classes)) {
	my $base = $::Classes{$type};
	my @out_for_type;
	foreach my $base (::subclasses_of($type), $type) {
	    foreach my $typefunc (@{$self->{treeop}{$base}}) {
		my @lines = ("	if ($typefunc->{match_func}(nodep)) return;\n",);
		if ($typefunc->{order}) {
		    unshift @out_for_type, @lines;   # TREEOP1's go in front of others
		} else {
		    push @out_for_type, @lines;
		}
	    }
	}
	$self->print("    // Generated by astgen\n",
		     "    virtual void visit(Ast${type}* nodep, AstNUser*) {\n",
		     "	nodep->iterateChildren(*this);\n",
		     @out_for_type,
		     "    }\n",) if $out_for_type[0];
    }
}

#######################################################################
package main;
__END__

=pod

=head1 NAME

astgen - Generate V3Ast headers to reduce C++ code duplication

=head1 SYNOPSIS

  astgen

=head1 DESCRIPTION

Generates several files for Verilator compilations.

=head1 ARGUMENTS

=over 4

=item --help

Displays this message and program version and exits.

=item --classes

Makes class declaration files

=back

=head1 DISTRIBUTION

Copyright 2002-2011 by Wilson Snyder.  Verilator 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: "./astgen "
### End: