[perl5.git] / x2p / s2p.SH

: This forces SH files to create target in same directory as SH file.
: This is so that make depend always knows where to find SH derivatives.
case "$0" in
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
case $CONFIG in
'')
    if test ! -f config.sh; then
	ln ../config.sh . || \
	ln -s ../config.sh . || \
	ln ../../config.sh . || \
	ln ../../../config.sh . || \
	(echo "Can't find config.sh."; exit 1)
    fi 2>/dev/null
    . ./config.sh
    ;;
esac
echo "Extracting s2p (with variable substitutions)"
: This section of the file will have variable substitutions done on it.
: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
: Protect any dollar signs and backticks that you do not want interpreted
: by putting a backslash in front.  You may delete these comments.
$spitshell >s2p <<!GROK!THIS!
#!$bin/perl

\$bin = '$bin';
!GROK!THIS!

: In the following dollars and backticks do not need the extra backslash.
$spitshell >>s2p <<'!NO!SUBS!'

# $Header: s2p.SH,v 4.0 91/03/20 01:57:59 lwall Locked $
#
# $Log:	s2p.SH,v $
# Revision 4.0  91/03/20  01:57:59  lwall
# 4.0 baseline.
# 
#

$indent = 4;
$shiftwidth = 4;
$l = '{'; $r = '}';

while ($ARGV[0] =~ /^-/) {
    $_ = shift;
  last if /^--/;
    if (/^-D/) {
	$debug++;
	open(BODY,'>-');
	next;
    }
    if (/^-n/) {
	$assumen++;
	next;
    }
    if (/^-p/) {
	$assumep++;
	next;
    }
    die "I don't recognize this switch: $_\n";
}

unless ($debug) {
    open(BODY,">/tmp/sperl$$") ||
      &Die("Can't open temp file: $!\n");
}

if (!$assumen && !$assumep) {
    print BODY <<'EOT';
while ($ARGV[0] =~ /^-/) {
    $_ = shift;
  last if /^--/;
    if (/^-n/) {
	$nflag++;
	next;
    }
    die "I don't recognize this switch: $_\\n";
}

EOT
}

print BODY <<'EOT';

