[p5sagit/p5-mst-13.2.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 ../../config.sh . || \
	ln ../../../config.sh . || \
	(echo "Can't find config.sh."; exit 1)
    fi
    . ./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 3.0.1.6 90/10/20 02:21:43 lwall Locked $
#
# $Log:	s2p.SH,v $
# Revision 3.0.1.6  90/10/20  02:21:43  lwall
# patch37: changed some ". config.sh" to ". ./config.sh"
# 
# Revision 3.0.1.5  90/10/16  11:32:40  lwall
# patch29: s2p modernized
# 
# Revision 3.0.1.4  90/08/09  05:50:43  lwall
# patch19: s2p didn't translate \n right
# 
# Revision 3.0.1.3  90/03/01  10:31:21  lwall
# patch9: s2p didn't handle \< and \>
# 
# Revision 3.0.1.2  89/11/17  15:51:27  lwall
# patch5: in s2p, line labels without a subsequent statement were done wrong
# patch5: s2p left residue in /tmp
# 
# Revision 3.0.1.1  89/11/11  05:08:25  lwall
# patch2: in s2p, + within patterns needed backslashing
# patch2: s2p was printing out some debugging info to the output file
# 
# Revision 3.0  89/10/18  15:35:02  lwall
# 3.0 baseline
# 
# Revision 2.0.1.1  88/07/11  23:26:23  root
# patch2: s2p didn't put a proper prologue on output script
# 
# Revision 2.0  88/06/05  00:15:55  root
# Baseline version 2.0.
# 
#

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