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

# ProgParser.pm - parse an Adaptive Perl program and call the codegenerator
# 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 ProgParser;

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

@ISA = qw(Exporter);
@EXPORT = qw(parseProgFile);

my ($buffer, $tok, $lineno, $errs);

sub syntax_error {
    $errs++;
    print STDERR "Syntax error in programfile at line $lineno, at '$tok'.\n";
    &gettoken;
}

sub gettoken {
    $tok = '*EOF*';
    return if (!defined $buffer);

    do {
	if ($buffer eq '') {
	    return unless (defined ($buffer = <PFILE>));
	    $buffer =~ s/\s*#.*$//;
	    $lineno++;
	}
	$buffer =~ s/^[\s\n\t]*//;
    } until ($buffer ne '');

    # print "GETT ", $buffer;

    if ($buffer =~ /^([_\w][_\[\]\{\}\w\d]*)/) {
	$tok = $1;
	$buffer = substr $buffer, length($tok);
	return;
    }

    if ($buffer =~ /^(\S)/) {
	$tok = $1;
	$buffer = substr $buffer, 1;
	return;
    }
}

# "parse" the do part of a traversal, ie. switch off the LL parser and
# look for ^ClassName.(pre|post|fixed): essentially. $rname is the
# name of the traversal routine and $code is a ref to the hash of
# code snippets to be filled
sub pDoSpec {
    my ($rname, $code) = @_;
    my ($codebuf, $kind, $cls);

    $codebuf = $cls = '';
    $kind = 'fooo';

    while(<PFILE>) {
	$lineno++;

	if (/^([\w_][_\w\d]*)\.(pre|post|fixed):$/) {
	    $code->{$cls}{$kind} = $codebuf;
	    $kind = $2;
	    $cls = $1;
	    if (!defined $classes{$cls}) {
		$errs++;
		print STDERR <<EOM;
Classname `$cls' at line $lineno is not mentioned in the classfile.
EOM
	    }
	    $codebuf = '';
	} elsif (/^(initialize|finalize):$/) {
	    $code->{$cls}{$kind} = $codebuf;
	    $kind = $1;
	    $cls = "+$rname";   # so as not to clash with classnames
	    $codebuf = '';
	} elsif (/^endtraversal\b/) {
	    $code->{$cls}{$kind} = $codebuf;
	    $buffer = $';
	    $tok = 'endtraversal';
	    return;
	} else {
	    $codebuf .= $_;
	}
    }
}

sub pFieldName {
    &syntax_error unless ($tok =~ /^[_\w][_\{\}\[\]\w\d]*$/);
    &gettoken;
}

sub pFieldNameList {
    my ($fieldlist) = @_;

    push @$fieldlist, $tok;
    &pFieldName;
    if ($tok eq ',') {
	&gettoken;
	&pFieldNameList;
    }
}

sub pClassName {
    &syntax_error unless ($tok =~ /^([_\w][_\w\d]*)$/);
    &gettoken;
}

sub pClassNameList {
    my ($classlist) = @_;

    push @$classlist, $tok;
    &pClassName;
    if ($tok eq ',') {
	&gettoken;
	&pClassNameList;
    }
}

# return hash of all fields of a class $c, by looking at all superclasses
# of $c.
sub allFields {
    my ($c) = @_;
    my ($cls, %fields);

    foreach $cls ($c, &supers($c)) {
	foreach (keys %{$classes{$cls}{instancevars}}) {
	    $fields{$_}++;
	}
    }
    return %fields;
}

# $forspec is a ref to a hash of hashes, first key is a class reference
# converted to a string, second key is the fieldnames NOT to traverse
# along
sub pForSpec {
    my ($forspec) = @_;
    my (@classlist, @fieldlist, $c, %fields, $clsptr, $cls);
    
    &pClassNameList(\@classlist);
    if ($tok eq 'only') {
	&gettoken;
	&pFieldNameList(\@fieldlist);

	foreach $c (@classlist) {
	    my %allfields = &allFields($c);
	    $clsptr = $classes{$c};
	    if (!defined $forspec->{$clsptr}) {
		$forspec->{$clsptr} = \%allfields;
	    }
	    foreach (@fieldlist) {
		if (!defined $allfields{$_}) {
		    print STDERR "Near line $lineno in programfile: Objects of class $c have no field $_.\n";
		    $errs++;
		}
		delete $forspec->{$clsptr}{$_};
		# print "ONLY: removing positive $_\n";
	    }
	}
    } elsif ($tok eq 'not') {
	&gettoken;
	&pFieldNameList(\@fieldlist);
	foreach $c (@classlist) {
	    my %allfields = &allFields($c);
	    foreach (@fieldlist) {
		if (!defined $allfields{$_}) {
		    print STDERR "Near line $lineno in programfile: Objects of class $c have no field $_.\n";
		    $errs++;
		}
		# print "NOT: adding negative $_\n";
		$forspec->{$classes{$c}}{$_}++;
	    }
	}
    } else {
	&syntax_error;
    }
}

# parse a traversal spec, $rname is the name of the traversal, $param is
# the string of formal parameters to the traversal
sub pTravSpec {
    my ($rname, $param) = @_;
    my (%forspec, $fromclass, @toclasses, %code);

    if ($tok eq 'from') {
	&gettoken;
	$fromclass = $tok;
	&pClassName;
	if ($tok eq 'to') {
	    &gettoken;
	    &pClassNameList(\@toclasses);
	    while ($tok eq 'for') {
		&gettoken;
		&pForSpec(\%forspec);
	    }
	    &syntax_error unless ($tok eq 'do');
	    # notice no gettoken here!
	    &pDoSpec($rname, \%code);
	    &syntax_error unless ($tok eq 'endtraversal');
	    &gettoken;

	    # call graph coloring routine and code generation here
	    &doit($rname, $param, $fromclass, \@toclasses, \%forspec, \%code);
	} else {
	    &syntax_error;
	}
    } else {
	&syntax_error;
    }
}

sub pParam {
    my ($param);

    if ($buffer =~ /^([^\)]*)\)/) {
	$param = $1;
	$buffer = substr $buffer, length($param)+1;
	&gettoken;
    } else {
	$param = '';
	&syntax_error;
    }
    return $param;
}

sub pRoutineName {
    &syntax_error unless ($tok =~ /^[_\w][_\w\d]*$/);
    &gettoken;
}

sub pRoutine {
    my ($rname);
    my ($param);

    if ($tok eq 'traversal') {
	&gettoken;
	$rname = $tok;
	&pRoutineName;
	if ($tok eq '(') {
	    $param = &pParam;
	}
	&pTravSpec($rname, $param);
    } else {
	&syntax_error;
    }
}

sub pProgFile {
  PFLOOP:
    while (defined ($buffer = <PFILE>)) {
	if ($buffer =~ /^\s*traversal\s+/) {
	    # initiate LL(1) parser of traversal spec
	    &gettoken;
	    &pRoutine;
	    $buffer = $tok . $buffer;
	    redo PFLOOP;
	} else {
	    &Codegen::emitCode($buffer) unless $buffer eq '*EOF*';
	}
    }
}

sub parseProgFile {
    my ($file) = @_;

    open(PFILE, $file) || croak "can't open $file: $!\n";
    $lineno = 0;
    $errs = 0;
    $buffer = '';
    &GraphColoring::cleanup;

    &pProgFile;
    close PFILE;
    return ($errs == 0);
}

1;