#ifdef PRINTIT
#ifdef ASSUMEP
$printit++;
#else
$printit++ unless $nflag;
#endif
#endif
LINE: while (<>) {
EOT

LINE: while (<>) {

    # Wipe out surrounding whitespace.

    s/[ \t]*(.*)\n$/$1/;

    # Perhaps it's a label/comment.

    if (/^:/) {
	s/^:[ \t]*//;
	$label = &make_label($_);
	if ($. == 1) {
	    $toplabel = $label;
	}
	$_ = "$label:";
	if ($lastlinewaslabel++) {
	    $indent += 4;
	    print BODY &tab, ";\n";
	    $indent -= 4;
	}
	if ($indent >= 2) {
	    $indent -= 2;
	    $indmod = 2;
	}
	next;
    } else {
	$lastlinewaslabel = '';
    }

    # Look for one or two address clauses

    $addr1 = '';
    $addr2 = '';
    if (s/^([0-9]+)//) {
	$addr1 = "$1";
    }
    elsif (s/^\$//) {
	$addr1 = 'eof()';
    }
    elsif (s|^/||) {
	$addr1 = &fetchpat('/');
    }
    if (s/^,//) {
	if (s/^([0-9]+)//) {
	    $addr2 = "$1";
	} elsif (s/^\$//) {
	    $addr2 = "eof()";
	} elsif (s|^/||) {
	    $addr2 = &fetchpat('/');
	} else {
	    &Die("Invalid second address at line $.\n");
	}
	$addr1 .= " .. $addr2";
    }

    # Now we check for metacommands {, }, and ! and worry
    # about indentation.

    s/^[ \t]+//;
    # a { to keep vi happy
    if ($_ eq '}') {
	$indent -= 4;
	next;
    }
    if (s/^!//) {
	$if = 'unless';
	$else = "$r else $l\n";
    } else {
	$if = 'if';
	$else = '';
    }
    if (s/^{//) {	# a } to keep vi happy
	$indmod = 4;
	$redo = $_;
	$_ = '';
	$rmaybe = '';
    } else {
	$rmaybe = "\n$r";
	if ($addr2 || $addr1) {
	    $space = ' ' x $shiftwidth;
	} else {
	    $space = '';
	}
	$_ = &transmogrify();
    }

    # See if we can optimize to modifier form.

    if ($addr1) {
	if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
	  $_ !~ / if / && $_ !~ / unless /) {
	    s/;$/ $if $addr1;/;
	    $_ = substr($_,$shiftwidth,1000);
	} else {
	    $_ = "$if ($addr1) $l\n$change$_$rmaybe";
	}
	$change = '';
	next LINE;
    }
} continue {
    @lines = split(/\n/,$_);
    for (@lines) {
	unless (s/^ *<<--//) {
	    print BODY &tab;
	}
	print BODY $_, "\n";
    }
    $indent += $indmod;
    $indmod = 0;
    if ($redo) {
	$_ = $redo;
	$redo = '';
	redo LINE;
    }
}
if ($lastlinewaslabel++) {
    $indent += 4;
    print BODY &tab, ";\n";
    $indent -= 4;
}

print BODY "}\n";
if ($appendseen || $tseen || !$assumen) {
    $printit++ if $dseen || (!$assumen && !$assumep);
    print BODY <<'EOT';

continue {
#ifdef PRINTIT
#ifdef DSEEN
#ifdef ASSUMEP
    print if $printit++;
#else
    if ($printit)
	{ print; }
    else
	{ $printit++ unless $nflag; }
#endif
#else
    print if $printit;
#endif
#else
    print;
#endif
#ifdef TSEEN
    $tflag = '';
#endif
#ifdef APPENDSEEN
    if ($atext) { print $atext; $atext = ''; }
#endif
}
EOT
}

close BODY;

unless ($debug) {
    open(HEAD,">/tmp/sperl2$$.c")
      || &Die("Can't open temp file 2: $!\n");
    print HEAD "#define PRINTIT\n" if ($printit);
    print HEAD "#define APPENDSEEN\n" if ($appendseen);
    print HEAD "#define TSEEN\n" if ($tseen);
    print HEAD "#define DSEEN\n" if ($dseen);
    print HEAD "#define ASSUMEN\n" if ($assumen);
    print HEAD "#define ASSUMEP\n" if ($assumep);
    if ($opens) {print HEAD "$opens\n";}
    open(BODY,"/tmp/sperl$$")
      || &Die("Can't reopen temp file: $!\n");
    while (<BODY>) {
	print HEAD $_;
    }
    close HEAD;

    print <<"EOT";
#!$bin/perl
eval 'exec $bin/perl -S \$0 \$*'
	if \$running_under_some_shell;

EOT
    open(BODY,"cc -E /tmp/sperl2$$.c |") ||
	&Die("Can't reopen temp file: $!\n");
    while (<BODY>) {
	/^# [0-9]/ && next;
	/^[ \t]*$/ && next;
	s/^<><>//;
	print;
    }
}

&Cleanup;
exit;

sub Cleanup {
    chdir "/tmp";
    unlink "sperl$$", "sperl2$$", "sperl2$$.c";
}
sub Die {
    &Cleanup;
    die $_[0];
}
sub tab {
    "\t" x ($indent / 8) . ' ' x ($indent % 8);
}
sub make_filehandle {
    local($_) = $_[0];
    local($fname) = $_;
    s/[^a-zA-Z]/_/g;
    s/^_*//;
    substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
    if (!$seen{$_}) {
	$opens .= <<"EOT";
open($_,'>$fname') || die "Can't create $fname";
EOT
    }
    $seen{$_} = $_;
}

sub make_label {
    local($label) = @_;
    $label =~ s/[^a-zA-Z0-9]/_/g;
    if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
    $label = substr($label,0,8);

    # Could be a reserved word, so capitalize it.
    substr($label,0,1) =~ y/a-z/A-Z/
      if $label =~ /^[a-z]/;

    $label;
}

sub transmogrify {
    {	# case
	if (/^d/) {
	    $dseen++;
	    chop($_ = <<'EOT');
<<--#ifdef PRINTIT
$printit = '';
<<--#endif
next LINE;
EOT
	    next;
	}

	if (/^n/) {
	    chop($_ = <<'EOT');
<<--#ifdef PRINTIT
<<--#ifdef DSEEN
<<--#ifdef ASSUMEP
print if $printit++;
<<--#else
if ($printit)
    { print; }
else
    { $printit++ unless $nflag; }
<<--#endif
<<--#else
print if $printit;
<<--#endif
<<--#else
print;
<<--#endif
<<--#ifdef APPENDSEEN
if ($atext) {print $atext; $atext = '';}
<<--#endif
$_ = <>;
<<--#ifdef TSEEN
$tflag = '';
<<--#endif
EOT
	    next;
	}

	if (/^a/) {
	    $appendseen++;
	    $command = $space . '$atext .=' . "\n<<--'";
	    $lastline = 0;
	    while (<>) {
		s/^[ \t]*//;
		s/^[\\]//;
		unless (s|\\$||) { $lastline = 1;}
		s/'/\\'/g;
		s/^([ \t]*\n)/<><>$1/;
		$command .= $_;
		$command .= '<<--';
		last if $lastline;
	    }
	    $_ = $command . "';";
	    last;
	}

	if (/^[ic]/) {
	    if (/^c/) { $change = 1; }
	    $addr1 = '$iter = (' . $addr1 . ')';
	    $command = $space . 'if ($iter == 1) { print'
	      . "\n<<--'";
	    $lastline = 0;
	    while (<>) {
		s/^[ \t]*//;
		s/^[\\]//;
		unless (s/\\$//) { $lastline = 1;}
		s/'/\\'/g;
		s/^([ \t]*\n)/<><>$1/;
		$command .= $_;
		$command .= '<<--';
		last if $lastline;
	    }
	    $_ = $command . "';}";
	    if ($change) {
		$dseen++;
		$change = "$_\n";
		chop($_ = <<"EOT");
<<--#ifdef PRINTIT
$space\$printit = '';
<<--#endif
${space}next LINE;
EOT
	    }
	    last;
	}

	if (/^s/) {
	    $delim = substr($_,1,1);
	    $len = length($_);
	    $repl = $end = 0;
	    $inbracket = 0;
	    for ($i = 2; $i < $len; $i++) {
		$c = substr($_,$i,1);
		if ($c eq $delim) {
		    if ($inbracket) {
			substr($_, $i, 0) = '\\';
			$i++;
			$len++;
		    }
		    else {
			if ($repl) {
			    $end = $i;
			    last;
			} else {
			    $repl = $i;
			}
		    }
		}
		elsif ($c eq '\\') {
		    $i++;
		    if ($i >= $len) {
			$_ .= 'n';
			$_ .= <>;
			$len = length($_);
			$_ = substr($_,0,--$len);
		    }
		    elsif (substr($_,$i,1) =~ /^[n]$/) {
			;
		    }
		    elsif (!$repl &&
		      substr($_,$i,1) =~ /^[(){}\w]$/) {
			$i--;
			$len--;
			substr($_, $i, 1) = '';
		    }
		    elsif (!$repl &&
		      substr($_,$i,1) =~ /^[<>]$/) {
			substr($_,$i,1) = 'b';
		    }
		}
		elsif ($c eq '[' && !$repl) {
		    $i++ if substr($_,$i,1) eq '^';
		    $i++ if substr($_,$i,1) eq ']';
		    $inbracket = 1;
		}
		elsif ($c eq ']') {
		    $inbracket = 0;
		}
		elsif (!$repl && index("()+",$c) >= 0) {
		    substr($_, $i, 0) = '\\';
		    $i++;
		    $len++;
		}
	    }
	    &Die("Malformed substitution at line $.\n")
	      unless $end;
	    $pat = substr($_, 0, $repl + 1);
	    $repl = substr($_, $repl+1, $end-$repl-1);
	    $end = substr($_, $end + 1, 1000);
	    $dol = '$';
	    $repl =~ s/\$/\\$/;
	    $repl =~ s'&'$&'g;
	    $repl =~ s/[\\]([0-9])/$dol$1/g;
	    $subst = "$pat$repl$delim";
	    $cmd = '';
	    while ($end) {
		if ($end =~ s/^g//) {
		    $subst .= 'g';
		    next;
		}
		if ($end =~ s/^p//) {
		    $cmd .= ' && (print)';
		    next;
		}
		if ($end =~ s/^w[ \t]*//) {
		    $fh = &make_filehandle($end);
		    $cmd .= " && (print $fh \$_)";
		    $end = '';
		    next;
		}
		&Die("Unrecognized substitution command".
		  "($end) at line $.\n");
	    }
	    chop ($_ = <<"EOT");
<<--#ifdef TSEEN
$subst && \$tflag++$cmd;
<<--#else
$subst$cmd;
<<--#endif
EOT
	    next;
	}

	if (/^p/) {
	    $_ = 'print;';
	    next;
	}

	if (/^w/) {
	    s/^w[ \t]*//;
	    $fh = &make_filehandle($_);
	    $_ = "print $fh \$_;";
	    next;
	}

	if (/^r/) {
	    $appendseen++;
	    s/^r[ \t]*//;
	    $file = $_;
	    $_ = "\$atext .= `cat $file 2>/dev/null`;";
	    next;
	}

	if (/^P/) {
	    $_ = 'print $1 if /(^.*\n)/;';
	    next;
	}

	if (/^D/) {
	    chop($_ = <<'EOT');
s/^.*\n//;
redo LINE if $_;
next LINE;
EOT
	    next;
	}

	if (/^N/) {
	    chop($_ = <<'EOT');
$_ .= <>;
<<--#ifdef TSEEN
$tflag = '';
<<--#endif
EOT
	    next;
	}

	if (/^h/) {
	    $_ = '$hold = $_;';
	    next;
	}

	if (/^H/) {
	    $_ = '$hold .= $_ ? $_ : "\n";';
	    next;
	}

	if (/^g/) {
	    $_ = '$_ = $hold;';
	    next;
	}

	if (/^G/) {
	    $_ = '$_ .= $hold ? $hold : "\n";';
	    next;
	}

	if (/^x/) {
	    $_ = '($_, $hold) = ($hold, $_);';
	    next;
	}

	if (/^b$/) {
	    $_ = 'next LINE;';
	    next;
	}

	if (/^b/) {
	    s/^b[ \t]*//;
	    $lab = &make_label($_);
	    if ($lab eq $toplabel) {
		$_ = 'redo LINE;';
	    } else {
		$_ = "goto $lab;";
	    }
	    next;
	}

	if (/^t$/) {
	    $_ = 'next LINE if $tflag;';
	    $tseen++;
	    next;
	}

	if (/^t/) {
	    s/^t[ \t]*//;
	    $lab = &make_label($_);
	    $_ = q/if ($tflag) {$tflag = ''; /;
	    if ($lab eq $toplabel) {
		$_ .= 'redo LINE;}';
	    } else {
		$_ .= "goto $lab;}";
	    }
	    $tseen++;
	    next;
	}

	if (/^=/) {
	    $_ = 'print "$.\n";';
	    next;
	}

	if (/^q/) {
	    chop($_ = <<'EOT');
close(ARGV);
@ARGV = ();
next LINE;
EOT
	    next;
	}
    } continue {
	if ($space) {
	    s/^/$space/;
	    s/(\n)(.)/$1$space$2/g;
	}
	last;
    }
    $_;
}

sub fetchpat {
    local($outer) = @_;
    local($addr) = $outer;
    local($inbracket);
    local($prefix,$delim,$ch);

    # Process pattern one potential delimiter at a time.

    DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
	$prefix = $1;
	$delim = $2;
	if ($delim eq '\\') {
	    s/(.)//;
	    $ch = $1;
	    $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
	    $ch = 'b' if $ch =~ /^[<>]$/;
	    $delim .= $ch;
	}
	elsif ($delim eq '[') {
	    $inbracket = 1;
	    s/^\^// && ($delim .= '^');
	    s/^]// && ($delim .= ']');
	}
	elsif ($delim eq ']') {
	    $inbracket = 0;
	}
	elsif ($inbracket || $delim ne $outer) {
	    $delim = '\\' . $delim;
	}
	$addr .= $prefix;
	$addr .= $delim;
	if ($delim eq $outer && !$inbracket) {
	    last DELIM;
	}
    }
    $addr;
}

!NO!SUBS!
chmod 755 s2p
$eunicefix s2p
Commit	Line	Data
a687059c LW	1	: This forces SH files to create target in same directory as SH file.
	2	: This is so that make depend always knows where to find SH derivatives.
	3	case "$0" in
	4	/) cd `expr X$0 : 'X\(.*\)/'` ;;
	5	esac
	6	case $CONFIG in
	7	'')
	8	if test ! -f config.sh; then
	9	ln ../config.sh . \|\| \
