summaryrefslogtreecommitdiff
path: root/x2p/s2p
diff options
context:
space:
mode:
Diffstat (limited to 'x2p/s2p')
-rwxr-xr-xx2p/s2p760
1 files changed, 760 insertions, 0 deletions
diff --git a/x2p/s2p b/x2p/s2p
new file mode 100755
index 0000000000..fa6e01791d
--- /dev/null
+++ b/x2p/s2p
@@ -0,0 +1,760 @@
+#!/usr/local/bin/perl
+
+eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+$bin = '/usr/local/bin';
+
+# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
+#
+# $Log: s2p.SH,v $
+# Revision 4.1 92/08/07 18:29:23 lwall
+#
+# Revision 4.0.1.2 92/06/08 17:26:31 lwall
+# patch20: s2p didn't output portable startup code
+# patch20: added ... as variant on ..
+# patch20: s2p didn't translate s/pat/\&/ or s/pat/\$/ or s/pat/\\1/ right
+#
+# Revision 4.0.1.1 91/06/07 12:19:18 lwall
+# patch4: s2p now handles embedded newlines better and optimizes common idioms
+#
+# 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 &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.
+
+ s/[ \t]*(.*)\n$/$1/;
+
+ # Perhaps it's a label/comment.
+
+ if (/^:/) {
+ s/^:[ \t]*//;
+ $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++) {
+ $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";
+ $addr1 = "\$. == $addr1" unless /^,/;
+ }
+ 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");
+ }
+ if ($addr2 =~ /^\d+$/) {
+ $addr1 .= "..$addr2";
+ }
+ else {
+ $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;
+}
+
+if ($appendseen || $tseen || !$assumen) {
+ $printit++ if $dseen || (!$assumen && !$assumep);
+ 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;
+
+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;
+ 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 &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/^<><>//;
+ 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) = $_;
+ 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} = $_;
+ }
+ $seen{$fname};
+}
+
+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($_ = &q(<<'EOT'));
+: <<--#ifdef PRINTIT
+: $printit = 0;
+: <<--#endif
+: next LINE;
+EOT
+ $sawnext++;
+ next;
+ }
+
+ if (/^n/) {
+ 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 .= <<'End_Of_Text';\n<<--";
+ $lastline = 0;
+ while (<>) {
+ s/^[ \t]*//;
+ s/^[\\]//;
+ unless (s|\\$||) { $lastline = 1;}
+ s/^([ \t]*\n)/<><>$1/;
+ $command .= $_;
+ $command .= '<<--';
+ last if $lastline;
+ }
+ $_ = $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 <<'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 . "End_Of_Text";
+ if ($change) {
+ $dseen++;
+ $change = "$_\n";
+ chop($_ = &q(<<"EOT"));
+: <<--#ifdef PRINTIT
+: $space\$printit = 0;
+: <<--#endif
+: ${space}next LINE;
+EOT
+ $sawnext++;
+ }
+ 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 ($repl && substr($_,$i,1) =~ /^\d$/) {
+ substr($_,$i-1,1) = '$';
+ }
+ }
+ elsif ($c eq '&' && $repl) {
+ substr($_, $i, 0) = '$';
+ $i++;
+ $len++;
+ }
+ elsif ($c eq '$' && $repl) {
+ substr($_, $i, 0) = '\\';
+ $i++;
+ $len++;
+ }
+ elsif ($c eq '[' && !$repl) {
+ $i++ if substr($_,$i,1) eq '^';
+ $i++ if substr($_,$i,1) eq ']';
+ $inbracket = 1;
+ }
+ elsif ($c eq ']') {
+ $inbracket = 0;
+ }
+ elsif ($c eq "\t") {
+ substr($_, $i, 1) = '\\t';
+ $i++;
+ $len++;
+ }
+ 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);
+ &simplify($pat);
+ $dol = '$';
+ $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 ($_ = &q(<<"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 /^(.*)/;';
+ next;
+ }
+
+ if (/^D/) {
+ chop($_ = &q(<<'EOT'));
+: s/^.*\n?//;
+: redo LINE if $_;
+: next LINE;
+EOT
+ $sawnext++;
+ next;
+ }
+
+ if (/^N/) {
+ chop($_ = &q(<<'EOT'));
+: $_ .= "\n";
+: $len1 = length;
+: $_ .= <>;
+: chop if $len1 < length;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
+EOT
+ next;
+ }
+
+ if (/^h/) {
+ $_ = '$hold = $_;';
+ next;
+ }
+
+ if (/^H/) {
+ $_ = '$hold .= "\n"; $hold .= $_;';
+ next;
+ }
+
+ if (/^g/) {
+ $_ = '$_ = $hold;';
+ next;
+ }
+
+ if (/^G/) {
+ $_ = '$_ .= "\n"; $_ .= $hold;';
+ next;
+ }
+
+ if (/^x/) {
+ $_ = '($_, $hold) = ($hold, $_);';
+ next;
+ }
+
+ if (/^b$/) {
+ $_ = 'next LINE;';
+ $sawnext++;
+ 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;';
+ $sawnext++;
+ $tseen++;
+ next;
+ }
+
+ if (/^t/) {
+ s/^t[ \t]*//;
+ $lab = &make_label($_);
+ $_ = q/if ($tflag) {$tflag = 0; /;
+ if ($lab eq $toplabel) {
+ $_ .= 'redo LINE;}';
+ } else {
+ $_ .= "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 $.;';
+ next;
+ }
+
+ if (/^q/) {
+ chop($_ = &q(<<'EOT'));
+: close(ARGV);
+: @ARGV = ();
+: next LINE;
+EOT
+ $sawnext++;
+ 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 =~ 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;
+}
+
View Lorry Controller Status