: # -*- perl -*-
eval 'exec $PERL_CMD -S $0 ${1+"$@"}'
  if 0;

use FindBin;
use File::Spec;

#
# PAL: Perl Augmented Language.
#

$VERSION= '1.13';
$COMBINE_CONTINUATION= 0;	#lines ended with \ printed as it is

$prog= &basename($0);
($PROG= $prog)=~ tr/a-z/A-Z/;

$PERL = $ENV{PERL_CMD};
if(not defined $PERL) {
  $PERL= "/usr/perl5/bin/perl";	#path for perl5; site dependent
  # warn "WARNING: BW_PERL not defined, using $PERL.\n";
}
$BASE=     "$FindBin::Bin/..";		#released path
$RUNTIME= "${PROG}_runtime.pl";
if ($^O eq 'solaris') {
$INCLUDE_CMD= "$FindBin::Bin/include";
}
if ($^O eq 'linux') {
$INCLUDE_CMD= "$FindBin::Bin/include.linux";
}
$OUTPUT_DIR=  ".";			# default output directory

$,= ' ';
$USER= $ENV{'USER'} || getlogin() || (getpwuid($<))[0] ;


@ARGV_save= @ARGV;
& initialize();				#may change BASE

if(! $QUIET) {
#	$cmd=  "echo \"`date +%m/%d/%y:%H`: $prog @ARGV\" >> $BASE/Log/$USER";
#	$cmd.= "; chmod 660 $BASE/Log/$USER" ;
#	system( $cmd );
	}

#Run cpp on the input file to expand #includes and __LINE__.
#The reason we can't use the perl option that runs cpp before running perl
#is because after running cpp, we have to do some massaging on output file.

### process only '#inc' as include directive :

if(1) {		#direct pipe.
$cmd= "$INCLUDE_CMD -i '#inc' -pal $include_string $infile ";
open(PP_FILE, " $cmd |") or die "Can't open pipe from '$cmd' $!\n";	#preprocessed file as input
}else{		#write to a file first.
$cmd= "$INCLUDE_CMD -i '#inc' -pal $include_string $infile > $infile_pp";
& EXIT2(1, $cmd)	if( system("$cmd") ) ;
open(PP_FILE, "< $infile_pp") or die "Can't open '$infile_pp' $!\n";	#preprocessed file as input
}

open(PL_FILE, "> $infile_pl") or die "Can't write '$infile_pl' $!\n";	#translated (perl) output

print PL_FILE "#! $PERL \n";		#make perl code executable
print PL_FILE "# Translated Perl code from '$0 @ARGV_save'\n\n";

for($i= 0; $i< @INCLUDE; $i++) {
	print PL_FILE "unshift(\@INC, '$INCLUDE[$i]');\n";
	}
print PL_FILE "srand($SEED);\n"	  if($SEED);
print PL_FILE "\$BASE= '$BASE';\n";
print PL_FILE "use lib '$FindBin::Bin/../lib';\n";
print PL_FILE "require \'$RUNTIME';\n";

& LINES_TO_PERL ();

close(PP_FILE);
close(PL_FILE);
chmod(0750, $infile_pl);

if($keep_tmpFile != 2) {
  if ( $outputFile ) {
      $attach= " > $outputFile"	if($outputFile);
      # Make sure current dir is writable, since we'll be generating temp files.
      & EXIT2(1, "Output directory '$OUTPUT_DIR' must be writable")
		if(! -w $OUTPUT_DIR);
  }
  # print STDERR "execute: $infile_pl @ARGV $attach \n";
  if( system("$PERL $infile_pl @ARGV $attach") ) {
	&EXIT2(1, "Can't execute $infile_pl @ARGV $attach");
	}
}

&cleanup();