27e2fb84	10	ln -s ../config.sh . \|\| \
a687059c LW	11	ln ../../config.sh . \|\| \
	12	ln ../../../config.sh . \|\| \
	13	(echo "Can't find config.sh."; exit 1)
fe14fcc3	14	fi 2>/dev/null
e5d73d77	15	. ./config.sh
a687059c LW	16	;;
	17	esac
	18	echo "Extracting s2p (with variable substitutions)"
	19	: This section of the file will have variable substitutions done on it.
	20	: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
	21	: Protect any dollar signs and backticks that you do not want interpreted
	22	: by putting a backslash in front. You may delete these comments.
	23	$spitshell >s2p <<!GROK!THIS!
	24	#!$bin/perl
	25
	26	\$bin = '$bin';
	27	!GROK!THIS!
	28
	29	: In the following dollars and backticks do not need the extra backslash.
	30	$spitshell >>s2p <<'!NO!SUBS!'
	31
fe14fcc3	32	# $Header: s2p.SH,v 4.0 91/03/20 01:57:59 lwall Locked $
378cc40b	33	#
a687059c	34	# $Log: s2p.SH,v $
fe14fcc3 LW	35	# Revision 4.0 91/03/20 01:57:59 lwall
fe14fcc3 LW	36	# 4.0 baseline.
378cc40b LW	37	#
378cc40b LW	38	#
8d063cd8 LW	39
	40	$indent = 4;
	41	$shiftwidth = 4;
	42	$l = '{'; $r = '}';
