#!/usr/bin/perl -w

#
# Function: Perl script to strip out assembler code from PL/S source module
#
# Syntax: pls-split [path]pls-source
# where
# pls-source	filename of PL/S source; 
#		if no extension present '.mac' assumed
# path		path to PL/S source & output files
#
# Input:    PL/S source with embedded assembler source
# Output:   PL/S source without embedded assembler source
#           Assembler source without embedded PL/S source
#
# Notes: 
#	This code asserts '*' in column 1 means PL/S, else it's assembler;
#       of course, that's not always the case ....
#
#	Unreferenced assembler definitions are discarded to reduce asm source size.
#

$arg = $ARGV[0];
$file = $arg;				# assume no path present
$ext = '.mac';
$plspath = '';
if ($arg =~ /\//) {			# path present?
	my @junk = split "/", $arg;
	$file = $junk[-1];		# save filename[.extension]
	$junk[-1] = '';			# drop filename
	$plspath = join "/", @junk;	# reassemble path
	chdir $plspath or die "chdir $plspath error\n";
}
if ($file =~ /\./) {			# extension present?
	my @junk = split /\./, $file;
	$file = $junk[0];
	$ext = "." . "$junk[1]";	# save user's extension
}
$infile = "$file$ext";
$plsfile = "$file-pls$ext";
$asmfile = "$file-asm$ext";
$stop1 = "START UNREFERENCED COMPONENTS";
$stop2 = "END UNREFERENCED COMPONENTS";
print "------------------------------------------------------------------------------\n";
unless (open INPUT, "<$infile") {die "Open $infile failed: $!"};
unless (open OUTPLS, ">$plsfile") {die "Open $plsfile failed: $!"};
unless (open OUTASM, ">$asmfile") {die "Open $asmfile failed: $!"};
my $readsrc = 0;
my $writepls = 0;
my $writeasm = 0;
while (<INPUT>) {
	my $line = $_;
	chomp $line;
	$readsrc++;
	my $char1 = substr($line, 0, 1);		# get 1st char
	if ($char1 eq '*') {
#-------------------------------------------------------# a PL/S statement
		if ($line =~ /$stop1/) {
			while ( !($line =~ /$stop2/)) {
#				print "Discarding $line";
				$line = <INPUT>;
			}
#			print "Discarding $line";
			next;
		}
		my $rc = null_comment($line);		# ignore null PL/S comments
		if ($rc) {next}
		$rc = non_null_comment($line);
		if ($rc) {
			print OUTASM "$line\n";		# echo to assembly output
			$writeasm++;
		}
		if (($line =~ / GENERATE/) ||
		   ($line =~ /GEN;/) ||
		   ($line =~ / GEN /)) {
			$line = generate($line);	# handle PL/S GENERATE stmt
		}
		if ($line =~ /^\*( )+END /) {
			print OUTASM "$line\n";		# echo END subrtn to asm
			$writeasm++;
		}
		print OUTPLS "$line\n";			# save asm comments as PL/S
		$writepls++;
#-------------------------------------------------------# an assembler statement
	} else {
		print OUTASM "$line\n";
		$writeasm++;
	}
}
close INPUT;
close OUTPLS;
close OUTASM;
print "$plspath" . "$infile - read $readsrc\n";
print "$plspath" . "$plsfile - wrote $writepls\n";
print "$plspath" . "$asmfile - wrote $writeasm\n";
exit;

sub null_comment {
	my $line = $_[0];			# input line
	if ($line =~ /^\*( )+\/\*( )+\*\//) {	# contains only * [...] /* [...] */
#		print "Null comment $line\n";
		return 1;			# reject null comment
	}
	return 0;				# preserve everything else
}

sub non_null_comment {
	my $line = $_[0];			# input line
	my $class = "[\-\/ A-Za-z0-9\#\@\'\,\.\=\*]";
	if ($line =~ /^\*( )+\/\*($class)+\*\//) {	# contains * [...] /* comment */
#		print "PL/S comment $line\n";
		return 1;			# reject null comment
	}
	return 0;				# preserve everything else
}

sub generate {
	my $line = $_[0];			# input line
	if ($line =~ /^\*\/\*/) {
		return $line;			# bypass PL/S comments
	}
	print OUTPLS "$line\n";			# echo GENERATE; line
	print OUTASM "$line\n";
	$writepls++;
	$writeasm++;
	$line = <INPUT>;
	chomp $line;
	my $genchar1 = substr($line, 0, 1);
	while ($genchar1 eq '*') {		# first, handle GENERATE continuations
		print OUTASM "$line\n";
		print OUTPLS "$line\n";
		$writepls++;
		$writeasm++;
		$line = <INPUT>;
		chomp $line;
		$genchar1 = substr($line, 0, 1);
	}
	while ($genchar1 ne '*') {		# now, the GENERATE'd code itself
		print OUTASM "$line\n";
		print OUTPLS "$line\n";
		$writepls++;
		$writeasm++;
		$line = <INPUT>;
		chomp $line;
		$genchar1 = substr($line, 0, 1);
	}
	return $line;
}