'')
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
- . config.sh
+ fi 2>/dev/null
+ . ./config.sh
;;
esac
echo "Extracting s2p (with variable substitutions)"
: In the following dollars and backticks do not need the extra backslash.
$spitshell >>s2p <<'!NO!SUBS!'
-# $Header: s2p.SH,v 3.0 89/10/18 15:35:02 lwall Locked $
+# $RCSfile: s2p.SH,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:18 $
#
# $Log: s2p.SH,v $
-# Revision 3.0 89/10/18 15:35:02 lwall
-# 3.0 baseline
+# Revision 4.0.1.1 91/06/07 12:19:18 lwall
+# patch4: s2p now handles embedded newlines better and optimizes common idioms
#
-# 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.
+# Revision 4.0 91/03/20 01:57:59 lwall
+# 4.0 baseline.
#
#
$indent = 4;
$shiftwidth = 4;
$l = '{'; $r = '}';
-$tempvar = '1';
-while ($ARGV[0] =~ '^-') {
+while ($ARGV[0] =~ /^-/) {
$_ = shift;
last if /^--/;
if (/^-D/) {
$debug++;
- open(body,'>-');
+ open(BODY,'>-');
next;
}
if (/^-n/) {
}
unless ($debug) {
- open(body,">/tmp/sperl$$") || do Die("Can't open temp file");
+ open(BODY,">/tmp/sperl$$") ||
+ &Die("Can't open temp file: $!\n");
}
if (!$assumen && !$assumep) {
- print body
-'while ($ARGV[0] =~ /^-/) {
- $_ = shift;
- last if /^--/;
- if (/^-n/) {
- $nflag++;
- next;
- }
- die "I don\'t recognize this switch: $_\\n";
+ print BODY &q(<<'EOT');
+: while ($ARGV[0] =~ /^-/) {
+: $_ = shift;
+: last if /^--/;
+: if (/^-n/) {
+: $nflag++;
+: next;
+: }
+: die "I don't recognize this switch: $_\\n";
+: }
+:
+EOT
}
-';
-}
+print BODY &q(<<'EOT');
+: #ifdef PRINTIT
+: #ifdef ASSUMEP
+: $printit++;
+: #else
+: $printit++ unless $nflag;
+: #endif
+: #endif
+: <><>
+: $\ = "\n"; # automatically add newline on print
+: <><>
+: #ifdef TOPLABEL
+: LINE:
+: while (chop($_ = <>)) {
+: #else
+: LINE:
+: while (<>) {
+: chop;
+: #endif
+EOT
+
+LINE:
+while (<>) {
+
+ # Wipe out surrounding whitespace.
-print body '
-#ifdef PRINTIT
-#ifdef ASSUMEP
-$printit++;
-#else
-$printit++ unless $nflag;
-#endif
-#endif
-line: while (<>) {
-';
-
-line: while (<>) {
s/[ \t]*(.*)\n$/$1/;
+
+ # Perhaps it's a label/comment.
+
if (/^:/) {
s/^:[ \t]*//;
- $label = do make_label($_);
+ $label = &make_label($_);
if ($. == 1) {
$toplabel = $label;
+ if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
+ $_ = <>;
+ redo LINE; # Never referenced, so delete it if not a comment.
+ }
}
$_ = "$label:";
- if ($lastlinewaslabel++) {$_ .= "\t;";}
+ if ($lastlinewaslabel++) {
+ $indent += 4;
+ print BODY &tab, ";\n";
+ $indent -= 4;
+ }
if ($indent >= 2) {
$indent -= 2;
$indmod = 2;
} else {
$lastlinewaslabel = '';
}
+
+ # Look for one or two address clauses
+
$addr1 = '';
$addr2 = '';
if (s/^([0-9]+)//) {
$addr1 = "$1";
+ $addr1 = "\$. == $addr1" unless /^,/;
}
elsif (s/^\$//) {
$addr1 = 'eof()';
}
elsif (s|^/||) {
- $addr1 = do fetchpat('/');
+ $addr1 = &fetchpat('/');
}
if (s/^,//) {
if (s/^([0-9]+)//) {
} elsif (s/^\$//) {
$addr2 = "eof()";
} elsif (s|^/||) {
- $addr2 = do fetchpat('/');
+ $addr2 = &fetchpat('/');
} else {
- do Die("Invalid second address at line $.\n");
+ &Die("Invalid second address at line $.\n");
}
$addr1 .= " .. $addr2";
}
- # a { to keep vi happy
+
+ # Now we check for metacommands {, }, and ! and worry
+ # about indentation.
+
s/^[ \t]+//;
+ # a { to keep vi happy
if ($_ eq '}') {
$indent -= 4;
next;
} else {
$space = '';
}
- $_ = do transmogrify();
+ $_ = &transmogrify();
}
+ # See if we can optimize to modifier form.
+
if ($addr1) {
if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
$_ !~ / if / && $_ !~ / unless /) {
s/;$/ $if $addr1;/;
$_ = substr($_,$shiftwidth,1000);
} else {
- $command = $_;
- $_ = "$if ($addr1) $l\n$change$command$rmaybe";
+ $_ = "$if ($addr1) $l\n$change$_$rmaybe";
}
$change = '';
- next line;
+ next LINE;
}
} continue {
@lines = split(/\n/,$_);
- while ($#lines >= 0) {
- $_ = shift(lines);
+ for (@lines) {
unless (s/^ *<<--//) {
- print body "\t" x ($indent / 8), ' ' x ($indent % 8);
+ print BODY &tab;
}
- print body $_, "\n";
+ print BODY $_, "\n";
}
$indent += $indmod;
$indmod = 0;
if ($redo) {
$_ = $redo;
$redo = '';
- redo line;
+ 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 '
-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
-}
-';
+ print BODY &q(<<'EOT');
+: #ifdef SAWNEXT
+: }
+: continue {
+: #endif
+: #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 = 0;
+: #endif
+: #ifdef APPENDSEEN
+: if ($atext) { chop $atext; print $atext; $atext = ''; }
+: #endif
+EOT
+
+print BODY &q(<<'EOT');
+: }
+EOT
}
-close body;
+close BODY;
unless ($debug) {
- open(head,">/tmp/sperl2$$.c") || do Die("Can't open temp file 2");
- 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$$") || do Die("Can't reopen temp file");
- while (<body>) {
- print head $_;
+ 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;
+ print HEAD "#define TOPLABEL\n" if $toplabel;
+ print HEAD "#define SAWNEXT\n" if $sawnext;
+ if ($opens) {print HEAD "$opens\n";}
+ open(BODY,"/tmp/sperl$$")
+ || &Die("Can't reopen temp file: $!\n");
+ while (<BODY>) {
+ print HEAD $_;
}
- close head;
-
- print "#!$bin/perl
-eval \"exec $bin/perl -S \$0 \$*\"
- if \$running_under_some_shell;
-
-";
- open(body,"cc -E /tmp/sperl2$$.c |") ||
- do Die("Can't reopen temp file");
- while (<body>) {
+ close HEAD;
+
+ print &q(<<"EOT");
+: #!$bin/perl
+: eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
+: 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/^<><>//;
}
}
-unlink "/tmp/sperl$$", "/tmp/sperl2$$";
+&Cleanup;
+exit;
+sub Cleanup {
+ chdir "/tmp";
+ unlink "sperl$$", "sperl2$$", "sperl2$$.c";
+}
sub Die {
- unlink "/tmp/sperl$$", "/tmp/sperl2$$";
+ &Cleanup;
die $_[0];
}
+sub tab {
+ "\t" x ($indent / 8) . ' ' x ($indent % 8);
+}
sub make_filehandle {
- $fname = $_ = $_[0];
- s/[^a-zA-Z]/_/g;
- s/^_*//;
- if (/^([a-z])([a-z]*)$/) {
- $first = $1;
- $rest = $2;
- $first =~ y/a-z/A-Z/;
- $_ = $first . $rest;
+ local($_) = $_[0];
+ local($fname) = $_;
+ if (!$seen{$fname}) {
+ $_ = "FH_" . $_ if /^\d/;
+ s/[^a-zA-Z0-9]/_/g;
+ s/^_*//;
+ $_ = "\U$_";
+ if ($fhseen{$_}) {
+ for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
+ $_ .= $tmp;
+ }
+ $fhseen{$_} = 1;
+ $opens .= &q(<<"EOT");
+: open($_, '>$fname') || die "Can't create $fname: \$!";
+EOT
+ $seen{$fname} = $_;
}
- if (!$seen{$_}) {
- $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n";
- }
- $seen{$_} = $_;
+ $seen{$fname};
}
sub make_label {
- $label = $_[0];
+ local($label) = @_;
$label =~ s/[^a-zA-Z0-9]/_/g;
if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
$label = substr($label,0,8);
- if ($label =~ /^([a-z])([a-z]*)$/) { # could be reserved word
- $first = $1;
- $rest = $2;
- $first =~ y/a-z/A-Z/; # so capitalize it
- $label = $first . $rest;
- }
+
+ # Could be a reserved word, so capitalize it.
+ substr($label,0,1) =~ y/a-z/A-Z/
+ if $label =~ /^[a-z]/;
+
$label;
}
{ # case
if (/^d/) {
$dseen++;
- $_ = '
-<<--#ifdef PRINTIT
-$printit = \'\';
-<<--#endif
-next line;';
+ chop($_ = &q(<<'EOT'));
+: <<--#ifdef PRINTIT
+: $printit = 0;
+: <<--#endif
+: next LINE;
+EOT
+ $sawnext++;
next;
}
if (/^n/) {
- $_ =
-'<<--#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';
+ chop($_ = &q(<<'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) {chop $atext; print $atext; $atext = '';}
+: <<--#endif
+: $_ = <>;
+: chop;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
+EOT
next;
}
if (/^a/) {
$appendseen++;
- $command = $space . '$atext .=' . "\n<<--'";
+ $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
$lastline = 0;
while (<>) {
s/^[ \t]*//;
s/^[\\]//;
unless (s|\\$||) { $lastline = 1;}
- s/'/\\'/g;
s/^([ \t]*\n)/<><>$1/;
$command .= $_;
$command .= '<<--';
last if $lastline;
}
- $_ = $command . "';";
+ $_ = $command . "End_Of_Text";
last;
}
if (/^[ic]/) {
if (/^c/) { $change = 1; }
+ $addr1 = 1 if $addr1 eq '';
$addr1 = '$iter = (' . $addr1 . ')';
- $command = $space . 'if ($iter == 1) { print' . "\n<<--'";
+ $command = $space .
+ " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
$lastline = 0;
while (<>) {
s/^[ \t]*//;
$command .= '<<--';
last if $lastline;
}
- $_ = $command . "';}";
+ $_ = $command . "End_Of_Text";
if ($change) {
$dseen++;
$change = "$_\n";
- $_ = "
-<<--#ifdef PRINTIT
-$space\$printit = '';
-<<--#endif
-${space}next line;";
+ chop($_ = &q(<<"EOT"));
+: <<--#ifdef PRINTIT
+: $space\$printit = 0;
+: <<--#endif
+: ${space}next LINE;
+EOT
+ $sawnext++;
}
last;
}
$c = substr($_,$i,1);
if ($c eq $delim) {
if ($inbracket) {
- $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
+ substr($_, $i, 0) = '\\';
$i++;
$len++;
}
$len = length($_);
$_ = substr($_,0,--$len);
}
- elsif (!$repl && substr($_,$i,1) =~ /^[(){}\w]$/) {
+ elsif (substr($_,$i,1) =~ /^[n]$/) {
+ ;
+ }
+ elsif (!$repl &&
+ substr($_,$i,1) =~ /^[(){}\w]$/) {
$i--;
$len--;
- $_ = substr($_,0,$i) . substr($_,$i+1,10000);
+ substr($_, $i, 1) = '';
+ }
+ elsif (!$repl &&
+ substr($_,$i,1) =~ /^[<>]$/) {
+ substr($_,$i,1) = 'b';
}
}
elsif ($c eq '[' && !$repl) {
elsif ($c eq ']') {
$inbracket = 0;
}
- elsif (!$repl && index("()",$c) >= 0) {
- $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
+ elsif ($c eq "\t") {
+ substr($_, $i, 1) = '\\t';
+ $i++;
+ $len++;
+ }
+ elsif (!$repl && index("()+",$c) >= 0) {
+ substr($_, $i, 0) = '\\';
$i++;
$len++;
}
}
- do Die("Malformed substitution at line $.\n") unless $end;
+ &Die("Malformed substitution at line $.\n")
+ unless $end;
$pat = substr($_, 0, $repl + 1);
- $repl = substr($_, $repl + 1, $end - $repl - 1);
+ $repl = substr($_, $repl+1, $end-$repl-1);
$end = substr($_, $end + 1, 1000);
+ &simplify($pat);
$dol = '$';
$repl =~ s/\$/\\$/;
$repl =~ s'&'$&'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/^g//) {
+ $subst .= 'g';
+ next;
+ }
+ if ($end =~ s/^p//) {
+ $cmd .= ' && (print)';
+ next;
+ }
if ($end =~ s/^w[ \t]*//) {
- $fh = do make_filehandle($end);
+ $fh = &make_filehandle($end);
$cmd .= " && (print $fh \$_)";
$end = '';
next;
}
- do Die("Unrecognized substitution command ($end) at line $.\n");
+ &Die("Unrecognized substitution command".
+ "($end) at line $.\n");
}
- $_ =
-"<<--#ifdef TSEEN
-$subst && \$tflag++$cmd;
-<<--#else
-$subst$cmd;
-<<--#endif";
+ chop ($_ = &q(<<"EOT"));
+: <<--#ifdef TSEEN
+: $subst && \$tflag++$cmd;
+: <<--#else
+: $subst$cmd;
+: <<--#endif
+EOT
next;
}
if (/^w/) {
s/^w[ \t]*//;
- $fh = do make_filehandle($_);
+ $fh = &make_filehandle($_);
$_ = "print $fh \$_;";
next;
}
}
if (/^P/) {
- $_ = 'print $1 if /(^.*\n)/;';
+ $_ = 'print $1 if /^(.*)/;';
next;
}
if (/^D/) {
- $_ =
-'s/^.*\n//;
-redo line if $_;
-next line;';
+ chop($_ = &q(<<'EOT'));
+: s/^.*\n?//;
+: redo LINE if $_;
+: next LINE;
+EOT
+ $sawnext++;
next;
}
if (/^N/) {
- $_ = '
-$_ .= <>;
-<<--#ifdef TSEEN
-$tflag = \'\';
-<<--#endif';
+ chop($_ = &q(<<'EOT'));
+: $_ .= "\n";
+: $len1 = length;
+: $_ .= <>;
+: chop if $len1 < length;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
+EOT
next;
}
}
if (/^H/) {
- $_ = '$hold .= $_ ? $_ : "\n";';
+ $_ = '$hold .= "\n"; $hold .= $_;';
next;
}
}
if (/^G/) {
- $_ = '$_ .= $hold ? $hold : "\n";';
+ $_ = '$_ .= "\n"; $_ .= $hold;';
next;
}
}
if (/^b$/) {
- $_ = 'next line;';
+ $_ = 'next LINE;';
+ $sawnext++;
next;
}
if (/^b/) {
s/^b[ \t]*//;
- $lab = do make_label($_);
+ $lab = &make_label($_);
if ($lab eq $toplabel) {
- $_ = 'redo line;';
+ $_ = 'redo LINE;';
} else {
$_ = "goto $lab;";
}
}
if (/^t$/) {
- $_ = 'next line if $tflag;';
+ $_ = 'next LINE if $tflag;';
+ $sawnext++;
$tseen++;
next;
}
if (/^t/) {
s/^t[ \t]*//;
- $lab = do make_label($_);
+ $lab = &make_label($_);
+ $_ = q/if ($tflag) {$tflag = 0; /;
if ($lab eq $toplabel) {
- $_ = 'if ($tflag) {$tflag = \'\'; redo line;}';
+ $_ .= 'redo LINE;}';
} else {
- $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}";
+ $_ .= "goto $lab;}";
}
$tseen++;
next;
}
+ if (/^y/) {
+ s/abcdefghijklmnopqrstuvwxyz/a-z/g;
+ s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
+ s/abcdef/a-f/g;
+ s/ABCDEF/A-F/g;
+ s/0123456789/0-9/g;
+ s/01234567/0-7/g;
+ $_ .= ';';
+ }
+
if (/^=/) {
- $_ = 'print "$.\n";';
+ $_ = 'print $.;';
next;
}
if (/^q/) {
- $_ =
-'close(ARGV);
-@ARGV = ();
-next line;';
+ chop($_ = &q(<<'EOT'));
+: close(ARGV);
+: @ARGV = ();
+: next LINE;
+EOT
+ $sawnext++;
next;
}
} continue {
local($inbracket);
local($prefix,$delim,$ch);
- delim: while (s:^([^\](|)[\\/]*)([](|)[\\/])::) {
+ # Process pattern one potential delimiter at a time.
+
+ DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
$prefix = $1;
$delim = $2;
- print "$prefix\t$delim\t$_\n";
if ($delim eq '\\') {
s/(.)//;
$ch = $1;
- $delim = '' if $ch =~ /^[(){}\w]$/;
- $delim .= $1;
+ $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
+ $ch = 'b' if $ch =~ /^[<>]$/;
+ $delim .= $ch;
}
elsif ($delim eq '[') {
$inbracket = 1;
s/^\^// && ($delim .= '^');
s/^]// && ($delim .= ']');
- print "$prefix\t$delim\t$_\n";
}
elsif ($delim eq ']') {
$inbracket = 0;
}
elsif ($inbracket || $delim ne $outer) {
- print "Adding\n";
$delim = '\\' . $delim;
}
$addr .= $prefix;
$addr .= $delim;
if ($delim eq $outer && !$inbracket) {
- last delim;
+ last DELIM;
}
}
+ $addr =~ s/\t/\\t/g;
+ &simplify($addr);
$addr;
}
+sub q {
+ local($string) = @_;
+ local($*) = 1;
+ $string =~ s/^:\t?//g;
+ $string;
+}
+
+sub simplify {
+ $_[0] =~ s/_a-za-z0-9/\\w/ig;
+ $_[0] =~ s/a-z_a-z0-9/\\w/ig;
+ $_[0] =~ s/a-za-z_0-9/\\w/ig;
+ $_[0] =~ s/a-za-z0-9_/\\w/ig;
+ $_[0] =~ s/_0-9a-za-z/\\w/ig;
+ $_[0] =~ s/0-9_a-za-z/\\w/ig;
+ $_[0] =~ s/0-9a-z_a-z/\\w/ig;
+ $_[0] =~ s/0-9a-za-z_/\\w/ig;
+ $_[0] =~ s/\[\\w\]/\\w/g;
+ $_[0] =~ s/\[^\\w\]/\\W/g;
+ $_[0] =~ s/\[0-9\]/\\d/g;
+ $_[0] =~ s/\[^0-9\]/\\D/g;
+ $_[0] =~ s/\\d\\d\*/\\d+/g;
+ $_[0] =~ s/\\D\\D\*/\\D+/g;
+ $_[0] =~ s/\\w\\w\*/\\w+/g;
+ $_[0] =~ s/\\t\\t\*/\\t+/g;
+ $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
+ $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
+}
+
!NO!SUBS!
chmod 755 s2p
$eunicefix s2p
projects / p5sagit/p5-mst-13.2.git / blobdiff