8d063cd8	43
0a12ae7d	44	while ($ARGV[0] =~ /^-/) {
8d063cd8 LW	45	$_ = shift;
	46	last if /^--/;
	47	if (/^-D/) {
	48	$debug++;
0a12ae7d	49	open(BODY,'>-');
8d063cd8 LW	50	next;
	51	}
	52	if (/^-n/) {
	53	$assumen++;
	54	next;
	55	}
	56	if (/^-p/) {
	57	$assumep++;
	58	next;
	59	}
378cc40b	60	die "I don't recognize this switch: $_\n";
8d063cd8 LW	61	}
	62
	63	unless ($debug) {
0a12ae7d LW	64	open(BODY,">/tmp/sperl$$") \|\|
0a12ae7d LW	65	&Die("Can't open temp file: $!\n");
8d063cd8 LW	66	}
	67
	68	if (!$assumen && !$assumep) {
0a12ae7d LW	69	print BODY <<'EOT';
0a12ae7d LW	70	while ($ARGV[0] =~ /^-/) {
8d063cd8 LW	71	$_ = shift;
	72	last if /^--/;
	73	if (/^-n/) {
	74	$nflag++;
	75	next;
	76	}
0a12ae7d	77	die "I don't recognize this switch: $_\\n";
8d063cd8 LW	78	}
8d063cd8 LW	79
0a12ae7d	80	EOT
8d063cd8 LW	81	}
8d063cd8 LW	82
0a12ae7d LW	83	print BODY <<'EOT';
0a12ae7d LW	84
8d063cd8 LW	85	#ifdef PRINTIT
	86	#ifdef ASSUMEP
	87	$printit++;
	88	#else
	89	$printit++ unless $nflag;
	90	#endif
	91	#endif
