#!/usr/local/perl5.002/bin/perl

# Codegen.pm - generate and emit the code to a file, a Perl module
# Copyright (C) 1996 Peter Orbaek <poe@daimi.aau.dk>
# This code is freely re-distributable under the GNU General Public License
# Version 1.0 11-May-96

package Codegen;

require 5.002;
use vars qw($codefilename @ISA @EXPORT);
use strict 'vars', 'subs';
use Carp;
use Exporter;
use ClassParser qw(%classes);
use GraphColoring;

@ISA = qw(Exporter);
@EXPORT = qw(doit supers superrefs);

local ($codefilename);
my $tmpdir = $main::ENV{TMPDIR} || '/tmp';

# return the list of all (transitive) superclasses of $cls without duplicates
sub supers {
    my ($cls) = @_;
    my (@todo, %done, $c);

    @todo = keys %{$classes{$cls}{superclasses}};
    while ($c = shift @todo) {
	if (!$done{$c}) {
	    push @todo, keys(%{$classes{$c}{superclasses}});
	    $done{$c}++;
	}
    }
    return keys %done;
}

sub superrefs {
    my ($clsptr) = @_;
    my (@todo, %done, $c);

    @todo = values %{$clsptr->{superclasses}};
    while ($c = shift @todo) {
	if (!defined $done{$c}) {
	    push @todo, values(%{$c->{superclasses}});
	    $done{$c} = $c;
	}
    }
    return values %done;
}

my %revcls;

# generates the recursive calls for all instance fields in %$ns
# if the result type ($otype) of this routine is non-void then
# assume that all the classes with method $name has a ${name}_res
# field of the appropriate type so that the result of calling
# o->name(...) can be stored in o->name_res.
sub cgfields {
    my ($name, $actuals, $forspec, $clsptr, $realclsptr) = @_;
    my ($v);
    my $ns = $clsptr->{instancevars};

    foreach $v (keys %$ns) {
	#print "field: $v, $revcls{$clsptr}, $revcls{$realclsptr}\n";
	#print "xx: ", $revcls{$ns->{$v}}, "\n";
	if ((!defined($forspec->{$realclsptr})
	     or !defined($forspec->{$realclsptr}{$v}))
	     and $ns->{$v}{colored}) {
	    # print "FIELD: $v\n";
	    if ($v =~ /\[([\w\d_]+)\]$/) {
		# $v is an array collection variable
		print CODE "\tmy (\$$1);\n";
		print CODE "\tfor (\$$1 = 0; \$$1 < scalar(\@{\$self->{'$`'}}); \$$1++) {\n";
		print CODE "\t\t\$self->{'$`'}[\$$1]->$name($actuals";
		if ($actuals) {
		    print CODE ", ";
		}
		print CODE "\$$1);\n";
		print CODE "\t}\n";
	    } elsif ($v =~ /\{([\w\d_]+)\}$/) {
		# $v is a hash collection variable
		print CODE "\tmy (\$$1);\n";
		print CODE "\twhile ((\$$1,\$_) = each %{\$self->{'", $`, "'}}) {\n";
		print CODE "\t\t\$_->$name($actuals";
		if ($actuals) {
		    print CODE ", ";
		}
		print CODE "\$$1);\n";
		print CODE "\t}\n";
	    } else {
		print CODE "\t";
		print CODE '$self->{"', $v, '"}->', "$name($actuals);\n";
	    }
	}
    }
}

sub codegen {
    my ($name, $args, $forspec, $code) = @_;
    my (%neighbors, $v, $c, $r, $s);
    my ($actuals) = $args;

    %revcls = reverse %classes;

    foreach $c (keys %classes) {
	if ($classes{$c}{colored}) {

	    $r = 0;
	    %neighbors = %{$classes{$c}{instancevars}};

	    print CODE "sub $c", "::", "$name {\n\tmy (\$self";
	    if ($args) {
		print CODE ", $args) = \@_;\n";
	    } else {
		print CODE ") = \@_;\n";
	    }

	    if (defined $code->{$c}{pre}) {
		print CODE "\t# PRECODE\n";
		print CODE $code->{$c}{pre};
	    }

	    if (defined $code->{$c}{fixed}) {
		print CODE "\t# FIXEDCODE\n";
		$_ = $code->{$c}{fixed};
		s/CALL/$name($actuals)/g;
		print CODE $_;
	    } else {
		foreach $s ($c, &supers($c)) {
		    cgfields $name, $actuals, $forspec, $classes{$s}, $classes{$c};
		}
	    }

	    if (defined $code->{$c}{post}) {
		print CODE "\n\t# POSTCODE\n";
		print CODE $code->{$c}{post};
	    }

	    print CODE "}\n\n";
	} else {
	    if (defined $code->{$c}) {
		print STDERR "In traversal `", substr($name, 1), "':\n";
		print STDERR "Code segments for class $c can't be on object path, ignored.\n";
	    }
	}
    }
}