################################################################################
# initialize & process cmd-line arguments
################################################################################
sub	process_cmdline {
my($PERLOPTIONS) = '';
my $ofile;

while(substr($ARGV[0],0,1) eq '-' || $ARGV[0]=~ /^([A-Za-z_]\w*=)(.*)/) {
	my($arg)= shift(@ARGV);

	# [Viranjit 11/21/03]
	if ( $arg =~ /^(-\S+)=(.+)/ ) {		# handle -<opt>=<val>
	    $arg	= $1;			# convert to -<opt> <val>
	    unshift @ARGV, $2;
	}
	
	if( substr($arg,0,1) ne '-') {		#set var from cmd-line
		$EVAL_STR .= "\$$1$2;\n";		# process "foo= bar"
	}elsif($arg eq '-base') {		#change base to non-default place
		$BASE= shift(@ARGV);		# for experimenting new version.
	}elsif($arg eq '-h' || $arg eq '-help') {
		& EXIT(0);
	}elsif($arg eq '-H' || $arg eq '-HELP') {
		& EXIT(0);
		# & INFO();	exit(0);
	}elsif($arg eq '-I') {
		@INCLUDE= (@INCLUDE, shift(@ARGV));	
	}elsif($arg eq '-k' || $arg eq '-keep') {
		$keep_tmpFile= 1;
	}elsif($arg eq '-ko' || $arg eq '-keeponly') {
		$keep_tmpFile= 2;
	}elsif($arg eq '-o') {
		$outputFile= shift(@ARGV);		#user-given output file
		(undef, $OUTPUT_DIR, $ofile) =
			    File::Spec->splitpath( $outputFile );
		$OUTPUT_DIR = "." if $OUTPUT_DIR eq "";
	}elsif($arg eq '-q' || $arg eq '-quiet') {
		$QUIET= 1;
	}elsif($arg eq '-R' || $arg eq '-REVERSE') {
		$REVERSE= shift(@ARGV);		#user-def reverse char
	}elsif($arg eq '-r' || $arg eq '-reverse') {
		$REVERSE= "\\\.";		#default reverse char: '.'
	}elsif($arg eq '-s' || $arg eq '-seed') {
		$SEED= shift(@ARGV);		#set random seed
	}elsif($arg eq '-w') {
		$PERLOPTIONS .= ' -w';
        }elsif($arg eq '-perl') {
		my($newperl)= shift(@ARGV);
		if (-x $newperl) {
		    $PERL = $newperl;
		}
	}
    }
	$PERL .= $PERLOPTIONS if ($PERLOPTIONS ne '');
}

sub	EXIT2 { & EXIT(@_, 'NoUsage'); }

sub	EXIT {
	my($errCode, $errStr, $NoUsage)= @_;
	print STDERR "$PROG ERR (line $.): $errStr\n"  if($errStr);
	& usage()				 if(! $NoUsage);
	& cleanup();
	exit($errCode);
}