0a12ae7d LW	92	LINE: while (<>) {
	93	EOT
	94
	95	LINE: while (<>) {
	96
	97	# Wipe out surrounding whitespace.
8d063cd8	98
8d063cd8	99	s/[ \t](.)\n$/$1/;
0a12ae7d LW	100
	101	# Perhaps it's a label/comment.
	102
8d063cd8 LW	103	if (/^:/) {
8d063cd8 LW	104	s/^:[ \t]*//;
0a12ae7d	105	$label = &make_label($_);
8d063cd8 LW	106	if ($. == 1) {
	107	$toplabel = $label;
	108	}
	109	$_ = "$label:";
ffed7fef LW	110	if ($lastlinewaslabel++) {
ffed7fef LW	111	$indent += 4;
0a12ae7d	112	print BODY &tab, ";\n";
ffed7fef LW	113	$indent -= 4;
ffed7fef LW	114	}
8d063cd8 LW	115	if ($indent >= 2) {
	116	$indent -= 2;
	117	$indmod = 2;
	118	}
	119	next;
	120	} else {
	121	$lastlinewaslabel = '';
	122	}
0a12ae7d LW	123
	124	# Look for one or two address clauses
	125
8d063cd8 LW	126	$addr1 = '';
	127	$addr2 = '';
	128	if (s/^([0-9]+)//) {
	129	$addr1 = "$1";
	130	}
	131	elsif (s/^\$//) {
	132	$addr1 = 'eof()';
	133	}
	134	elsif (s\|^/\|\|) {
0a12ae7d	135	$addr1 = &fetchpat('/');
8d063cd8 LW	136	}
	137	if (s/^,//) {
	138	if (s/^([0-9]+)//) {
	139	$addr2 = "$1";
	140	} elsif (s/^\$//) {
	141	$addr2 = "eof()";
	142	} elsif (s\|^/\|\|) {
0a12ae7d	143	$addr2 = &fetchpat('/');
8d063cd8	144	} else {
0a12ae7d	145	&Die("Invalid second address at line $.\n");
8d063cd8 LW	146	}
	147	$addr1 .= " .. $addr2";
	148	}
0a12ae7d LW	149
	150	# Now we check for metacommands {, }, and ! and worry
	151	# about indentation.
	152
378cc40b	153	s/^[ \t]+//;
0a12ae7d	154	# a { to keep vi happy
8d063cd8 LW	155	if ($_ eq '}') {
	156	$indent -= 4;
	157	next;
	158	}
	159	if (s/^!//) {
	160	$if = 'unless';
	161	$else = "$r else $l\n";
	162	} else {
	163	$if = 'if';
	164	$else = '';
	165	}
	166	if (s/^{//) { # a } to keep vi happy
	167	$indmod = 4;
	168	$redo = $_;
	169	$_ = '';
	170	$rmaybe = '';
	171	} else {
	172	$rmaybe = "\n$r";
	173	if ($addr2 \|\| $addr1) {
a687059c	174	$space = ' ' x $shiftwidth;
8d063cd8 LW	175	} else {
	176	$space = '';
	177	}
0a12ae7d	178	$_ = &transmogrify();
8d063cd8 LW	179	}
8d063cd8 LW	180
0a12ae7d LW	181	# See if we can optimize to modifier form.
0a12ae7d LW	182
8d063cd8 LW	183	if ($addr1) {
	184	if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
	185	$_ !~ / if / && $_ !~ / unless /) {
	186	s/;$/ $if $addr1;/;
	187	$_ = substr($_,$shiftwidth,1000);
	188	} else {
0a12ae7d	189	$_ = "$if ($addr1) $l\n$change$_$rmaybe";
8d063cd8 LW	190	}
8d063cd8 LW	191	$change = '';
0a12ae7d	192	next LINE;
8d063cd8 LW	193	}
	194	} continue {
	195	@lines = split(/\n/,$_);
0a12ae7d	196	for (@lines) {
8d063cd8	197	unless (s/^ *<<--//) {
0a12ae7d	198	print BODY &tab;
8d063cd8	199	}
0a12ae7d	200	print BODY $_, "\n";
8d063cd8 LW	201	}
	202	$indent += $indmod;
	203	$indmod = 0;
	204	if ($redo) {
	205	$_ = $redo;
	206	$redo = '';
0a12ae7d	207	redo LINE;
8d063cd8 LW	208	}
8d063cd8 LW	209	}
ffed7fef LW	210	if ($lastlinewaslabel++) {
ffed7fef LW	211	$indent += 4;
0a12ae7d	212	print BODY &tab, ";\n";
ffed7fef LW	213	$indent -= 4;
ffed7fef LW	214	}
8d063cd8	215
0a12ae7d	216	print BODY "}\n";
8d063cd8 LW	217	if ($appendseen \|\| $tseen \|\| !$assumen) {
8d063cd8 LW	218	$printit++ if $dseen \|\| (!$assumen && !$assumep);
0a12ae7d LW	219	print BODY <<'EOT';
0a12ae7d LW	220
8d063cd8 LW	221	continue {
	222	#ifdef PRINTIT
	223	#ifdef DSEEN
	224	#ifdef ASSUMEP
	225	print if $printit++;
	226	#else
0a12ae7d LW	227	if ($printit)
	228	{ print; }
	229	else
	230	{ $printit++ unless $nflag; }
8d063cd8 LW	231	#endif
	232	#else
	233	print if $printit;
	234	#endif
	235	#else
	236	print;
	237	#endif
	238	#ifdef TSEEN
0a12ae7d	239	$tflag = '';
8d063cd8 LW	240	#endif
8d063cd8 LW	241	#ifdef APPENDSEEN
0a12ae7d	242	if ($atext) { print $atext; $atext = ''; }
8d063cd8 LW	243	#endif
8d063cd8 LW	244	}
0a12ae7d	245	EOT
8d063cd8 LW	246	}
8d063cd8 LW	247
0a12ae7d	248	close BODY;
8d063cd8 LW	249
8d063cd8 LW	250	unless ($debug) {
0a12ae7d LW	251	open(HEAD,">/tmp/sperl2$$.c")
	252	\|\| &Die("Can't open temp file 2: $!\n");
	253	print HEAD "#define PRINTIT\n" if ($printit);
	254	print HEAD "#define APPENDSEEN\n" if ($appendseen);
	255	print HEAD "#define TSEEN\n" if ($tseen);
	256	print HEAD "#define DSEEN\n" if ($dseen);
	257	print HEAD "#define ASSUMEN\n" if ($assumen);
	258	print HEAD "#define ASSUMEP\n" if ($assumep);
	259	if ($opens) {print HEAD "$opens\n";}
	260	open(BODY,"/tmp/sperl$$")
	261	\|\| &Die("Can't reopen temp file: $!\n");
	262	while (<BODY>) {
	263	print HEAD $_;
8d063cd8	264	}
0a12ae7d	265	close HEAD;
8d063cd8	266
0a12ae7d LW	267	print <<"EOT";
	268	#!$bin/perl
	269	eval 'exec $bin/perl -S \$0 \$*'
a687059c LW	270	if \$running_under_some_shell;
a687059c LW	271
0a12ae7d LW	272	EOT
	273	open(BODY,"cc -E /tmp/sperl2$$.c \|") \|\|
	274	&Die("Can't reopen temp file: $!\n");
	275	while (<BODY>) {
8d063cd8 LW	276	/^# [0-9]/ && next;
	277	/^[ \t]*$/ && next;
	278	s/^<><>//;
	279	print;
	280	}
	281	}
	282
0a12ae7d LW	283	&Cleanup;
0a12ae7d LW	284	exit;
8d063cd8	285
0a12ae7d LW	286	sub Cleanup {
	287	chdir "/tmp";
	288	unlink "sperl$$", "sperl2$$", "sperl2$$.c";
	289	}
8d063cd8	290	sub Die {
0a12ae7d	291	&Cleanup;
8d063cd8 LW	292	die $_[0];
8d063cd8 LW	293	}
0a12ae7d LW	294	sub tab {
	295	"\t" x ($indent / 8) . ' ' x ($indent % 8);
	296	}
8d063cd8	297	sub make_filehandle {
0a12ae7d LW	298	local($_) = $_[0];
0a12ae7d LW	299	local($fname) = $_;
8d063cd8 LW	300	s/[^a-zA-Z]/_/g;
8d063cd8 LW	301	s/^_*//;
0a12ae7d	302	substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
8d063cd8	303	if (!$seen{$_}) {
0a12ae7d LW	304	$opens .= <<"EOT";
	305	open($_,'>$fname') \|\| die "Can't create $fname";
	306	EOT
8d063cd8 LW	307	}
	308	$seen{$_} = $_;
	309	}
	310
	311	sub make_label {
0a12ae7d	312	local($label) = @_;
8d063cd8 LW	313	$label =~ s/[^a-zA-Z0-9]/_/g;
	314	if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
	315	$label = substr($label,0,8);
0a12ae7d LW	316
	317	# Could be a reserved word, so capitalize it.
	318	substr($label,0,1) =~ y/a-z/A-Z/
	319	if $label =~ /^[a-z]/;
	320
8d063cd8 LW	321	$label;
	322	}
	323
	324	sub transmogrify {
	325	{ # case
	326	if (/^d/) {
	327	$dseen++;
0a12ae7d	328	chop($_ = <<'EOT');
8d063cd8	329	<<--#ifdef PRINTIT
0a12ae7d	330	$printit = '';
8d063cd8	331	<<--#endif
0a12ae7d LW	332	next LINE;
0a12ae7d LW	333	EOT
8d063cd8 LW	334	next;
	335	}
	336
	337	if (/^n/) {
0a12ae7d LW	338	chop($_ = <<'EOT');
0a12ae7d LW	339	<<--#ifdef PRINTIT
8d063cd8 LW	340	<<--#ifdef DSEEN
	341	<<--#ifdef ASSUMEP
	342	print if $printit++;
	343	<<--#else
0a12ae7d LW	344	if ($printit)
	345	{ print; }
	346	else
	347	{ $printit++ unless $nflag; }
8d063cd8 LW	348	<<--#endif
	349	<<--#else
	350	print if $printit;
	351	<<--#endif
	352	<<--#else
	353	print;
	354	<<--#endif
	355	<<--#ifdef APPENDSEEN
0a12ae7d	356	if ($atext) {print $atext; $atext = '';}
8d063cd8 LW	357	<<--#endif
	358	$_ = <>;
	359	<<--#ifdef TSEEN
0a12ae7d LW	360	$tflag = '';
	361	<<--#endif
	362	EOT
8d063cd8 LW	363	next;
	364	}
	365
	366	if (/^a/) {
	367	$appendseen++;
0a12ae7d	368	$command = $space . '$atext .=' . "\n<<--'";
8d063cd8 LW	369	$lastline = 0;
	370	while (<>) {
	371	s/^[ \t]*//;
	372	s/^[\\]//;
	373	unless (s\|\\$\|\|) { $lastline = 1;}
	374	s/'/\\'/g;
	375	s/^([ \t]*\n)/<><>$1/;
	376	$command .= $_;
	377	$command .= '<<--';
	378	last if $lastline;
	379	}
	380	$_ = $command . "';";
	381	last;
	382	}
	383
	384	if (/^[ic]/) {
	385	if (/^c/) { $change = 1; }
	386	$addr1 = '$iter = (' . $addr1 . ')';
0a12ae7d LW	387	$command = $space . 'if ($iter == 1) { print'
0a12ae7d LW	388	. "\n<<--'";
8d063cd8 LW	389	$lastline = 0;
	390	while (<>) {
	391	s/^[ \t]*//;
	392	s/^[\\]//;
	393	unless (s/\\$//) { $lastline = 1;}
	394	s/'/\\'/g;
	395	s/^([ \t]*\n)/<><>$1/;
	396	$command .= $_;
	397	$command .= '<<--';
	398	last if $lastline;
	399	}
	400	$_ = $command . "';}";
	401	if ($change) {
	402	$dseen++;
	403	$change = "$_\n";
0a12ae7d	404	chop($_ = <<"EOT");
8d063cd8 LW	405	<<--#ifdef PRINTIT
	406	$space\$printit = '';
	407	<<--#endif
0a12ae7d LW	408	${space}next LINE;
0a12ae7d LW	409	EOT
8d063cd8 LW	410	}
	411	last;
	412	}
	413
	414	if (/^s/) {
	415	$delim = substr($_,1,1);
	416	$len = length($_);
	417	$repl = $end = 0;
a687059c	418	$inbracket = 0;
8d063cd8 LW	419	for ($i = 2; $i < $len; $i++) {
8d063cd8 LW	420	$c = substr($_,$i,1);
a687059c LW	421	if ($c eq $delim) {
a687059c LW	422	if ($inbracket) {
0a12ae7d	423	substr($_, $i, 0) = '\\';
a687059c LW	424	$i++;
	425	$len++;
	426	}
	427	else {
	428	if ($repl) {
	429	$end = $i;
	430	last;
	431	} else {
	432	$repl = $i;
	433	}
	434	}
	435	}
	436	elsif ($c eq '\\') {
8d063cd8 LW	437	$i++;
	438	if ($i >= $len) {
	439	$_ .= 'n';
	440	$_ .= <>;
	441	$len = length($_);
	442	$_ = substr($_,0,--$len);
	443	}
00bf170e LW	444	elsif (substr($_,$i,1) =~ /^[n]$/) {
	445	;
	446	}
0a12ae7d LW	447	elsif (!$repl &&
0a12ae7d LW	448	substr($_,$i,1) =~ /^[(){}\w]$/) {
8d063cd8 LW	449	$i--;
8d063cd8 LW	450	$len--;
0a12ae7d	451	substr($_, $i, 1) = '';
8d063cd8	452	}
0a12ae7d LW	453	elsif (!$repl &&
0a12ae7d LW	454	substr($_,$i,1) =~ /^[<>]$/) {
9f68db38 LW	455	substr($_,$i,1) = 'b';
9f68db38 LW	456	}
8d063cd8	457	}
a687059c LW	458	elsif ($c eq '[' && !$repl) {
	459	$i++ if substr($_,$i,1) eq '^';
	460	$i++ if substr($_,$i,1) eq ']';
	461	$inbracket = 1;
8d063cd8	462	}
a687059c LW	463	elsif ($c eq ']') {
	464	$inbracket = 0;
	465	}
ae986130	466	elsif (!$repl && index("()+",$c) >= 0) {
0a12ae7d	467	substr($_, $i, 0) = '\\';
8d063cd8 LW	468	$i++;
	469	$len++;
	470	}
	471	}
0a12ae7d LW	472	&Die("Malformed substitution at line $.\n")
0a12ae7d LW	473	unless $end;
8d063cd8	474	$pat = substr($_, 0, $repl + 1);
0a12ae7d	475	$repl = substr($_, $repl+1, $end-$repl-1);
8d063cd8 LW	476	$end = substr($_, $end + 1, 1000);
8d063cd8 LW	477	$dol = '$';
378cc40b	478	$repl =~ s/\$/\\$/;
8d063cd8 LW	479	$repl =~ s'&'$&'g;
	480	$repl =~ s/[\\]([0-9])/$dol$1/g;
	481	$subst = "$pat$repl$delim";
	482	$cmd = '';
	483	while ($end) {
0a12ae7d LW	484	if ($end =~ s/^g//) {
	485	$subst .= 'g';
	486	next;
	487	}
	488	if ($end =~ s/^p//) {
	489	$cmd .= ' && (print)';
	490	next;
	491	}
8d063cd8	492	if ($end =~ s/^w[ \t]*//) {
0a12ae7d	493	$fh = &make_filehandle($end);
8d063cd8 LW	494	$cmd .= " && (print $fh \$_)";
	495	$end = '';
	496	next;
	497	}
0a12ae7d LW	498	&Die("Unrecognized substitution command".
0a12ae7d LW	499	"($end) at line $.\n");
8d063cd8	500	}
0a12ae7d LW	501	chop ($_ = <<"EOT");
0a12ae7d LW	502	<<--#ifdef TSEEN
a687059c LW	503	$subst && \$tflag++$cmd;
	504	<<--#else
	505	$subst$cmd;
0a12ae7d LW	506	<<--#endif
0a12ae7d LW	507	EOT
8d063cd8 LW	508	next;
	509	}
	510
	511	if (/^p/) {
	512	$_ = 'print;';
	513	next;
	514	}
	515
	516	if (/^w/) {
	517	s/^w[ \t]*//;
0a12ae7d	518	$fh = &make_filehandle($_);
8d063cd8 LW	519	$_ = "print $fh \$_;";
	520	next;
	521	}
	522
	523	if (/^r/) {
	524	$appendseen++;
	525	s/^r[ \t]*//;
	526	$file = $_;
	527	$_ = "\$atext .= `cat $file 2>/dev/null`;";
	528	next;
	529	}
	530
	531	if (/^P/) {
a687059c	532	$_ = 'print $1 if /(^.*\n)/;';
8d063cd8 LW	533	next;
	534	}
	535
	536	if (/^D/) {
0a12ae7d LW	537	chop($_ = <<'EOT');
	538	s/^.*\n//;
	539	redo LINE if $_;
	540	next LINE;
	541	EOT
8d063cd8 LW	542	next;
	543	}
	544
	545	if (/^N/) {
0a12ae7d	546	chop($_ = <<'EOT');
8d063cd8 LW	547	$_ .= <>;
8d063cd8 LW	548	<<--#ifdef TSEEN
0a12ae7d LW	549	$tflag = '';
	550	<<--#endif
	551	EOT
8d063cd8 LW	552	next;
	553	}
	554
	555	if (/^h/) {
	556	$_ = '$hold = $_;';
	557	next;
	558	}
	559
	560	if (/^H/) {
	561	$_ = '$hold .= $_ ? $_ : "\n";';
	562	next;
	563	}
	564
	565	if (/^g/) {
	566	$_ = '$_ = $hold;';
	567	next;
	568	}
	569
	570	if (/^G/) {
	571	$_ = '$_ .= $hold ? $hold : "\n";';
	572	next;
	573	}
	574
	575	if (/^x/) {
	576	$_ = '($_, $hold) = ($hold, $_);';
	577	next;
	578	}
	579
	580	if (/^b$/) {
0a12ae7d	581	$_ = 'next LINE;';
8d063cd8 LW	582	next;
	583	}
	584
	585	if (/^b/) {
	586	s/^b[ \t]*//;
0a12ae7d	587	$lab = &make_label($_);
8d063cd8	588	if ($lab eq $toplabel) {
0a12ae7d	589	$_ = 'redo LINE;';
8d063cd8 LW	590	} else {
	591	$_ = "goto $lab;";
	592	}
	593	next;
	594	}
	595
	596	if (/^t$/) {
0a12ae7d	597	$_ = 'next LINE if $tflag;';
8d063cd8 LW	598	$tseen++;
	599	next;
	600	}
	601
	602	if (/^t/) {
	603	s/^t[ \t]*//;
0a12ae7d LW	604	$lab = &make_label($_);
0a12ae7d LW	605	$_ = q/if ($tflag) {$tflag = ''; /;
8d063cd8	606	if ($lab eq $toplabel) {
0a12ae7d	607	$_ .= 'redo LINE;}';
8d063cd8	608	} else {
0a12ae7d	609	$_ .= "goto $lab;}";
8d063cd8 LW	610	}
	611	$tseen++;
	612	next;
	613	}
	614
	615	if (/^=/) {
	616	$_ = 'print "$.\n";';
	617	next;
	618	}
	619
	620	if (/^q/) {
0a12ae7d LW	621	chop($_ = <<'EOT');
0a12ae7d LW	622	close(ARGV);
8d063cd8	623	@ARGV = ();
0a12ae7d LW	624	next LINE;
0a12ae7d LW	625	EOT
8d063cd8 LW	626	next;
	627	}
	628	} continue {
	629	if ($space) {
	630	s/^/$space/;
	631	s/(\n)(.)/$1$space$2/g;
	632	}
	633	last;
	634	}
	635	$_;
	636	}
	637
a687059c LW	638	sub fetchpat {
	639	local($outer) = @_;
	640	local($addr) = $outer;
	641	local($inbracket);
	642	local($prefix,$delim,$ch);
	643
0a12ae7d LW	644	# Process pattern one potential delimiter at a time.
	645
	646	DELIM: while (s#^([^\]+(\|)[\\/]*)([]+(\|)[\\/])##) {
a687059c LW	647	$prefix = $1;
a687059c LW	648	$delim = $2;
a687059c LW	649	if ($delim eq '\\') {
	650	s/(.)//;
	651	$ch = $1;
00bf170e	652	$delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
9f68db38 LW	653	$ch = 'b' if $ch =~ /^[<>]$/;
9f68db38 LW	654	$delim .= $ch;
a687059c LW	655	}
	656	elsif ($delim eq '[') {
	657	$inbracket = 1;
	658	s/^\^// && ($delim .= '^');
	659	s/^]// && ($delim .= ']');
a687059c LW	660	}
	661	elsif ($delim eq ']') {
	662	$inbracket = 0;
	663	}
	664	elsif ($inbracket \|\| $delim ne $outer) {
a687059c LW	665	$delim = '\\' . $delim;
	666	}
	667	$addr .= $prefix;
	668	$addr .= $delim;
	669	if ($delim eq $outer && !$inbracket) {
0a12ae7d	670	last DELIM;
a687059c LW	671	}
	672	}
	673	$addr;
	674	}
	675
	676	!NO!SUBS!
	677	chmod 755 s2p
	678	$eunicefix s2p