#!/local/bin/perl

#
#	Copyright 1993, Center for Computer Vision and Visualization,
#	University of Florida.  All rights reserved.
#


#
# $Log: g++-instantiate.perl,v $
# Revision 1.13  1994/10/18  18:07:04  thoth
# the requires keyword now handles multiple classes and whitespace
# at the end of the line.
#
# Revision 1.12  1994/10/12  20:46:07  thoth
# Added ability to quote text into the generated instantiation files.
#
# Revision 1.11  1994/10/11  18:14:38  thoth
# Object files are now placed in ANSIinst/ unless the -repository argument
# is supplied with a different directory name.
# // comments are now supported.
#
# Revision 1.10  1994/10/06  17:57:33  gmt
# *** empty log message ***
#
# Revision 1.9  1994/10/04  18:25:27  gmt
# Added code to generate instnace for SC++ 7 on the mac.
#
# Revision 1.8  1994/10/03  20:30:04  thoth
# added ability to give prefix to the auto-generated dos names.
#
# Revision 1.7  1994/10/03  14:01:58  thoth
# Added -larry option to use .cpp files instead of .c files.
# Added "requiring" directive for instantiations that need non-type-related
# files.
#
# Revision 1.6  1994/09/29  18:27:43  thoth
# fix location of borland #pragma.
# Fix problem where requirements were accumulating.
#
# Revision 1.5  1994/09/29  18:11:20  thoth
# Added -dos command flag to override user-supplied module names with
# numbers.  This is necessary due to the so-called DOS file system.
# Comments in .desc file are now passed through slightly digested to
# the C++ file.
#
# Revision 1.4  1994/09/29  17:42:28  thoth
# Added despooging for storage qualifiers and redundant keywords likely
# to appear in function declarations.
# Added support for Borland-style instantiation.
# Added support for comments in the .desc file.
#
# Revision 1.3  1994/09/27  18:38:50  thoth
# fixed bug where $instrepository wasn't being created.
# added capability to instantiate function templates.
#
# Revision 1.2  1994/09/22  19:33:46  thoth
# Modifications to allow grouping of several instantiations into one
# object file.
#
# Revision 1.1  1994/09/16  17:57:55  thoth
# Initial revision
#

$mac = 1 if( $0 =~ /mac/i );

$unique_number=0;
$builds_succeeded = 1;
$nobuild=0;
$thorough=1;

if( $mac )
{
    $instrepository = ":template_instances";
    $nobuild = 1;
    $thorough = 0;
}
else
{
    $instrepository = "./ANSIinst";
}



#
# eliminates duplicates in an array
#

sub uniq_array {
    local (@rval, %seen, $_);
    foreach (@_) {
	unless ($seen{$_}) {
	    push(@rval, $_);
	    $seen{$_} = 1;
	}
    }
    return @rval;
}

#
# subroutine to get every other element of an array, starting with the
# first one
#

sub every_other {
    local(@rval);
    while (@_) {
	push(@rval, shift(@_));
	shift(@_);
    }
    return @rval;
}

%MANGLINGS = ("int", "i",
	      "char", "c",
	      "short", "s",
	      "long", "l",
	      "float", "f",
	      "double", "d");

#
# Translate the punctuation-heavy type name into something the linker
# can handle (even though we aren't targeting a linker, we're targeting
# the filesystem).
#

