#!/local/bin/perl

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


# $Id: c-gen-ops.perl,v 1.7.1.1 1994/12/28 17:50:26 thoth Exp thoth $

#
# $Log: c-gen-ops.perl,v $
# Revision 1.7.1.1  1994/12/28  17:50:26  thoth
# Constructors and conversions are impossible as friends.
#
# Revision 1.7  1994/05/17  12:57:54  thoth
# Improved operations generation scheme.  Lines from the op.desc file can
# be quoted into the .c file to allow inclusion of infrastructure.  Also
# the op.desc output can be redirected to several files.  The prefix
# directive allows common information (include files) to be included in
# every generated source file.
#
# Revision 1.6  1994/02/12  19:45:10  thoth
# removed cruft.
# improved data hiding.
#
# Revision 1.5  1994/02/03  16:22:48  thoth
# Arguments to binary operations were specified "lhs rhs return" but are
# now specified "return lhs rhs" to be consistent with function declaration
# syntax.
#
# Revision 1.4  1994/01/31  15:56:25  thoth
# What was previously called conversion is really a constructor.  We have
# a new thing that is truly a conversion (for stuff like int->float in the
# int class).
#
# Revision 1.3  1994/01/07  15:12:35  thoth
# Image class is now CoreImage and named image types are
# Image<P,T>.
#
# Revision 1.2  1993/12/29  17:33:18  thoth
# New operator scheme that prevents the need for trivial Image conversions.
#
# Revision 1.1  1993/09/15  13:04:07  thoth
# Initial revision
#
# Revision 1.6  93/05/27  11:46:13  thoth
# Copyright Notices
# 
# Revision 1.5  93/05/18  21:43:00  thoth
# Fixed uninitialized value bug when generating reductions.
# 
# Revision 1.4  93/04/08  13:25:40  thoth
# floats and u_chars are now passed by value.
# 
# Revision 1.3  93/03/18  13:17:03  thoth
# Operator mangling is not yet finished, but covers more cases now.
# We now handle converions from one Image type to another.
# Image-scalar operations with different basetypes
# now generate correct code (I hope).
# 
# Revision 1.2  93/03/10  13:38:55  thoth
# Operator mangling is not yet finished, but covers more cases now.
# Infix detection is now automatic.
# We now handle reducers.
# We now handle unary operations.
# 

#
# Stuff to handle buffering for the prefix stuff
#

sub get_line {
    if (@buffer) {
	return shift(@buffer);
    } else {
	return scalar(<>);
    }
}

sub push_lines {
    push(@buffer, @_);
    #print STDERR "pushed ", scalar(@_), " lines into buffer\n";
}

#
#
#

sub is_imagearg {
	return $_[0] =~ /^I\((.*)\)$/;
}

sub basetype {
	local($_) = @_;
	if (/^I\((.*)\)$/) {
		return $1;
	} else {
		return $_;
	}
}

sub make_opname {
	local($_) = @_;
	s/\+/IAOPpl/g;
	s/-/IAOPmn/g;
	s/\*/IAOPmu/g;
	s:/:IAOPdv:g;

	s/%/IAOPmd/g;
	s/&&/IAOPla/g;
	s/\|\|/IAOPlo/g;
	s/!/IAOPno/g;

	s/&/IAOPba/g;
	s/\|/IAOPbo/g;
	s/\^/IAOPbx/g;
	s/~/IAOPbn/g;

	s/<</IAOPls/g;
	s/>>/IAOPrs/g;

	s/<=/IAOPle/g;
	s/</IAOPlt/g;
	s/==/IAOPeq/g;
	s/!=/IAOPne/g;
	s/>=/IAOPge/g;
	s/>/IAOPgt/g;
	return $_;
}

sub file_substitution {
	local($fname, $op, $subop, $zero, $atype, $ltype, $rtype) = @_;
	open(FILE, "<opgen-templs/$fname") ||
			die "couldn't open opgen-templs/$fname, stopped";
#	print STDERR "zero : $zero. \t ltype: $ltype\n";
	local($_);
	local($/) = -1;
	$_ = <FILE>;
	s/\bOP\b/$op/g;
	s/\bSUBOP\b/$subop/g;
	local($opname) = &make_opname($op);
	if ($opname eq "") {
		$opname = $op;
	}
	# print STDERR $op , " = ", $opname, "\n";
	s/OPNAME/$opname/g;
	s/ATYPE/$atype/g;
	s/LTYPE/$ltype/g;
	s/RTYPE/$rtype/g;
	s/ZERO/$zero/g;
	print $_;
	$/ = '\n';
	close(FILE);
}


@buffer = ();
open(REALOUT, ">&STDOUT") || die "unable to copy stdout";
close(STDOUT);

$pwise = $comm = $bin = -1;