sub initialize {
   #reset all control variables :
    @INCLUDE= ();
    $REVERSE= '';			#default: no reverse mode

    & EXIT(1)	if($#ARGV == -1);

    & process_cmdline();		#process argv before input file

    & EXIT(0, "Missing input file")	if($#ARGV < 0);

    $infile=	 shift(@ARGV);
    my($name)= &basename($infile);
    $infile_pp=  "/usr/tmp/$name.$$.pp";	#after preprocess
    $infile_pl=  "/usr/tmp/$name.$$.pl";	#after xlating to perl

##  & process_cmdline()	if($#ARGV >= 0);	#after input file
#   & EXIT(1, "Cmd-Line error")	if($#ARGV >= 0) ;

    # Check suffix of input file and make sure it exists.
    if($infile !~ /\.[^\.]*(pal|pm|tg)$/i &&		#no .pal|.pm|.tg suffix, and
	    ! $REVERSE) {   			# not start w/ reverse mode
		& EXIT2(1, "$infile must be ended with '.*(pal|pm|tg)'");
		}
    & EXIT2(1, "$infile does not exist")	if(! -r $infile);

    # Make sure include directories exist.
    for($i= 0; $i < @INCLUDE; $i++) {
	if(! -d $INCLUDE[$i]) {
		& EXIT2(1, "Directory $INCLUDE[$i] does not exist");
	}else{
		$include_string = $include_string . " -I $INCLUDE[$i]";
		}
	}

}


sub	LINES_TO_PERL {			#translate all lines to perl
my($REVERSE_save);

$curr_linenum= 0;
$REVERSE_save= $REVERSE;

$INIT= 1;
$line=         '';
$currLineType= '';
while(<PP_FILE>) {		#read input file, and do some filtering
    if(/^# line (\d+) (.*)/) {
	$curr_linenum= $1 - 1;	# -1 because the line itself is following
	$curr_file=    $2;
	print PL_FILE $_;
	next;
    }else{
	++ $curr_linenum;
	}
    if(/^$REVERSE#+\s*(END_INIT|ENDINIT)/ && $INIT) {	# put "foo=bar" after #END_INIT
	s/^$REVERSE//;
	print PL_FILE "$_";
	print PL_FILE $EVAL_STR;
	$INIT= 0;
	next;
	}
    if($line ne '') {		#this is a continued line: strip its prefix
	if( $currLineType ne &lineType($_) ) {
	    &EXIT2(1, "prefix of continued line doesn't match previous line");
	    }
	s/^://;
	s/^$REVERSE//	if($REVERSE ne '');
	}
     if($COMBINE_CONTINUATION==1 && s/\\\s*$// ) {
      #line ended w/ \, cat to previous line
	$currLineType= &lineType($_)	if(! $currLineType);
        $line.= $_;
	next;
    }elsif($COMBINE_CONTINUATION==2 &&
    	   ((! /#define/) && s/\\\s*$/\n/) ) {
      #ended w/ \, and not #define
	$currLineType= &lineType($_)	if(! $currLineType);
	$line.= $_;
	next;
    }


    $line.= $_;				#concate w/ potential previous lines
    $line_save= $line;
    & line_to_perl(*line);		#change :-lines to perl print stmt
    if($line_save ne $line) {
	$line=~ s/\n(.)/\n# line $curr_linenum $curr_file\n$1/g;
#	print PL_FILE "# line $curr_linenum $curr_file\n"   if($line =~ /\n./);
	}
    print PL_FILE "$line";
    $line=    	   '';			#reset only after a 'line' is complete
    $currLineType= '';
    }
}


sub	lineType {
my($line)= @_;
my($prefix)= substr($line,0,1);
my($typ)=
    ($prefix eq ':') && ($MODE eq 'PLAIN' || $REVERSE eq '') ?	':' :
    ($prefix eq $REVERSE) && ($REVERSE ne '') ?			$REVERSE :
								'x'       ;
$typ;
}


#
# Massage the cpp output file to 
#   replace lines beginning with ":" with print statements
#   replace single quote with backslash quote
#   replace '\n' with '\\n'
#   massage some of the spacing.

sub  line_to_perl {			#translate 1 line to perl stmt
local(*line) = @_;
my($print_linenum)= 1;
my($i);

   if($MODE eq 'PLAIN') {	#===> complete_as_is (plain) TEXT mode:
	# if($line =~ s/^[ \t]*://) {			#text stuff
	if($line =~ s/^://) {				#text stuff
		$line= & PASS_AS_IS( $line );
	}elsif($REVERSE ne '' && $line =~ s/^$REVERSE//) {	#perl stmt
		& check_mode_switch(*line);
#    	}elsif($line =~ /^#/) {			#cpp-generated stuff: pass
#			;		 	# unchanged as perl comment
	}elsif($line =~ s/^\\#/#/) {		#text escaped comment: put back
		$line= & pass_as_is( $line ) ;		#plain text
	}else{	$line= & pass_as_is( $line ) ; }	#plain text

   }elsif($REVESE ne ';' && $line =~ s/^;//) {	#===> complete_as_is TEXT mode:
	## ';' in first column: NOT even perl variable will be evaluated
	## Note that: perl variables still evaluated in ordinary TEXT mode
		$line= & pass_as_is( $line ) ;

   }elsif($REVERSE eq '') {	#==> PERL mode: text needs prefix w/ ':'
	if($line =~ s/^://) {			#rm text-prefix up to ':'
		$line= & PASS_AS_IS( $line );	#text
	}else{
		& check_mode_switch(*line);	#perl stmt
		}
   }else {			#==> TEXT mode: perl code prefixed w/ $REVERSE
	if($line =~ s/^$REVERSE//) {	#perl stmt: remove prefix
	   & check_mode_switch(*line);

#   	}elsif($line =~ /^\s*#/) {		#cpp-generated stuff: pass
#   		;		 		# unchanged as perl comment
	}elsif($line =~ s/^\\#/#/) {	#text escaped comment: put back
		$line= & PASS_AS_IS( $line ) ;	#AS_IS line
	}else{	$line= & PASS_AS_IS( $line ) ; 	#AS_IS line
		}
	}
}

sub	check_mode_switch {		#mode-switch command: start_perl, and
local(*line)= @_;			# start_text[(reverse_string)]

if($line=~ /^\s*#/) {			#comment at the begin:
	;
}elsif($line=~ /^\s*start_plain/) {		#switch to pure text mode
	$MODE= 'PLAIN';
	$line= '';				#nullify the line
}elsif($line=~ /^\s*start_perl/) {		#switch to perl mode
	$REVERSE_save= $REVERSE;		#save prev REVERSE char
	$REVERSE= '';				#clear REVERSE
	$MODE= '';
	$line= '';				#nullify the line
}elsif($line=~ s/^\s*start_text//) {
    if($line=~ s/\s*\((.*)\)//) {	#switch to text mode
	   $REVERSE= "$1";			#use specified $REVERSE
    }elsif($REVERSE_save ne '') {
	   $REVERSE= $REVERSE_save; 		#use prev $REVERSE
    }else{
	   $REVERSE= "\\\.";			#use default $REVERSE
	   }
    $line= '';					#nullify the line
    $MODE= '';
}else{	my($prefix_stmt)= & proc_SELECTION(*line);
	$line= $prefix_stmt . $line;
	}
$line;
}


sub	pass_as_is {		#COMPLETELY as is: nothing will be evaluated
my($line)= @_ ;

$line =~ s/\n$//;			# get rid of \n, if any.
$line =~ s/\\/\\\\/g;			# change \ to \\; to print as \
$line =~ s/'/\\'/g;			# replace quote w/ 'backslash quote'
#$line = "print \"\\n\", \'$line\';\n"; #enclose $line w/ ': no escaped needed
$line = "print \'$line\', \"\\n\";\n";	#enclose $line w/ ', so no escaped needed
}


sub	PASS_AS_IS {		#everything EXCEPT PERL $ variables appear as is
local($line)= @_;		#perl variable is evaluated to its value;
				#so only $ need be escaped by programmer.

$line=~ s/\n$//;			# get rid of \n

my($prefix_stmt)= & proc_SELECTION(*line, 1);

### only '\' and " need be escaped !!
$line =~ s/\\/\\\\/g;			# change \ to \\ for printing as \
$line =~ s/"/\\"/g;			# change " to \" for printing as "

### preseve $  as $;  so when printed, it is perl variable.
### preseve \$ as \$; so when printed, it is '$' . {...}.
### preseve $$ as $$; so when printed, it is process id.
$line =~ s/\\\\([\[\$\@\]])/\\$1/g;	# put \\$ back to \$; to print as $

#$line = $prefix_stmt . "print \"\\n$line\";\n";	
$line = $prefix_stmt . "print \"$line\\n\";\n";	

}

#------------------- [[....]] is selection list which randomly choose element
#------------------- [e[...]] is enumeration list which choose elements in order
#------------------- [l[...]] return the number of elements in the list

sub	proc_SELECTION {	#process selection list [e?[...]]
local(*string, $func_sub)= @_;		#string is either text or perl stmt.
my($list, $cmd);			#list is stuff within [e?[ and ]]
my($sel_stmt, $fun_stmt);
my($acc);

$acc= '';
########## selection list replacement:
while( 1 ) {		###--replace next [..[..]] to a $variable
	last	if($string !~ /\[([\w ,:]*)\[([^\]]*)\]\]/) ;
###########			[ cmd       [ .list.  ] ]
	++ $list_idx;			#GLOBAL: increment after done with it
	$acc    .= $` . "\$\{_PARAM$list_idx\}";	#become a variable
	$string = $';					#process rest later

	$cmd=   $1;
	$list= "$2";
	$list=~ s/([^\\])"/$1\\"/g;		# escape non-escaped "
	$list=~ s/^"/\\"/;
	$list=~ s/\n//g;			# remove all new-line char

	my($ln)= $curr_linenum - 1;
  ##--- $_PARAMn is delay-evaluated until the last run, where all
  ##----- $perl variables in [[..]] list are evaluated else where.
	$sel_stmt .= "\$_PARAM$list_idx= &proc_SEL($list_idx, \"[$list]\", \"$cmd\", \"$curr_file:$ln\");\n";
	}

$string= $acc . $string;
$acc=    '';
########## function call replacement in 'text string':
if( $func_sub ) {
 while(1) {
   last	if($string !~ /(.)?\&\s*([a-zA-Z_]\w*\s*\([^\)]*\))/ );
###                            &   ---funcName--    ( ..... )
   $match= $&;
   if($1 eq '\\') {
	$string= $';			#set before another substitute.
	$acc  .= $`;
	$match =~ s/^.//;		#un-escape \& to &.
	$acc  .= $match;
	next;
	}
   ++ $func_idx;
   $acc      .= $` . "$1\$\{_RETURN$func_idx\}";
   $string    = $';					#remaining part
   $fun_stmt .= "\$_RETURN$func_idx= & $2;\n";
   }
 }
# $fun_stmt=~ s/\\"/"/g;			#un-escape \"
# $fun_stmt=~ s/\\\\/\\/g;		#un-escape \\

$string= "$acc" . "$string";		# substitute orignal stmt

$sel_stmt . $fun_stmt;		#### return prefix stmt: proc_SEL() + func-call
}


################################################################################
# cleanup
################################################################################
sub cleanup {			# remove .pp and .pl files when no -k option
if($keep_tmpFile) {
	my($targ)= &basename($infile_pl);
	$targ=~ s/$$\.//;
	$targ= File::Spec->catfile( $OUTPUT_DIR, $targ) if $OUTPUT_DIR ne ".";
	system("mv $infile_pl $targ");
}else{
	unlink($infile_pp)	if(-f $infile_pp);
	unlink($infile_pl)	if(-f $infile_pl);
	}
}


################################################################################
# usage		and 	    INFO
################################################################################
sub	usage {
my(@version)= split(' ', $VERSION);
print	<<EOF;
Usage: $prog [options] {file.$prog} [{\@ARGV for file.$prog}]
    options:
      {var}={expr}	 will set ${var} to {expr} after "^#END_INIT", before
			 which is the place to give default values.
      -h(elp)            print usage information.
      -I <include_dir>   add <include_dir> to search path for #includes.
      -k(eep)            keep temporary files after run.
      -ko|-keeponly      generate temporary files and exit.
      -o <outfile>       output assembly language to <outfile>.
      -perl <file>	 Change the default perl version use to <file>.
      -r(everse)         reverse to TEXT mode by treating lines prefixed w/ '.'
                         as perl stmt, the rest are output unchanged.
      -R '{prefix}'      same as -r except perl-prefix set to {prefix};
                         char special to regular expression need be escaped.
      -s(eed) {number}   set random number seed by calling 'srand({number})'.
'$PROG', Perl extended Language, is a macro language based on Perl.
Version: 1.00.
EOF

#     -H(ELP)            more info about $PROG extension: reverse mode,
#                        string/number selection/enumeration, etc.
#end of print <<EOF;
}

sub	INFO {
print <<EOF;
    List substitution: same as what CHAOS accepted
	1. [[....]]:	selection; replace the whole thing with a randomly
				selected element from the ... list.
	2. [e[...]]:	enumeration; replace the while thing with the NEXT
				element from the ... list.
	3. [l[...]]:	length; replace the whole thing with the number of
				elements of the ... list.
	4. Type of list:
		a. number list: [[0, 2, 4-9, 11-13]]
		b. string list: [[bc1f, bc1t, bc1fl, bc1tl]]
    About MODE: perl, text, and plain-text";
          The original testgen is always in perl mode where all lines are perl
          stmt by default. Only those prefixed with ':' are output as is with
          perl variables evaluated. $PROG can switch mode bewteen perl and
          text. In perl mode, text needs be prefixed with ':' just like in
          testgen. In text mode, all lines are text by default. Perl stmt
          need be started with perl-prefix, whose default is '.'. It can
          be set to something else by using -R option. To make life more
          versatile (or complicated :-), $PROG can switch modes on the fly.
          Two pseudo perl functions are added for the purpose:
                start_perl and start_text[({new_perl_prefix})]
          Start_perl switches to perl mode and to comply with testgen, the
          text-prefix is always ':'. Start_text switches to text mode with
          perl-prefix set to either previous perl-prefix or {new_perl_prefix}
          if specified. NOTE: perl-prefix is to process as regular expression.
          Appropriate escape is needed. Here are Examples to set . and []
          as perl-prefix:
                 $prog -R '\\.'  and $prog -R '\\[\\]' on the command line, and
                 start_text(\\.) and start_text(\\[\\]) on your .tg file.
          In text mode, perl variables are still evaluated. To prevent that,
          a pure text mode is added which must always be prefixed with ';'
          if it is not used as perl_prefix.
    Other differences in TEXT lines:
          '\$': In testgen, '\$' if not for perl variables is escaped with \$\$;
                in $PROG, it is escaped with more conventional \\\$.
          '#': .tg file is first fed to cpp for macro processing.
                So, '#' can't appear in the 1st column even in text
                mode unless it is escaped with \\.
          leading spaces: In testgen, spaces following ':' are replaced with
                1 blank; in $PROG, they survive to maintain original indent.
EOF
	# end of prnt <<EOF;
}


sub basename {
        my($name) = @_;
	my( $basename ) = "";
        split(/\//, $name);
	$basename = pop @_;
##	$basename =~ s/,.*$//;
        return($basename);
	}

1;