3 eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
4 if $running_under_some_shell;
6 $bin = '/usr/local/bin';
8 # $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
11 # Revision 4.1 92/08/07 18:29:23 lwall
13 # Revision 4.0.1.2 92/06/08 17:26:31 lwall
14 # patch20: s2p didn't output portable startup code
15 # patch20: added ... as variant on ..
16 # patch20: s2p didn't translate s/pat/\&/ or s/pat/\$/ or s/pat/\\1/ right
18 # Revision 4.0.1.1 91/06/07 12:19:18 lwall
19 # patch4: s2p now handles embedded newlines better and optimizes common idioms
21 # Revision 4.0 91/03/20 01:57:59 lwall
30 while ($ARGV[0] =~ /^-/) {
46 die "I don't recognize this switch: $_\n";
50 open(BODY,">/tmp/sperl$$") ||
51 &Die("Can't open temp file: $!\n");
54 if (!$assumen && !$assumep) {
55 print BODY &q(<<'EOT');
56 : while ($ARGV[0] =~ /^-/) {
63 : die "I don't recognize this switch: $_\\n";
69 print BODY &q(<<'EOT');
74 : $printit++ unless $nflag;
78 : $\ = "\n"; # automatically add newline on print
82 : while (chop($_ = <>)) {
93 # Wipe out surrounding whitespace.
97 # Perhaps it's a label/comment.
101 $label = &make_label($_);
104 if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
106 redo LINE; # Never referenced, so delete it if not a comment.
110 if ($lastlinewaslabel++) {
112 print BODY &tab, ";\n";
121 $lastlinewaslabel = '';
124 # Look for one or two address clauses
130 $addr1 = "\$. == $addr1" unless /^,/;
136 $addr1 = &fetchpat('/');
144 $addr2 = &fetchpat('/');
146 &Die("Invalid second address at line $.\n");
148 if ($addr2 =~ /^\d+$/) {
149 $addr1 .= "..$addr2";
152 $addr1 .= "...$addr2";
156 # Now we check for metacommands {, }, and ! and worry
160 # a { to keep vi happy
167 $else = "$r else $l\n";
172 if (s/^{//) { # a } to keep vi happy
179 if ($addr2 || $addr1) {
180 $space = ' ' x $shiftwidth;
184 $_ = &transmogrify();
187 # See if we can optimize to modifier form.
190 if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
191 $_ !~ / if / && $_ !~ / unless /) {
193 $_ = substr($_,$shiftwidth,1000);
195 $_ = "$if ($addr1) $l\n$change$_$rmaybe";
201 @lines = split(/\n/,$_);
203 unless (s/^ *<<--//) {
216 if ($lastlinewaslabel++) {
218 print BODY &tab, ";\n";
222 if ($appendseen || $tseen || !$assumen) {
223 $printit++ if $dseen || (!$assumen && !$assumep);
224 print BODY &q(<<'EOT');
232 : print if $printit++;
237 : { $printit++ unless $nflag; }
249 : if ($atext) { chop $atext; print $atext; $atext = ''; }
253 print BODY &q(<<'EOT');
261 open(HEAD,">/tmp/sperl2$$.c")
262 || &Die("Can't open temp file 2: $!\n");
263 print HEAD "#define PRINTIT\n" if $printit;
264 print HEAD "#define APPENDSEEN\n" if $appendseen;
265 print HEAD "#define TSEEN\n" if $tseen;
266 print HEAD "#define DSEEN\n" if $dseen;
267 print HEAD "#define ASSUMEN\n" if $assumen;
268 print HEAD "#define ASSUMEP\n" if $assumep;
269 print HEAD "#define TOPLABEL\n" if $toplabel;
270 print HEAD "#define SAWNEXT\n" if $sawnext;
271 if ($opens) {print HEAD "$opens\n";}
272 open(BODY,"/tmp/sperl$$")
273 || &Die("Can't reopen temp file: $!\n");
281 : eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
282 : if \$running_under_some_shell;
285 open(BODY,"cc -E /tmp/sperl2$$.c |") ||
286 &Die("Can't reopen temp file: $!\n");
300 unlink "sperl$$", "sperl2$$", "sperl2$$.c";
307 "\t" x ($indent / 8) . ' ' x ($indent % 8);
309 sub make_filehandle {
312 if (!$seen{$fname}) {
313 $_ = "FH_" . $_ if /^\d/;
318 for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
322 $opens .= &q(<<"EOT");
323 : open($_, '>$fname') || die "Can't create $fname: \$!";
332 $label =~ s/[^a-zA-Z0-9]/_/g;
333 if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
334 $label = substr($label,0,8);
336 # Could be a reserved word, so capitalize it.
337 substr($label,0,1) =~ y/a-z/A-Z/
338 if $label =~ /^[a-z]/;
347 chop($_ = &q(<<'EOT'));
358 chop($_ = &q(<<'EOT'));
362 : print if $printit++;
367 : { $printit++ unless $nflag; }
375 : <<--#ifdef APPENDSEEN
376 : if ($atext) {chop $atext; print $atext; $atext = '';}
389 $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
394 unless (s|\\$||) { $lastline = 1;}
395 s/^([ \t]*\n)/<><>$1/;
400 $_ = $command . "End_Of_Text";
405 if (/^c/) { $change = 1; }
406 $addr1 = 1 if $addr1 eq '';
407 $addr1 = '$iter = (' . $addr1 . ')';
409 " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
414 unless (s/\\$//) { $lastline = 1;}
416 s/^([ \t]*\n)/<><>$1/;
421 $_ = $command . "End_Of_Text";
425 chop($_ = &q(<<"EOT"));
427 : $space\$printit = 0;
437 $delim = substr($_,1,1);
441 for ($i = 2; $i < $len; $i++) {
442 $c = substr($_,$i,1);
445 substr($_, $i, 0) = '\\';
464 $_ = substr($_,0,--$len);
466 elsif (substr($_,$i,1) =~ /^[n]$/) {
470 substr($_,$i,1) =~ /^[(){}\w]$/) {
473 substr($_, $i, 1) = '';
476 substr($_,$i,1) =~ /^[<>]$/) {
477 substr($_,$i,1) = 'b';
479 elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
480 substr($_,$i-1,1) = '$';
483 elsif ($c eq '&' && $repl) {
484 substr($_, $i, 0) = '$';
488 elsif ($c eq '$' && $repl) {
489 substr($_, $i, 0) = '\\';
493 elsif ($c eq '[' && !$repl) {
494 $i++ if substr($_,$i,1) eq '^';
495 $i++ if substr($_,$i,1) eq ']';
502 substr($_, $i, 1) = '\\t';
506 elsif (!$repl && index("()+",$c) >= 0) {
507 substr($_, $i, 0) = '\\';
512 &Die("Malformed substitution at line $.\n")
514 $pat = substr($_, 0, $repl + 1);
515 $repl = substr($_, $repl+1, $end-$repl-1);
516 $end = substr($_, $end + 1, 1000);
519 $subst = "$pat$repl$delim";
522 if ($end =~ s/^g//) {
526 if ($end =~ s/^p//) {
527 $cmd .= ' && (print)';
530 if ($end =~ s/^w[ \t]*//) {
531 $fh = &make_filehandle($end);
532 $cmd .= " && (print $fh \$_)";
536 &Die("Unrecognized substitution command".
537 "($end) at line $.\n");
539 chop ($_ = &q(<<"EOT"));
541 : $subst && \$tflag++$cmd;
556 $fh = &make_filehandle($_);
557 $_ = "print $fh \$_;";
565 $_ = "\$atext .= `cat $file 2>/dev/null`;";
570 $_ = 'print $1 if /^(.*)/;';
575 chop($_ = &q(<<'EOT'));
585 chop($_ = &q(<<'EOT'));
589 : chop if $len1 < length;
603 $_ = '$hold .= "\n"; $hold .= $_;';
613 $_ = '$_ .= "\n"; $_ .= $hold;';
618 $_ = '($_, $hold) = ($hold, $_);';
630 $lab = &make_label($_);
631 if ($lab eq $toplabel) {
640 $_ = 'next LINE if $tflag;';
648 $lab = &make_label($_);
649 $_ = q/if ($tflag) {$tflag = 0; /;
650 if ($lab eq $toplabel) {
660 s/abcdefghijklmnopqrstuvwxyz/a-z/g;
661 s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
675 chop($_ = &q(<<'EOT'));
686 s/(\n)(.)/$1$space$2/g;
695 local($addr) = $outer;
697 local($prefix,$delim,$ch);
699 # Process pattern one potential delimiter at a time.
701 DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
704 if ($delim eq '\\') {
707 $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
708 $ch = 'b' if $ch =~ /^[<>]$/;
711 elsif ($delim eq '[') {
713 s/^\^// && ($delim .= '^');
714 s/^]// && ($delim .= ']');
716 elsif ($delim eq ']') {
719 elsif ($inbracket || $delim ne $outer) {
720 $delim = '\\' . $delim;
724 if ($delim eq $outer && !$inbracket) {
736 $string =~ s/^:\t?//g;
741 $_[0] =~ s/_a-za-z0-9/\\w/ig;
742 $_[0] =~ s/a-z_a-z0-9/\\w/ig;
743 $_[0] =~ s/a-za-z_0-9/\\w/ig;
744 $_[0] =~ s/a-za-z0-9_/\\w/ig;
745 $_[0] =~ s/_0-9a-za-z/\\w/ig;
746 $_[0] =~ s/0-9_a-za-z/\\w/ig;
747 $_[0] =~ s/0-9a-z_a-z/\\w/ig;
748 $_[0] =~ s/0-9a-za-z_/\\w/ig;
749 $_[0] =~ s/\[\\w\]/\\w/g;
750 $_[0] =~ s/\[^\\w\]/\\W/g;
751 $_[0] =~ s/\[0-9\]/\\d/g;
752 $_[0] =~ s/\[^0-9\]/\\D/g;
753 $_[0] =~ s/\\d\\d\*/\\d+/g;
754 $_[0] =~ s/\\D\\D\*/\\D+/g;
755 $_[0] =~ s/\\w\\w\*/\\w+/g;
756 $_[0] =~ s/\\t\\t\*/\\t+/g;
757 $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
758 $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;