home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BURKS 2
/
BURKS_AUG97.ISO
/
SLAKWARE
/
D12
/
PERL1.TGZ
/
perl1.tar
/
usr
/
bin
/
s2p
< prev
next >
Wrap
Text File
|
1996-06-28
|
13KB
|
745 lines
#!/usr/bin/perl
eval 'exec perl -S $0 "$@"'
if 0;
$startperl = "#!/usr/bin/perl";
# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
#
# $Log: s2p.SH,v $
$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");
: $startperl
: eval 'exec 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 &&