sub mangle {
    local($_) = @_;
    #print "asked to mangle $_\n";
    s/\s*([<,>])\s*/\1/g;
    if (/<.*>/) {
	local (@chars) = split(//);
	local($count, $stage)=(0,0);
	local($cname, $arg,@args);
	for ($i=0; $i<@chars; $i++) {
	    if ($chars[$i] eq "<") {
		$arg .= $chars[$i] if ($count>0);
		$count++;
	    } elsif ($chars[$i] eq ">") {
		$count--;
		if ($count==0) {
		    push(@args, $arg);
		} else {
		    $arg .= $chars[$i];
		}
	    } elsif ($chars[$i] eq "," && $count==1) {
		push(@args, $arg);
		$arg="";
	    } elsif ($count==0) {
		$cname .= $chars[$i];
	    } else {
		$arg .= $chars[$i];
	    }
	}
	die "$0: gnarled template name, \$count==$count " unless $count==0;
	local($allargs)="_";
	foreach $arg (@args) {
	    $allargs .= &mangle($arg);
	}
	local($rval) = $cname . "__pt__" . length($allargs) . $allargs;
	return length($rval).$rval;
    } elsif (/^\s*unsigned\s+/) {
	return "U".&mangle($');
    } elsif (defined($MANGLINGS{$_})) {
	return $MANGLINGS{$_};
    } else {
	return length($_).$_;
    }
}

#
#
#

sub ctime_of_file {
    local ($fname) = @_;
    local (@crap) = stat($fname);
    return $crap[10];
}

#
# returns true if the file named by the first argument was modified
# more recently than all the other files named.
#

sub check_older {
    local ($target, @sources) = @_;

    return 0 if ( ! -f $target );

    local($tct) = &ctime_of_file($target);
    local ($_);
    foreach (@sources) {
	if ($tct < &ctime_of_file($_)) {
	    # print "$_:$tct is older than $target:", &ctime_of_file($_), "\n";
	    return 0;
	}
    }
    return 1;
}

#
# We run the source file through the preprocessor to check what include
# files it is dependent on.  We then check to see if any of them have
# changed since it was last built.  If any have, then we return 0,
# signaling that the .o file is out-of-date
#

sub thorough_check {
    local ($fname)=@_;

    local (@included);

    pipe(READ,WRITE) || die "unable to open pipe for preprocessor communication";

    local($|)=1;
    print ""; print STDERR "";

    local ($childpid) = fork;

    $|=0;

    if ($childpid) {
	close(WRITE);
	local ($_);
	while (<READ>) {
	    if (/^\s*#\s*\d+\s*["<](.*)[">]\s*$/) {
		push (@included, $1);
	    }
	}
	waitpid($childpid, 0);
    } else {
	close(READ);
	open(STDOUT,">&WRITE");
	exec $ENV{CCC}, "-E", @CPPARGS, $fname;
	die "$0: Error: unable to exec $ENV{CCC} "
    }

    @included = &uniq_array(@included);
#    print join ("\n", @included);

    local($oname);
    ($oname = $fname) =~ s/\.c$/.o/;

    return &check_older($oname, @included);
}

#
# Given the name of a C++ source file and a list of dependencies, decide
# if the corresponding .o needs to be recompiled, and recompile if so.
#

sub build_from {
    local($fname) = @_;

    local($oname, $oname2);
    ($oname = $fname) =~ s/\.c$/.o/;

    if ($thorough ?&thorough_check($fname): &check_older($oname, @_)) {
	print "$oname is up to date\n";
	return;
    }

    ($oname2 = $oname) =~ s-^.*/--g;

    # some compilers put the .o file in the current directory regardless
    die "$0: Error: $oname2 exists in current directory.  Move it out of the way or delete it please. " if ( -e $oname2 );

    local($|);
    $|=1;
    print STDOUT ($nobuild?"would build":"building")," $oname from $fname\n";

    return if ($nobuild);


    local ($childpid);
    $childpid = fork;
    if ($childpid) {
	waitpid($childpid, 0);
    } else {
	exec $ENV{CCC}, "-c", @CPPARGS, $fname;
	die "$0: Error: unable to exec $ENV{CCC} "
    }
    #system("gnumake $oname");

    if ($? == 0) {
	# everything went OK

	if ( -e $oname2 ) {
	    rename ($oname2, $oname)
		|| die "$0: error: unable to rename $oname2 to $oname ";
	}
    } else {
	if ($fragile) {
	    die "$0: build of $oname failed.  Aborting.\n";
	} else {
	    warn "$0: build of $oname failed.  Continuing despite error\n";
	    $builds_succeeded=0;
	}
    }
}

#
# This package is in charge of accumulating output and eventually
# emitting a source file that gets compiled to a .o.  It is a separate
# package from main because it acts like a separate task.
#

package emit;

$unique_file_number = 0;	# we may have to use the ar-remangling file :(

sub set_filename {
    local ($_) = @_;

    if ($main'dos) {
	$_ = $main'dosprefix . ($unique_file_number++); # throw away whatever they told us

    } elsif (/^\s*mangle\s+/) {
	$_ = &main'mangle($'); #'
	s/^\d+//;
    }

    if (defined($fname)) {
	warn "$0: emission filename redefined from ",$fname," to ", $_;
    }

    if( $main'mac ) 		# '
       {
	   $fname = $main'instrepository.":".$_.".c"; #'
       }
       else
       {
	   $fname = $main'instrepository."/".$_.".c"; #'
       }

    $fname .= "pp" if ($main'larry);
}

sub emit_string {
    die "$0: attempt to emit code without an output filename"
	unless (defined($fname));

    local($_);
    foreach (@_) {
	$output .= $_;
    }
}

sub add_requirements {
    local ($_, $i);
    foreach $_ (@_) {
	for ($i=0; $i<@requirements; $i++) {
	    last if ($_ eq $requirements[$i]);

	}
	if ($i>=@requirements) {
	    push(@requirements, $_);
	    s/\.c/.cpp/ if $main'larry;
	    &emit_string("#include $_\n");
	}
    }
#    @requirements = (@requirements, @_);
}

#
# The real meat of the emit package.
#  It generates the source file and builds it.
#

sub end_module {
    die "$0: attempt to finalize module that has no filename"
	unless (defined($fname));

    if ($main'borland) { #'
	$output = "\n#pragma option -Jgd\n\n" . $output;
    }

    if (0) {
	local ($includes, $_);
	foreach (&main'uniq_array(@requirements)) { #'){
	    s/\.c/.cpp/ if $main'larry;
#	    print $main'larry, " is larry ($_)\n";
	    $includes .= "#include ".$_."\n";
	}
	$output = $includes . $output;
#	print "includes are $includes\n";
    }

    unless ( -d $main'instrepository ) { #' ){
	mkdir($main'instrepository, 0777) #')
	      || die "$0: Error: Unable to create instantiation repository $instrepository ";
    }

    # check to see if we would actually change the file
    if ( -e $fname ) {
	open(FILE, "<$fname") || die "$0: error during dependency check.  Unable to open $fname for read ";
	local ($/) = -1;
	local ($_) = <FILE>;
#	print length($_) , " =? ", length($output), "\n";
#	print $output;
	if ($_ eq $output) {
          $output = "";    # don\'t rewrite the file
	}
    }

    if ($main'nobuild>1) { #') {
	if ($output ne "") {
	    print "$0: would rewrite $fname\n";
	} else {
	    print "$0: $fname would be unchanged\n";
	}
    } else {
	if ($output ne "") {   # make sure we\'re making changes to the file
	    open(FILE, ">$fname") || die "$0: unable to open $fname for write";
	    print FILE $output;
	    close(FILE);
	}

	&main'build_from($fname, @requirements) #'
	    unless $main'nobuild;
    }

    undef ($fname);
    undef(@requirements);
    $output="";
}

package main;

#
# Emit code to command the compiler to instantiate a template
# with certain args.
#

sub instantiate {
    local($cn) = @_;
    local ( $isfunction, @_);

    local($shortcut) = (0);

    $shortcut=1 unless defined($emit'fname); #')

    &emit'set_filename("mangle ".$cn)	#'
	if $shortcut;

    {
	local($shred) = ($cn);
	$isfunction = ($shred =~ s/(operator.*|\w+)\(/(/); # function instantiation
		       defined($foo'foo); #'))
	@_ = &every_other(split(/(\s*[<,>()*&;])+\s*/, $shred));
    }

#    print "classes in $cn: ", join(", ", @_), "\n";

    local($_, %classes, @classes);
    foreach $_ (@_) {
	s/\s*(const|volatile|class|struct|enum|union)\b//g;
	s/^\s+//;
	s/\s+$//;
	unless (defined $classes{$_}) {
	    push(@classes, $_);
	    $classes{$_} = 1;
	}
    }
#    print "classes in $cn: ", join(", ", @classes), "\n";

    local($construct) = "";

    $construct .= "\n// new instantiation\n";

#    $construct .= "// mangled to ". $mangling. ", ok?\n";


    $construct .= "#pragma template_access public\n" if( $mac );

    local ($first);
    $first = 1;
    #$construct .= "// first= $first\n";

    foreach $_ (@classes) {
	die "$0: Error: Unknown class $_ " unless defined $REQUIRES{$_};
	local($include);
	local (@requirements);
	push(@requirements, split(",", $REQUIRES{$_}));
	# $construct .= "// for $_ first= $first\n";
	if ($first) {
	    push(@requirements, split(",", $IREQUIRES{$_}));
	    $first=0;
	}
	&emit'add_requirements(@requirements); #'
    }
    if ($isfunction) {
	if ($borland) {	#'
	    local ($f);
	    $construct .= "static void slack" . $unique_number++ #'
	    . "()\n";
	    $f = $cn;
	    $f =~ s/(operator.*|\w+)\(/(*f)(/; defined ($foo'foo); #'))
	    local($funcname) = $1;
	    $construct .= "{\n  $f;\n  f = $funcname;\n}\n";
	} elsif ($mac) {     
	    # Get rid of the return value;
	    $cn =~ s/^\s*\S+\s*//;

	    # Get rid of the trailing ';'
	    $cn =~ s/;\s*$//;

	    $construct .= "#pragma template ". $cn . "\n";
	} else {
	    # ANSI
	    $construct .= "template ". $cn . ";\n";
	}
    } else {
	if ($borland) {	#'
	    $construct .= "typedef $cn slack" . $unique_number++ . ";\n";
	} elsif ($mac) {     
	    $construct .= "#pragma template $cn\n";
	} else {
	    # ANSI
	    $construct .= "template class " . $cn . ";\n";
	}
    }

    &emit'emit_string($construct);

    &emit'end_module
	if $shortcut;
}

######################################################################
#
# main control flow
#
######################################################################

{
# teach this perl script that builtins don\'t need include files
    local($a,$b, $c);
    foreach $a ( "unsigned", "signed", "" ) {
	foreach $b ( "char", "short", "int", "long", "long long" ) {
	    $c = $a." ".$b; $c =~ s/^\s+//;
	    $REQUIRES{$c} = "";
	}
    }
    foreach $a ("float", "double", "long double" ) { $REQUIRES{$a} = ""; }
}

# parse arguments 

@CPPARGS=();
{
    local(@files, $_);

    while (@ARGV) {
	$_ = shift @ARGV;
	if ($_ eq "-n") {
	    $nobuild=1;
	    # disable compiling of source
	} elsif ($_ eq "-N") {
	    $nobuild=2;
	    # NYI: disable generation of source files
	} elsif ($_ eq "-sloppy") {
	    $thorough=0;
	    # disable the preprocessing to determine dependencies;
	} elsif ($_ eq "-repository" ) {
	    $instrepository = shift;
	} elsif ($_ eq "-borland") {
	    $borland=1;
	    # Borland C++ has different template instantiation mechanisms.
	} elsif ($_ eq "-dos") {
	    $dos=1;
	    $dosprefix = shift;
	    # AUGH! we have to fit inside DOS filename restriction.
	} elsif ($_ eq "-larry") {
	    $larry=1;
	    # Larry can\'t figure out how to make Borland
	    # compile .c files as C++ code
	} elsif ($_ eq "-fragile") {
	    $fragile=1;
	    # break if any compilations failed.  Default is to bull on through
	} elsif (/^-/) {
	    push(@CPPARGS, $_);
	    # anything else with a dash is an argument to the compiler
	} else {
	    push(@files, $_);
	    # anything without a dash must be an input file.
	}
    }
    @ARGV=@files;
}

# check environment

$ENV{CCC} = "c++" unless defined $ENV{CCC};

while ( <> ) {
    chop;

    if (/^\s*"/) { #") {
	&emit'emit_string($', "\n"); #'
	next;
    } elsif (s-(#|//)(.*)-- && defined ($emit'fname)) { #'))
	&emit'emit_string("// $1\n"); #'
    }

    if ( /^\s*$/ ) {
    } elsif ( /\s+requires\s*/ ) {
	local ($classes, $includes) = ($`, $');
	$includes =~ s/\s*$//;
	local ($headers, $implementation) = split( /\s+and\s+/, $includes );
	local ($class);
	foreach $class (split(/\s*,\s*/, $classes)) {
	    $REQUIRES{$class} = $headers;
	    $IREQUIRES{$class} = $implementation;
	}

    } elsif ( /^\s*instantiate\s+/ ) {
	&instantiate($');
    } elsif ( /^\s*requiring\s+/ ) {
	&emit'add_requirements($');

    } elsif ( /^\s*filename\s+/ ) {
	&emit'set_filename($');
    } elsif ( /^\s*end_module\s*$/ ) {
	&emit'end_module($');

    } else {
	die "$0: Unrecognized directive: $_ ";
    }

}

if ($builds_succeeded) {
    exit 0;
} else {
    die "$0: One of the subsidiary compiles failed.  Exiting with error\n";
}
