#
# The contents of this file are subject to the Netscape Public License
# Version 1.0 (the "NPL"); you may not use this file except in
# compliance with the NPL.  You may obtain a copy of the NPL at
# http://www.mozilla.org/NPL/
#
# Software distributed under the NPL is distributed on an "AS IS" basis,
# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
# for the specific language governing rights and limitations under the
# NPL.
#
# The Initial Developer of this code under the NPL is Netscape
# Communications Corporation.  Portions created by Netscape are
# Copyright (C) 1998 Netscape Communications Corporation.  All Rights
# Reserved.
#

#
# nad.pl
#
# Takes a nad file (Netscape Architecture Definition) and
# produces a header with the Terminals and Named rules in it
# and prints the BURG specification to stdout.
#
# Usage:
#   perl nad.pl <nad file> <PrimitiveOperations source> <PrimitiveOperations Enum FN> <DataNodeTemplates FN> <Named Rule Enum File> > <Burg File>
#

# rules in BURG must be >= 1
# terminals in BURG must be >= 1

# Fields of a $gPrimitiveInfo structure
$nameIndex = 0;
$categoryIndex = 1;
$usageIndex = 2;
$commentIndex = 3;

# DataNode flag numbers
$dnIsReal = 0;
$dnCanRaiseException = 1;
$dnIsRoot = 2;

# Special kinds
$voidKind = "vkVoid";
$shortOrigin = "aoVariable";

# grab the arguments
($NadFile, $PrimitiveOperationsSourceFN, $PrimitiveOperationsEnumFN, $DataNodeTemplateFN, $BurgHeaderFN) = @ARGV;

#print STDERR "$PrimitiveOperationsSourceFN\n";

# read PrimitiveOperation infos
open PrimitiveOperationsSourceFN or die "Couldn't open $PrimitiveOperationsSourceFN: $!\n";
$readingStage = 0;
while (<PrimitiveOperationsSourceFN>)
{
	if ($readingStage == 0) {
		if (/^\s*((?:\/\/.*)?\n)$/) {
			push @headerLines,$1;
		} else {
			$readingStage = 1;
		}
	}
	if ($readingStage == 1) {
		if (/^\s*ARG-ORIGIN\s+'(.)'\s+(\w+)\s*;\s*\n$/) {
			$argOrigins{$1} = $2;
		} elsif (/^\s*ARG-KIND\s+'(.)'\s+(\w+)\s*;\s*\n$/) {
			$argKinds{$1} = $2;
		} elsif (/^\s*SHORT-ARG\s+'(.)'\s+(\w+)\s*;\s*\n$/) {
			$shortArgs{$1} = $2;
		} elsif (!/^\s*(\/\/.*)?\n$/) {
			$readingStage = 2;
		}
	}
	if ($readingStage == 2) {
		die "Bad line: $_\n" unless m/^(?:\s*{(\w+),\s*(\w+),\s*"([^"\s]*)"})?(?:\s*(\/\/.*))?\n?$/;
		# print STDERR "--->$1***$2***$3***$4\n";
		#($name, $category, $usage, $comment) = ($1, $2, $3, $4);
		push @gPrimitiveInfo, [$1, $2, $3, $4];
	}
}
close PrimitiveOperationsSourceFN;

$argOrigins = "";
$argKinds = "";
$shortArgs = "";
foreach (keys %argOrigins) {$argOrigins .= $_;}
foreach (keys %argKinds) {$argKinds .= $_;}
foreach (keys %shortArgs) {$shortArgs .= $_;}
#print STDERR "argOrigins = \"$argOrigins\"\n";
#print STDERR "argKinds = \"$argKinds\"\n";
#print STDERR "shortArgs = \"$shortArgs\"\n";

$maxArgOriginNameLength = maxStringLength(values %argOrigins);
$maxValueKindNameLength = maxStringLength(values %argKinds, values %shortArgs);
$maxPrimitiveNameLength = maxStringLength(map $_->[$nameIndex], @gPrimitiveInfo);
$maxCategoryNameLength = maxStringLength(map $_->[$categoryIndex], @gPrimitiveInfo);

# do DataNodeTemplates
unlink ($DataNodeTemplateFN) or break;
outputNodeTemplates($DataNodeTemplateFN, \@gPrimitiveInfo);