# init temp file for code generation
sub init {
    my ($file) = @_;

    open(CODE, ">$tmpdir/adap.$$") 
	|| croak "can't write-open $tmpdir/adap.$$: $!\n";
    $codefilename = $file;
}

# the code generation went well, move the temp file to its destination
sub commit {
    my $res;

    close CODE;

    $res = system 'mv', "$tmpdir/adap.$$", $codefilename;
    if ($res >> 8) {
	croak "final mv failed.\n";
    }
    # so that this will work with make, the timestamps of the tmpdir
    # may not be the same as those for the target directory, eg. with
    # AFS and out-of-sync clocks
    system 'touch', $codefilename;
}

# some error occured, drop the temp file
sub rollback {
    close CODE;
    unlink "$tmpdir/adap.$$";
    unlink $codefilename;
}

sub emitCode {
    print CODE @_;
}

# called from ProgParser, generate code for a single traversal spec
sub doit {
    my ($name, $args, $fromclass, $toclasses, $forspec, $code) = @_;
    my ($c);

    &cleanup;  # ready GraphColoring for a new round, resets flags in %classes
    foreach $c (@$toclasses) {
	&iterate($classes{$fromclass}, $classes{$c}, $forspec);
    }

    # generate all the recursive methods for the traversal
    &codegen("_$name", $args, $forspec, $code);

    # generate entry routine for the traversal
    print CODE "sub $fromclass", "::", "$name {\n\tmy (\$self";
    if ($args) {
	print CODE ", $args";
    }
    print CODE ") = \@_;\n";

    if (defined $code->{"+$name"}{initialize}) {
	print CODE "\t# init\n";
	print CODE $code->{"+$name"}{initialize};
    }

    print CODE "\t\$self->_$name($args);\n";

    if (defined $code->{"+$name"}{finalize}) {
	print CODE "\t# final\n";
	print CODE $code->{"+$name"}{finalize};
    }
    print CODE "}\n";
}

sub genobject {
    print CODE <<'EOM';
# Code generated by the Adaptive Perl compiler, do not edit.
# Object class:

package Object;
use vars qw(@ISA);
@ISA = ();

# inheritable object initializer
sub initialize {
	my ($self, %inits) = @_;

	foreach (keys %inits) {	$self->{$_} = $inits{$_}; }
}

# inheritable object constructor, used by all classes
sub new {
	my $class = shift;
	my $self = {};
	bless $self, $class;
	$self->initialize(@_);
	return $self;
}

# inheritable general object displayer, $fh is a filehandle reference
sub display {
	my ($self, $fh) = @_;
	my ($f, $thing);

	print $fh ref($self), ": {\n";
	while (($f, $thing) = each %$self) {
		if (ref $thing) {
			$thing->display($fh);
		} else {
			print $fh "  $f => $thing\n";
		}
	}
	print $fh "}\n";
}

package main;
EOM
}

sub genclasses {
    my ($cls, $supers);

    print CODE <<'EOM';

# Code generated by the Adaptive Perl compiler, do not edit.
# Inheritance stuff:

EOM

    foreach $cls (keys %classes) {
	next if $cls eq 'Object';
	$supers = join(' ', keys(%{$classes{$cls}{superclasses}}), 'Object');
	print CODE '@', $cls, "::ISA = qw($supers);\n";
    }
}

1;