[OpenSPARC-T2-DV] / tools / perlmod / pal / 1.13 / bin / pal

: # -*- 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;
Commit	Line	Data
86530b38 AT	1	: # -- perl --
	2	eval 'exec $PERL_CMD -S $0 ${1+"$@"}'
	3	if 0;
	4
	5	use FindBin;
	6	use File::Spec;
	7
	8	#
	9	# PAL: Perl Augmented Language.
	10	#
	11
	12	$VERSION= '1.13';
	13	$COMBINE_CONTINUATION= 0; #lines ended with \ printed as it is
	14
	15	$prog= &basename($0);
	16	($PROG= $prog)=~ tr/a-z/A-Z/;
	17
	18	$PERL = $ENV{PERL_CMD};
	19	if(not defined $PERL) {
	20	$PERL= "/usr/perl5/bin/perl"; #path for perl5; site dependent
	21	# warn "WARNING: BW_PERL not defined, using $PERL.\n";
	22	}
	23	$BASE= "$FindBin::Bin/.."; #released path
	24	$RUNTIME= "${PROG}_runtime.pl";
	25	if ($^O eq 'solaris') {
	26	$INCLUDE_CMD= "$FindBin::Bin/include";
	27	}
	28	if ($^O eq 'linux') {
	29	$INCLUDE_CMD= "$FindBin::Bin/include.linux";
	30	}
	31	$OUTPUT_DIR= "."; # default output directory
	32
	33	$,= ' ';
	34	$USER= $ENV{'USER'} \|\| getlogin() \|\| (getpwuid($<))[0] ;
	35
	36
	37	@ARGV_save= @ARGV;
	38	& initialize(); #may change BASE
	39
	40	if(! $QUIET) {
	41	# $cmd= "echo \"`date +%m/%d/%y:%H`: $prog @ARGV\" >> $BASE/Log/$USER";
	42	# $cmd.= "; chmod 660 $BASE/Log/$USER" ;
	43	# system( $cmd );
	44	}
	45
	46	#Run cpp on the input file to expand #includes and __LINE__.
	47	#The reason we can't use the perl option that runs cpp before running perl
	48	#is because after running cpp, we have to do some massaging on output file.
	49
	50	### process only '#inc' as include directive :
	51
	52	if(1) { #direct pipe.
	53	$cmd= "$INCLUDE_CMD -i '#inc' -pal $include_string $infile ";
	54	open(PP_FILE, " $cmd \|") or die "Can't open pipe from '$cmd' $!\n"; #preprocessed file as input
	55	}else{ #write to a file first.
	56	$cmd= "$INCLUDE_CMD -i '#inc' -pal $include_string $infile > $infile_pp";
	57	& EXIT2(1, $cmd) if( system("$cmd") ) ;
	58	open(PP_FILE, "< $infile_pp") or die "Can't open '$infile_pp' $!\n"; #preprocessed file as input
	59	}
	60
	61	open(PL_FILE, "> $infile_pl") or die "Can't write '$infile_pl' $!\n"; #translated (perl) output
	62
	63	print PL_FILE "#! $PERL \n"; #make perl code executable
	64	print PL_FILE "# Translated Perl code from '$0 @ARGV_save'\n\n";