while ($_ = &get_line) {
    if (/^#/) {
	if ($' eq "\n") {
	    print $';
	} else {
	    print "// ",$';
	}
	next;
    } elsif (/^"H?C/) {
	print $';
	next;
    } elsif (/^"H/) {
	next;
    } elsif ( /^\s+$/) {
	next;
    }

    local($bin,$pwise,$comm,$optype) = (0,0,0,0);
    print "/" x 70,
	"\n//\n",
	"// Begin operation support routines for :\n",
	"// ",$_,
	"//\n";
    split;
#    print STDERR join(" ",@_),"\n";
    while (@_) {
    	$_ = shift(@_);
	#print STDERR $_,"\n";

	if ($_ eq "filename") {
	    close(STDOUT);
	    local($filename) = @_;
	    open(STDOUT, ">$filename")
		|| die "unable to open $filename for write";
	    print REALOUT $filename, "\n";
	    #print STDERR "Opened $filename for write \n";

	    print <<EOT
// Emacs -*- C++ -*-

// Machine generated include file, do not modify.

EOT
    ;
	    &push_lines(@file_prefix);
	    @_ = (); last;	# next input line
	} elsif ($_ eq "prefix") {
	    @file_prefix = ();
	    while (<>) {
		last if (/^end$/);

		push(@file_prefix, $_);
	    }
	    #print STDERR "Prefix contains ", scalar(@file_prefix), " lines\n";
	    @_ = (); last;	# next input line

	} elsif ($_ eq "reduction") {
	    $pwise = 0;
	    $bin = 0;
	} elsif ($_ eq "pointwise") {
	    $pwise = 1;
	} elsif ($_ eq "strictrel") {
	    $pwise = 2;
	} elsif ($_ eq "constructor") {
	    $pwise = 3;
	} elsif ($_ eq "conversion") {
	    $pwise = 4;

	} elsif ($_ eq "binary") {
	    $bin = 1;
    	} elsif ($_ eq "unary") {
	    $bin = 0;

	} elsif ($_ eq "commutative") {
	    $comm = 1;
	} elsif ($_ eq "non-commutative") {
	    $comm = 0;

	} else {
	    unshift(@_,$_);
	    last;
	}
    }

    unless (@_) { next; }

    local($op, $subopname, $subop);
    undef($zero);

    $op = shift(@_);
    if ($pwise == 3 || $pwise == 4) {
      $subopname = "none";
      $subop = "";
    } else {
      $subopname = $subop = $op;
    }
    while (1) {
	if ($_[0] =~ /^subop=/) {
	    $subopname = $subop = $';
	} elsif ($_[0] =~ /^zero=/) {
	    $zero = $';
	} else {
	    last;
	}
	shift(@_);
    }

    $infix = ($subop =~ s/^operator//);
    $opeq = ($subop =~ m/=$/);


    if ($pwise==0) {
	local($rtype, $argtype) = @_;
	(&is_imagearg($argtype) && !&is_imagearg($rtype)) || die "reductions are from images to scalars. stopped";
	defined($zero) || die "reductions require a zero.";
	&file_substitution("reduce_".($infix?"op":"fn")."_nz",
		$op, $subop, $zero, &basetype($rtype), &basetype($argtype),
		" #ERROR# ");
    } elsif ($pwise==3) {
	if (1) {
	    print "//** constructors are obsolete?\n";
	} else {
	    local($lhs) = @_;
	    (&is_imagearg($op) && &is_imagearg($lhs)) || die "constructor must be from image to image. stopped";
	    &file_substitution("constructor", $op, $op, "#error#",
			       &basetype($op), &basetype($lhs), " #ERROR# ");
	}
    } elsif ($pwise==4) {
	if (1) {
	    print "//** conversions are obsolete?\n";
	} else {
	    local($lhs) = @_;
	    (&is_imagearg($op) && &is_imagearg($lhs)) || die "conversion must be from image to image. stopped";
      &file_substitution("conversion", $op, $subop, "#error#",
			       &basetype($op), &basetype($lhs), " #ERROR# ");
	}
    } elsif ($bin) {
	local($rtype, $lhs, $rhs) = @_;

	$commcode = $comm;
	if (&is_imagearg($lhs)) {
	    if (&is_imagearg($rhs)) {
		$arity = "II";
		$commcode = $comm && (&basetype($lhs) eq &basetype($rhs));
	    } else {
		$arity = "Is";
		$commcode = $comm && (&basetype($lhs) eq $rhs);
	    }
	} else {
	    if (&is_imagearg($rhs)) {
		$arity = "sI";
		$commcode = $comm && ($lhs eq &basetype($rhs));
	    } else {
		die "Non-image operation, stopped";
	    }
	}
	&file_substitution("b".
			   ($pwise==2 ? "sr" : "pw")."_".
			   ( $commcode ? "c":"nc").
			   "_${arity}_".($infix ? "op":"fn"),
			   $op, $subop, "#error#", &basetype($rtype),
			   &basetype($lhs),&basetype($rhs));
    } else { # unary
	local($rtype, $arg) = @_;
	if ($opeq) {
	    print "// There are none (it's inline)\n";
	} else {
	    &file_substitution("upw", $op, $subop, "#error#",
			       &basetype($rtype),
			       &basetype($arg),"");
	}
    }
    print "\n";
}

exit 0;

print<<EndOfDescription

Lines beginning with a # are ignored.


EndOfDescription
