diff options
Diffstat (limited to 'gnu/usr.bin/perl/x2p/s2p')
-rwxr-xr-x | gnu/usr.bin/perl/x2p/s2p | 766 |
1 files changed, 766 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/x2p/s2p b/gnu/usr.bin/perl/x2p/s2p new file mode 100755 index 0000000..8a8a74c --- /dev/null +++ b/gnu/usr.bin/perl/x2p/s2p @@ -0,0 +1,766 @@ +#!/usr/gnu/bin/perl + +eval 'exec /usr/gnu/bin/perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +$bin = '/usr/gnu/bin'; + +# $RCSfile: s2p,v $$Revision: 1.2 $$Date: 1994/03/05 01:28:48 $ +# +# $Log: s2p,v $ +# Revision 1.2 1994/03/05 01:28:48 ache +# 1) Perl uses scrambler crypt() version from libc instead of proper one +# from -lcrypt (if exist) +# 2) We have now all sem/shm/msg stuff, add it to perl too +# +# Revision 1.1.1.1 1993/08/23 21:30:10 nate +# PERL! +# +# 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; +} + |