65
66	for($i= 0; $i< @INCLUDE; $i++) {
67	print PL_FILE "unshift(\@INC, '$INCLUDE[$i]');\n";
68	}
69	print PL_FILE "srand($SEED);\n" if($SEED);
70	print PL_FILE "\$BASE= '$BASE';\n";
71	print PL_FILE "use lib '$FindBin::Bin/../lib';\n";
72	print PL_FILE "require \'$RUNTIME';\n";
73
74	& LINES_TO_PERL ();
75
76	close(PP_FILE);
77	close(PL_FILE);
78	chmod(0750, $infile_pl);
79
80	if($keep_tmpFile != 2) {
81	if ( $outputFile ) {
82	$attach= " > $outputFile" if($outputFile);
83	# Make sure current dir is writable, since we'll be generating temp files.
84	& EXIT2(1, "Output directory '$OUTPUT_DIR' must be writable")
85	if(! -w $OUTPUT_DIR);
86	}
87	# print STDERR "execute: $infile_pl @ARGV $attach \n";
88	if( system("$PERL $infile_pl @ARGV $attach") ) {
89	&EXIT2(1, "Can't execute $infile_pl @ARGV $attach");
90	}
91	}
92
93	&cleanup();
94
95
96
97	################################################################################
98	# initialize & process cmd-line arguments
99	################################################################################
100	sub process_cmdline {
101	my($PERLOPTIONS) = '';
102	my $ofile;
103
104	while(substr($ARGV[0],0,1) eq '-' \|\| $ARGV[0]=~ /^([A-Za-z_]\w=)(.)/) {
105	my($arg)= shift(@ARGV);
106
107	# [Viranjit 11/21/03]
108	if ( $arg =~ /^(-\S+)=(.+)/ ) { # handle -<opt>=<val>
109	$arg = $1; # convert to -<opt> <val>
110	unshift @ARGV, $2;
111	}
112
113	if( substr($arg,0,1) ne '-') { #set var from cmd-line
114	$EVAL_STR .= "\$$1$2;\n"; # process "foo= bar"
115	}elsif($arg eq '-base') { #change base to non-default place
116	$BASE= shift(@ARGV); # for experimenting new version.
117	}elsif($arg eq '-h' \|\| $arg eq '-help') {
118	& EXIT(0);
119	}elsif($arg eq '-H' \|\| $arg eq '-HELP') {
120	& EXIT(0);
121	# & INFO(); exit(0);
122	}elsif($arg eq '-I') {
123	@INCLUDE= (@INCLUDE, shift(@ARGV));
124	}elsif($arg eq '-k' \|\| $arg eq '-keep') {
125	$keep_tmpFile= 1;
126	}elsif($arg eq '-ko' \|\| $arg eq '-keeponly') {
127	$keep_tmpFile= 2;
128	}elsif($arg eq '-o') {
129	$outputFile= shift(@ARGV); #user-given output file
130	(undef, $OUTPUT_DIR, $ofile) =
131	File::Spec->splitpath( $outputFile );
132	$OUTPUT_DIR = "." if $OUTPUT_DIR eq "";
133	}elsif($arg eq '-q' \|\| $arg eq '-quiet') {
134	$QUIET= 1;
135	}elsif($arg eq '-R' \|\| $arg eq '-REVERSE') {
136	$REVERSE= shift(@ARGV); #user-def reverse char
137	}elsif($arg eq '-r' \|\| $arg eq '-reverse') {
138	$REVERSE= "\\\."; #default reverse char: '.'
139	}elsif($arg eq '-s' \|\| $arg eq '-seed') {
140	$SEED= shift(@ARGV); #set random seed
141	}elsif($arg eq '-w') {
142	$PERLOPTIONS .= ' -w';
143	}elsif($arg eq '-perl') {
144	my($newperl)= shift(@ARGV);
145	if (-x $newperl) {
146	$PERL = $newperl;
147	}
148	}
149	}
150	$PERL .= $PERLOPTIONS if ($PERLOPTIONS ne '');
151	}
152
153	sub EXIT2 { & EXIT(@_, 'NoUsage'); }
154
155	sub EXIT {
156	my($errCode, $errStr, $NoUsage)= @_;
157	print STDERR "$PROG ERR (line $.): $errStr\n" if($errStr);
158	& usage() if(! $NoUsage);
159	& cleanup();
160	exit($errCode);
161	}
162
163	sub initialize {
164	#reset all control variables :
165	@INCLUDE= ();
166	$REVERSE= ''; #default: no reverse mode
167
168	& EXIT(1) if($#ARGV == -1);
169
170	& process_cmdline(); #process argv before input file
171
172	& EXIT(0, "Missing input file") if($#ARGV < 0);
173
174	$infile= shift(@ARGV);
175	my($name)= &basename($infile);
176	$infile_pp= "/usr/tmp/$name.$$.pp"; #after preprocess
177	$infile_pl= "/usr/tmp/$name.$$.pl"; #after xlating to perl
178
179	## & process_cmdline() if($#ARGV >= 0); #after input file
180	# & EXIT(1, "Cmd-Line error") if($#ARGV >= 0) ;
181
182	# Check suffix of input file and make sure it exists.
183	if($infile !~ /\.[^\.]*(pal\|pm\|tg)$/i && #no .pal\|.pm\|.tg suffix, and
184	! $REVERSE) { # not start w/ reverse mode
185	& EXIT2(1, "$infile must be ended with '.*(pal\|pm\|tg)'");
186	}
187	& EXIT2(1, "$infile does not exist") if(! -r $infile);
188
189	# Make sure include directories exist.
190	for($i= 0; $i < @INCLUDE; $i++) {
191	if(! -d $INCLUDE[$i]) {
192	& EXIT2(1, "Directory $INCLUDE[$i] does not exist");
193	}else{
194	$include_string = $include_string . " -I $INCLUDE[$i]";
195	}
196	}
197
198	}
199
200
201	sub LINES_TO_PERL { #translate all lines to perl
202	my($REVERSE_save);
203
204	$curr_linenum= 0;
205	$REVERSE_save= $REVERSE;
206
207	$INIT= 1;
208	$line= '';
209	$currLineType= '';
210	while(<PP_FILE>) { #read input file, and do some filtering
211	if(/^# line (\d+) (.*)/) {
212	$curr_linenum= $1 - 1; # -1 because the line itself is following
213	$curr_file= $2;
214	print PL_FILE $_;
215	next;
216	}else{
217	++ $curr_linenum;
218	}
219	if(/^$REVERSE#+\s*(END_INIT\|ENDINIT)/ && $INIT) { # put "foo=bar" after #END_INIT
220	s/^$REVERSE//;
221	print PL_FILE "$_";
222	print PL_FILE $EVAL_STR;
223	$INIT= 0;
224	next;
225	}
226	if($line ne '') { #this is a continued line: strip its prefix
227	if( $currLineType ne &lineType($_) ) {
228	&EXIT2(1, "prefix of continued line doesn't match previous line");
229	}
230	s/^://;
231	s/^$REVERSE// if($REVERSE ne '');
232	}
233	if($COMBINE_CONTINUATION==1 && s/\\\s*$// ) {
234	#line ended w/ \, cat to previous line
235	$currLineType= &lineType($_) if(! $currLineType);
236	$line.= $_;
237	next;
238	}elsif($COMBINE_CONTINUATION==2 &&
239	((! /#define/) && s/\\\s*$/\n/) ) {
240	#ended w/ \, and not #define
241	$currLineType= &lineType($_) if(! $currLineType);
242	$line.= $_;
243	next;
244	}
245
246
247	$line.= $_; #concate w/ potential previous lines
248	$line_save= $line;
249	& line_to_perl(*line); #change :-lines to perl print stmt
250	if($line_save ne $line) {
251	$line=~ s/\n(.)/\n# line $curr_linenum $curr_file\n$1/g;
252	# print PL_FILE "# line $curr_linenum $curr_file\n" if($line =~ /\n./);
253	}
254	print PL_FILE "$line";
255	$line= ''; #reset only after a 'line' is complete
256	$currLineType= '';
257	}
258	}
259
260
261	sub lineType {
262	my($line)= @_;
263	my($prefix)= substr($line,0,1);
264	my($typ)=
265	($prefix eq ':') && ($MODE eq 'PLAIN' \|\| $REVERSE eq '') ? ':' :
266	($prefix eq $REVERSE) && ($REVERSE ne '') ? $REVERSE :
267	'x' ;
268	$typ;
269	}
270
271
272	#
273	# Massage the cpp output file to
274	# replace lines beginning with ":" with print statements
275	# replace single quote with backslash quote
276	# replace '\n' with '\\n'
277	# massage some of the spacing.
278
279	sub line_to_perl { #translate 1 line to perl stmt
280	local(*line) = @_;
281	my($print_linenum)= 1;
282	my($i);
283
284	if($MODE eq 'PLAIN') { #===> complete_as_is (plain) TEXT mode:
285	# if($line =~ s/^[ \t]*://) { #text stuff
286	if($line =~ s/^://) { #text stuff
287	$line= & PASS_AS_IS( $line );
288	}elsif($REVERSE ne '' && $line =~ s/^$REVERSE//) { #perl stmt
289	& check_mode_switch(*line);
290	# }elsif($line =~ /^#/) { #cpp-generated stuff: pass
291	# ; # unchanged as perl comment
292	}elsif($line =~ s/^\\#/#/) { #text escaped comment: put back
293	$line= & pass_as_is( $line ) ; #plain text
294	}else{ $line= & pass_as_is( $line ) ; } #plain text
295
296	}elsif($REVESE ne ';' && $line =~ s/^;//) { #===> complete_as_is TEXT mode:
297	## ';' in first column: NOT even perl variable will be evaluated
298	## Note that: perl variables still evaluated in ordinary TEXT mode
299	$line= & pass_as_is( $line ) ;
300
301	}elsif($REVERSE eq '') { #==> PERL mode: text needs prefix w/ ':'
302	if($line =~ s/^://) { #rm text-prefix up to ':'
303	$line= & PASS_AS_IS( $line ); #text
304	}else{
305	& check_mode_switch(*line); #perl stmt
306	}
307	}else { #==> TEXT mode: perl code prefixed w/ $REVERSE
308	if($line =~ s/^$REVERSE//) { #perl stmt: remove prefix
309	& check_mode_switch(*line);
310
311	# }elsif($line =~ /^\s*#/) { #cpp-generated stuff: pass
312	# ; # unchanged as perl comment
313	}elsif($line =~ s/^\\#/#/) { #text escaped comment: put back
314	$line= & PASS_AS_IS( $line ) ; #AS_IS line
315	}else{ $line= & PASS_AS_IS( $line ) ; #AS_IS line
316	}
317	}
318	}
319
320	sub check_mode_switch { #mode-switch command: start_perl, and
321	local(*line)= @_; # start_text[(reverse_string)]
322
323	if($line=~ /^\s*#/) { #comment at the begin:
324	;
325	}elsif($line=~ /^\s*start_plain/) { #switch to pure text mode
326	$MODE= 'PLAIN';
327	$line= ''; #nullify the line
328	}elsif($line=~ /^\s*start_perl/) { #switch to perl mode
329	$REVERSE_save= $REVERSE; #save prev REVERSE char
330	$REVERSE= ''; #clear REVERSE
331	$MODE= '';
332	$line= ''; #nullify the line
333	}elsif($line=~ s/^\s*start_text//) {
334	if($line=~ s/\s\((.)\)//) { #switch to text mode
335	$REVERSE= "$1"; #use specified $REVERSE
336	}elsif($REVERSE_save ne '') {
337	$REVERSE= $REVERSE_save; #use prev $REVERSE
338	}else{
339	$REVERSE= "\\\."; #use default $REVERSE
340	}
341	$line= ''; #nullify the line
342	$MODE= '';
343	}else{ my($prefix_stmt)= & proc_SELECTION(*line);
344	$line= $prefix_stmt . $line;
345	}
346	$line;
347	}
348
349
350	sub pass_as_is { #COMPLETELY as is: nothing will be evaluated
351	my($line)= @_ ;
352
353	$line =~ s/\n$//; # get rid of \n, if any.
354	$line =~ s/\\/\\\\/g; # change \ to \\; to print as \
355	$line =~ s/'/\\'/g; # replace quote w/ 'backslash quote'
356	#$line = "print \"\\n\", \'$line\';\n"; #enclose $line w/ ': no escaped needed
357	$line = "print \'$line\', \"\\n\";\n"; #enclose $line w/ ', so no escaped needed
358	}
359
360
361	sub PASS_AS_IS { #everything EXCEPT PERL $ variables appear as is
362	local($line)= @_; #perl variable is evaluated to its value;
363	#so only $ need be escaped by programmer.
364
365	$line=~ s/\n$//; # get rid of \n
366
367	my($prefix_stmt)= & proc_SELECTION(*line, 1);
368
369	### only '\' and " need be escaped !!
370	$line =~ s/\\/\\\\/g; # change \ to \\ for printing as \
371	$line =~ s/"/\\"/g; # change " to \" for printing as "
372
373	### preseve $ as $; so when printed, it is perl variable.
374	### preseve \$ as \$; so when printed, it is '$' . {...}.
375	### preseve $$ as $$; so when printed, it is process id.
376	$line =~ s/\\\\([\[\$\@\]])/\\$1/g; # put \\$ back to \$; to print as $
377
378	#$line = $prefix_stmt . "print \"\\n$line\";\n";
379	$line = $prefix_stmt . "print \"$line\\n\";\n";
380
381	}
382
383	#------------------- [[....]] is selection list which randomly choose element
384	#------------------- [e[...]] is enumeration list which choose elements in order
385	#------------------- [l[...]] return the number of elements in the list
386
387	sub proc_SELECTION { #process selection list [e?[...]]
388	local(*string, $func_sub)= @_; #string is either text or perl stmt.
389	my($list, $cmd); #list is stuff within [e?[ and ]]
390	my($sel_stmt, $fun_stmt);
391	my($acc);
392
393	$acc= '';
394	########## selection list replacement:
395	while( 1 ) { ###--replace next [..[..]] to a $variable
396	last if($string !~ /\[([\w ,:])\[([^\]])\]\]/) ;
397	########### [ cmd [ .list. ] ]
398	++ $list_idx; #GLOBAL: increment after done with it
399	$acc .= $` . "\$\{_PARAM$list_idx\}"; #become a variable
400	$string = $'; #process rest later
401
402	$cmd= $1;
403	$list= "$2";
404	$list=~ s/([^\\])"/$1\\"/g; # escape non-escaped "
405	$list=~ s/^"/\\"/;
406	$list=~ s/\n//g; # remove all new-line char
407
408	my($ln)= $curr_linenum - 1;
409	##--- $_PARAMn is delay-evaluated until the last run, where all
410	##----- $perl variables in [[..]] list are evaluated else where.
411	$sel_stmt .= "\$_PARAM$list_idx= &proc_SEL($list_idx, \"[$list]\", \"$cmd\", \"$curr_file:$ln\");\n";
412	}
413
414	$string= $acc . $string;
415	$acc= '';
416	########## function call replacement in 'text string':
417	if( $func_sub ) {
418	while(1) {
419	last if($string !~ /(.)?\&\s([a-zA-Z_]\w\s\([^\)]\))/ );
420	### & ---funcName-- ( ..... )
421	$match= $&;
422	if($1 eq '\\') {
423	$string= $'; #set before another substitute.
424	$acc .= $`;
425	$match =~ s/^.//; #un-escape \& to &.
426	$acc .= $match;
427	next;
428	}
429	++ $func_idx;
430	$acc .= $` . "$1\$\{_RETURN$func_idx\}";
431	$string = $'; #remaining part
432	$fun_stmt .= "\$_RETURN$func_idx= & $2;\n";
433	}
434	}
435	# $fun_stmt=~ s/\\"/"/g; #un-escape \"
436	# $fun_stmt=~ s/\\\\/\\/g; #un-escape \\
437
438	$string= "$acc" . "$string"; # substitute orignal stmt
439
440	$sel_stmt . $fun_stmt; #### return prefix stmt: proc_SEL() + func-call
441	}
442
443
444	################################################################################
445	# cleanup
446	################################################################################
447	sub cleanup { # remove .pp and .pl files when no -k option
448	if($keep_tmpFile) {
449	my($targ)= &basename($infile_pl);
450	$targ=~ s/$$\.//;
451	$targ= File::Spec->catfile( $OUTPUT_DIR, $targ) if $OUTPUT_DIR ne ".";
452	system("mv $infile_pl $targ");
453	}else{
454	unlink($infile_pp) if(-f $infile_pp);
455	unlink($infile_pl) if(-f $infile_pl);
456	}
457	}
458
459
460	################################################################################
461	# usage and INFO
462	################################################################################
463	sub usage {
464	my(@version)= split(' ', $VERSION);
465	print <<EOF;
466	Usage: $prog [options] {file.$prog} [{\@ARGV for file.$prog}]
467	options:
468	{var}={expr} will set ${var} to {expr} after "^#END_INIT", before
469	which is the place to give default values.
470	-h(elp) print usage information.
471	-I <include_dir> add <include_dir> to search path for #includes.
472	-k(eep) keep temporary files after run.
473	-ko\|-keeponly generate temporary files and exit.
474	-o <outfile> output assembly language to <outfile>.
475	-perl <file> Change the default perl version use to <file>.
476	-r(everse) reverse to TEXT mode by treating lines prefixed w/ '.'
477	as perl stmt, the rest are output unchanged.
478	-R '{prefix}' same as -r except perl-prefix set to {prefix};
479	char special to regular expression need be escaped.
480	-s(eed) {number} set random number seed by calling 'srand({number})'.
481	'$PROG', Perl extended Language, is a macro language based on Perl.
482	Version: 1.00.
483	EOF
484
485	# -H(ELP) more info about $PROG extension: reverse mode,
486	# string/number selection/enumeration, etc.
487	#end of print <<EOF;
488	}
489
490	sub INFO {
491	print <<EOF;
492	List substitution: same as what CHAOS accepted
493	1. [[....]]: selection; replace the whole thing with a randomly
494	selected element from the ... list.
495	2. [e[...]]: enumeration; replace the while thing with the NEXT
496	element from the ... list.
497	3. [l[...]]: length; replace the whole thing with the number of
498	elements of the ... list.
499	4. Type of list:
500	a. number list: [[0, 2, 4-9, 11-13]]
501	b. string list: [[bc1f, bc1t, bc1fl, bc1tl]]
502	About MODE: perl, text, and plain-text";
503	The original testgen is always in perl mode where all lines are perl
504	stmt by default. Only those prefixed with ':' are output as is with
505	perl variables evaluated. $PROG can switch mode bewteen perl and
506	text. In perl mode, text needs be prefixed with ':' just like in
507	testgen. In text mode, all lines are text by default. Perl stmt
508	need be started with perl-prefix, whose default is '.'. It can
509	be set to something else by using -R option. To make life more
510	versatile (or complicated :-), $PROG can switch modes on the fly.
511	Two pseudo perl functions are added for the purpose:
512	start_perl and start_text[({new_perl_prefix})]
513	Start_perl switches to perl mode and to comply with testgen, the
514	text-prefix is always ':'. Start_text switches to text mode with
515	perl-prefix set to either previous perl-prefix or {new_perl_prefix}
516	if specified. NOTE: perl-prefix is to process as regular expression.
517	Appropriate escape is needed. Here are Examples to set . and []
518	as perl-prefix:
519	$prog -R '\\.' and $prog -R '\\[\\]' on the command line, and
520	start_text(\\.) and start_text(\\[\\]) on your .tg file.
521	In text mode, perl variables are still evaluated. To prevent that,
522	a pure text mode is added which must always be prefixed with ';'
523	if it is not used as perl_prefix.
524	Other differences in TEXT lines:
525	'\$': In testgen, '\$' if not for perl variables is escaped with \$\$;
526	in $PROG, it is escaped with more conventional \\\$.
527	'#': .tg file is first fed to cpp for macro processing.
528	So, '#' can't appear in the 1st column even in text
529	mode unless it is escaped with \\.
530	leading spaces: In testgen, spaces following ':' are replaced with
531	1 blank; in $PROG, they survive to maintain original indent.
532	EOF
533	# end of prnt <<EOF;
534	}
535
536
537	sub basename {
538	my($name) = @_;
539	my( $basename ) = "";
540	split(/\//, $name);
541	$basename = pop @_;
542	## $basename =~ s/,.*$//;
543	return($basename);
544	}
545
546	1;
547