# do PrimitiveOperations enum
unlink ($PrimitiveOperationsEnumFN) or break;
$gLastPrimEnumName = outputEnumFromListX("PrimitiveOperation", $PrimitiveOperationsEnumFN, 0, \@gPrimitiveInfo, \&primInfoToEnumDescriptor);
open FILE, ">>$PrimitiveOperationsEnumFN" or die "Couldn't open $PrimitiveOperationsEnumFN: $!\n";
print FILE "\nconst uint nPrimitiveOperations = $gLastPrimEnumName + 1;\n";
close FILE;

# now handle the BURG section of the file
open NadFile or die "Couldn't open $NadFile: $!\n";
while (<NadFile>)
{
    if (/%(.*)/)
    {
        $section = $1;

        if ($section eq "terminals")
        {
            #print STDERR "processing terminals...\n";
            while(<NadFile>)
            {
                if (/%/)
                {
                    last;
                }
                else
                {
                    chop;
                    $ts[++$#ts] = $_;
                }
            }
        }
        elsif($section eq "startsymbols")
        {
            #print STDERR "processing startsymbols...\n";
            while(<NadFile>)
            {
                if (/%/)
                {
                    last;
                }
                else
                {
                    chop;
                    $sss[++$#sss] = $_;
                }
            }            
        }
        elsif($section eq "top")
        {
            #print STDERR "processing top...\n";
            while(<NadFile>)
            {
                if (/%/)
                {
                    last;
                }
                else
                {
                    $top[++$#top] = $_;
                }
            }            
        }
        elsif($section eq "nonterm_header")
        {
           #print STDERR "processing nonterm_header...\n";
            while(<NadFile>)
            {
                if (/%/)
                {
                    last;
                }
                else
                {
                    $BurgHeaderFN[++$#header] = $_;
                }
            }            
        }
        elsif($section eq "grammar")
        {
            #print STDERR "processing grammar...\n";
            while(<NadFile>)
            {
                if (/%/)
                {
                    last;
                }
                else
                {
                    chop;
					$old = $_;
					if (!s/\/\/.*//)
					{
						$_ = $old;
						if (s/\w//)
						{
							$_ = $old;
							($rules[++$#rules], $costs[++$#costs], $rulenames[++$#rulenames])  = split(/\$/, $_);
							$costs[$#costs] =~ s/\s//g;
							$rulenames[$#rulenames] =~ s/\s//g;
						}
					}
                } 
            }            
            

        }
    }
}

# Do NamedRules enum file
unlink ($BurgHeaderFN) or break;
outputEnumFromListX("NamedRules", $BurgHeaderFN, 1, \@rulenames, \&ruleNameToEnumDescriptor);

# print out cruft at top
print "%{\n";
foreach $x (@top)
{
    print $x;
}
print "%}\n";

# print out start symbol
# we use a false one so we can have multiple start symbols
print "%start xxxGeneratedStartSymbol\n";

# print terminals
$termno = 1;
foreach $x (@primoperations)
{
	$_ = $x;
	if (s/\w+//)
	{
   		print "%term $x = $termno\n";
    	$termno++;
	}
}

# convert a primitive info into a list of terminal names
# skip first terminal which is pkNone
@ts = ();
foreach $x (@gPrimitiveInfo[1..$#gPrimitiveInfo])
{
	push @ts, $x->[$nameIndex];
}

# print out "%term BLAHBLAH = number"
foreach $x (@ts)
{
	$_ = $x;
	if (s/\w+//)
	{
   		print "%term $x = $termno\n";
    	$termno++;
	}
}

# start counting anonruleno's at the number rules + number of start symbols
$anonruleno = $#rules +1 + $#sss + 1;
print "%%\n";


# now print out the start symbols
# start symbols are anonymous rules
foreach $x (@sss)
{
    print "xxxGeneratedStartSymbol:\t$x \t = $anonruleno (0);\n";
    $anonruleno++;
}


# now print out the rules
# if it is a named rule we store it away in 
# an array of named rules so we can print the enum out later
# named rules start at 0 anonymous rules pick up where sss's left of
$namedruleno = 1;
$i = 0;
foreach $x (@rules)
{
	#print STDERR "$i rulename:  ***$rulenames[$i]*** ***$costs[$i]***\n";
	
    if ($rulenames[$i] eq "")
    {
        # this is an anonymous rule
		#print STDERR "anon\n";

        print "$x\t = $anonruleno ($costs[$i]);\n"; 
        $anonruleno++;
    }
    else
    {
        print "$x\t = $namedruleno ($costs[$i]);\n";
        $namedrules[++$#namedrules] = $rulenames[$i];
        $namedruleno++;
    }

    $i = $i + 1;
}

print "%%\n";


# primInfoToEnumDescriptor
#
# Convert a primInfo to a ($enumname, $enumcomment) list
sub primInfoToEnumDescriptor
{
	my ($primInfo) = @_;
	return ($$primInfo[$nameIndex], $$primInfo[$commentIndex]);
}

# primInfoToEnumDescriptor
#
# Convert a namedrule (a string) to a ($enumname, $enumcomment) list
sub ruleNameToEnumDescriptor
{
	my ($name) = @_;
	return ($name, "");	
}


#	outputGeneratedHeader
#
#	Output header of generated file.
sub outputGeneratedHeader
{
	my ($fh, $filename) = @_;
	
	$_ = $filename;
	
	if (!(s/.*:([^:]+)\Z/$1/))
	{
		s/(.*)/$1/;
	}
	
	$filename = $1;

	print $fh "//\n// $filename\n//\n// Generated file\n// DO NOT EDIT\n//\n\n";
}


# outputEnumFromListX
#
# in
#    name: name of this enum, will be printed as a comment above
#    fileName: file name which to append this enum
#    enumBase: value of first enum (usually either 0 or 1)
#    items: list of items
#	 convertFunc: function that transforms an item into a (enumname, enumcomment) list
#
# out
#    the file $fileName with the appended enum
#    returns the last enum output
# 
sub outputEnumFromListX
{
    my ($name, $fileName, $enumBase, $items, $convertFunc) = @_;
	my $i;
	my $lastEnum;
	my $lastName;

    for ($i = $#$items; $i >= 0; $i--)
    {
		my ($name, $comment) = &$convertFunc($$items[$i]);
		if ($name ne "")
		{
			$lastEnum = $i;
			$lastName = $name;
			last;
		}
	}
	#($hi, $crap) = &$convertFunc($$items[$lastEnum]);
	#print STDERR "----> $lastEnum, $hi <---\n";

    open FILE, ">>$fileName" or die "Couldn't open $fileName: $!\n";

	outputGeneratedHeader(\*FILE, $fileName);
    print FILE "enum $name\n";
    print FILE "{\n";

	my $enumCount = $enumBase;		# used so we don't count spaces, but still go through the whole array
    for ($i = 0; $i <= $#$items; $i++)
    {
		# print previous item's comma and comment
		# if it has a name, then we print out the enum name, else we just print the comment
		my ($name, $comment) = &$convertFunc($$items[$i]);

		if ($name ne "")
		{
			printf FILE "\t%-20s\t%s\n", "$name = $enumCount" . ($i == $lastEnum ? "" : ","), $comment;
			$enumCount++;
		}
		elsif ($comment eq "")
			{printf FILE "\n";}
		else
			{printf FILE "\t%-20s\t%s\n", "", $comment;}
    }
    print FILE "};\n";
    close FILE;

	return $lastName;
}

sub getResult
{
	my ($expression) = @_;
	
	#print STDERR "getResult: $expression\n";
	$_ = $expression;
	if (s/(.*)?->(.*)/$1 $2/)
	{
		#print STDERR "getResult -- lhs -- : $1\n";
		#print STDERR "getResult -- rhs -- : $2\n";
		return $2;
	}
}

sub getArgs
{
	my ($expression) = @_;
	my @returnVal;
	#print STDERR "return val is $#returnVal\n";
	
	$_ = $expression;
	if (s/(.*)?->(.*)//)
	{	
		$lhs = $1;
		#print STDERR "$lhs XXXX $2\n";
		$_ = $lhs;
		
		while (s/\b([A-Za-z\(\)]+)//)
		{
			#print STDERR "$1 foo \n";
			$returnVal[++$#returnVal] = $1;
		}
	}
	
	#print STDERR "return val is $#returnVal\n";
	return @returnVal;
}


#
# Given a list of strings, return the length of the longest one.
#
sub maxStringLength
{
	my $max = 0;
	foreach (@_)
		{$max = length if $max < length;}
	return $max;
}


#
# Ensure that the usage string has the proper format.
# Return the outputs and inputs strings.
#
sub verifyUsage
{
	my ($usage) = @_;
	return ("", "") if $usage eq "";
	my $flags = 0;
	die "Bad usage string: $usage\n" unless $usage =~ /^([^:]*):([^:]*)$/;
	my ($outputs, $inputs) = ($1, $2);
	#print STDERR "'$usage' -> '$outputs', '$inputs'\n";
	die "Bad usage string: $usage\n" unless
			$outputs =~ /^E?(|[Z$shortArgs]|[$argOrigins][$argKinds])$/o and
			$inputs ne "*" and $inputs =~ /^(Z|([$argOrigins][$argKinds\@]|[$shortArgs])*\*?)$/o;
	return ($outputs, $inputs);
}


#
# Decode a single argument, possibly with a wildcard.
#
# Return four values:
#   the argument's origin,
#   the argument's valueKind, and
#   true if the valueKind is a wildcard (either '@' or '_').
#
sub decodeArg
{
	my ($arg) = @_;
	my $origin = $shortOrigin;
	my $kind = $voidKind;
	my $wildcard = 0;
	if (defined($shortArgs{$arg})) {
		$kind = $shortArgs{$arg};
	} elsif ($arg =~ /^([$argOrigins])([$argKinds])$/) {
		$origin = $argOrigins{$1};
		$kind = $argKinds{$2};
	} elsif ($arg =~ /^([$argOrigins])[\@_]$/) {
		$origin = $argOrigins{$1};
		$wildcard = 1;
	} else {
		die "Internal error\n";
	}
	return ($origin, $kind, $wildcard);
}


#
# Convert an inputs string returned from verifyUsage into a string that contains the
# input constraints only and is appropriate as a C++ identifier name.
# Wildcard '@' symbols are converted into '_' symbols.
#
# Return two values:
#   the constraint string,
#   true if the last input is repeated.
#
sub inputsToConstraintString
{
	my ($inputs) = @_;
	$inputs = "" if $inputs eq "Z";
	die "Internal error\n" unless $inputs =~ /^([^\*]*)(\*?)$/;
	my $constraints = $1;
	my $repeat = $2 ne "";
	$constraints =~ tr/\@/_/;
	return ($constraints, $repeat);
}


#
# Convert a constraint string returned from inputsToConstraintString into an array
# of single-argument strings and return that array.
#
sub decodeConstraintString
{
	my ($constraints) = @_;
	my @args = ();
	while ($constraints ne "") {
		die "Internal error\n" unless $constraints =~ /^([$argOrigins][$argKinds\_]|[$shortArgs])(.*)$/o;
		push @args, $1;
		$constraints = $2;
	};
	return @args;
}


#
# Convert an outputs string returned from verifyUsage into a ValueKind constant.
# Null outputs get vkVoid.
#
sub outputsToKind
{
	my ($outputs) = @_;
	if ($outputs =~ /([$shortArgs]|[$argOrigins][$argKinds])/) {
		my ($origin, $kind, $wildcard) = decodeArg($1);
		die "Bad output: $outputs\n" if $wildcard || ($origin ne $shortOrigin);
		return $kind;
	} else {
		return $voidKind;
	}
}


#
# Convert a usage string (without quotes) to a hexadecimal string representing the desired flags value
#
sub usageToFlags
{
	my ($usage) = @_;
	my $flags = 0;
	$flags |= 1<<$dnIsReal if $usage ne "";
	$flags |= 1<<$dnCanRaiseException | 1<<$dnIsRoot if $usage =~ /E/;
	$flags |= 1<<$dnIsRoot if $usage =~ /Z/;
	return sprintf "0x%.4X", $flags;
}


#
# in
#    arrayName: name of this array
#    namesName: name of array of enum names
#    fileName: file name which to append this enum
#    names: list of names
#
# out
#    the file $fileName with the appended definitions
#
sub outputNodeTemplates
{
    my ($fileName, $primInfos) = @_;
	my $i;
	my $str;
	my $lastEnum;
	my %constraintStrings;

	# find out where to place the comma
    for ($i = $#$primInfos; $i >= 0; $i--)
    {
		if ($primInfos->[$i][$nameIndex] ne "")
		{
			$lastEnum = $i;
			last;
		}
	}

    open FILE, ">>$fileName" or die "Couldn't open $fileName: $!\n";

	outputGeneratedHeader(\*FILE, $fileName);	
	print FILE "#include \"Primitives.h\"\n\n";
	print FILE @headerLines;

    print FILE "\nconst DataNode::Template DataNode::templates[nPrimitiveOperations] = \n";
    print FILE "{\n";
    my $formatString = "\t{%-".($maxPrimitiveNameLength+2)."s".
    				   "%-".($maxCategoryNameLength+2)."s".
    				   "%-".($maxValueKindNameLength+2)."s".
    				   "%-8s\t%s\n";
    my $commentFormatString = "\t%-".(1 + $maxPrimitiveNameLength+2 + $maxCategoryNameLength+2 + $maxValueKindNameLength+2 + 8)."s\t%s\n";
    for ($i = 0; $i <= $#$primInfos; $i++)
    {
		my ($name, $category, $usage, $comment) =
			($primInfos->[$i][$nameIndex], $primInfos->[$i][$categoryIndex], $primInfos->[$i][$usageIndex], $primInfos->[$i][$commentIndex]);

		# If it has a name, then we print out the template, else we just print the comment.
		if ($name ne "") {
			my ($outputs, $inputs) = verifyUsage($usage);
			printf FILE $formatString,
						"$name,",
						"$category,",
						outputsToKind($outputs).",",
						usageToFlags($usage)."}".($i == $lastEnum ? "" : ","),
						$comment;
			my ($constraintString, $repeat) = inputsToConstraintString($inputs);
			$constraintStrings{$constraintString} = 1;
		} elsif ($comment eq "")
			{printf FILE "\n";}
		else
			{printf FILE $commentFormatString, "", $comment;}
    }
    print FILE "};\n\n\n";

    print FILE "#ifdef DEBUG\n";
    # Print definitions for all of the constraint strings, printing each unique one only once.
    my @constraintStrings = sort keys %constraintStrings;
    my $maxConstraintNameLength = length("constraint") + maxStringLength(@constraintStrings);
	foreach $str (@constraintStrings) {
		if ($str ne "") {
			my @constraints = decodeConstraintString($str);
			printf FILE "static const DataNode::InputConstraint %-".($maxConstraintNameLength+3)."s= {",
					"constraint$str\[]";
			my @constraint;
			while (defined($constraint = shift @constraints)) {
				my ($origin, $kind, $wildcard) = decodeArg($constraint);
				printf FILE "{%-".($maxValueKindNameLength+2)."s", "$kind,";
				print FILE "DataNode::";
				if (@constraints)
					{printf FILE "%-".($maxArgOriginNameLength+3)."s", "$origin},";}
				else
					{print FILE "$origin}";}
			}
			print FILE "};\n";
		}
	}
    print FILE "\n\n";

    print FILE "const DataNode::InputConstraintPattern DataNode::inputConstraintPatterns[nPrimitiveOperations] = \n";
    print FILE "{\n";
    $formatString = "\t{%-".($maxConstraintNameLength+2)."s%d, %-7s   // %-${maxPrimitiveNameLength}s\t%s\n";
    $commentFormatString = "\t%-".(1 + $maxConstraintNameLength+2 + 16 + $maxPrimitiveNameLength)."s\t%s\n";
    for ($i = 0; $i <= $#$primInfos; $i++)
    {
		my ($name, $usage, $comment) =
			($primInfos->[$i][$nameIndex], $primInfos->[$i][$usageIndex], $primInfos->[$i][$commentIndex]);

		# If it has a name, then we print out the input pattern, else we just print the comment.
		if ($name ne "") {
			my ($outputs, $inputs) = verifyUsage($usage);
			my ($constraintString, $repeat) = inputsToConstraintString($inputs);
			printf FILE $formatString,
						($constraintString eq "" ? "0" : "constraint$constraintString").",",
						scalar decodeConstraintString($constraintString),
						($repeat ? "true" : "false")."}".($i == $lastEnum ? "" : ","),
						$name, $comment;
			$constraintStrings{$constraintString} = 1;
		} elsif ($comment eq "")
			{printf FILE "\n";}
		else
			{printf FILE $commentFormatString, "", $comment;}
    }
    print FILE "};\n#endif\n\n\n";

    print FILE "#ifdef DEBUG_LOG\n";
    print FILE "static const char primitiveOperationNames[nPrimitiveOperations][16] = \n";
    print FILE "{\n";
    for ($i = 0; $i <= $#$primInfos; $i++)
    {
		my $name = $primInfos->[$i][$nameIndex];

		# If it has a name, then we print out the name.
		if ($name ne "")
		{
			$nameStr = $name;
			$nameStr = $1 if $name =~ /^[pc]o(\w+)$/;
			printf FILE "\t%-".($maxPrimitiveNameLength+1)."s\t// %s\n",
					 "\"$nameStr\"" . ($i == $lastEnum ? "" : ","), $name;
		}
    }
    print FILE "};\n#endif\n\n";

    close FILE;
}