os2/s2p.cmd

   1 extproc perl -Sx
   2 #!perl
   3
   4 $bin = 'c:/bin';
   5
   6 # $Header: s2p.cmd,v 4.0 91/03/20 01:37:09 lwall Locked $
   7 #
   8 # $Log: s2p.cmd,v $
   9 # Revision 4.0  91/03/20  01:37:09  lwall
  10 # 4.0 baseline.
  11 #
  12 # Revision 3.0.1.6  90/10/20  02:21:43  lwall
  13 # patch37: changed some ". config.sh" to ". ./config.sh"
  14 #
  15 # Revision 3.0.1.5  90/10/16  11:32:40  lwall
  16 # patch29: s2p modernized
  17 #
  18 # Revision 3.0.1.4  90/08/09  05:50:43  lwall
  19 # patch19: s2p didn't translate \n right
  20 #
  21 # Revision 3.0.1.3  90/03/01  10:31:21  lwall
  22 # patch9: s2p didn't handle \< and \>
  23 #
  24 # Revision 3.0.1.2  89/11/17  15:51:27  lwall
  25 # patch5: in s2p, line labels without a subsequent statement were done wrong
  26 # patch5: s2p left residue in /tmp
  27 #
  28 # Revision 3.0.1.1  89/11/11  05:08:25  lwall
  29 # patch2: in s2p, + within patterns needed backslashing
  30 # patch2: s2p was printing out some debugging info to the output file
  31 #
  32 # Revision 3.0  89/10/18  15:35:02  lwall
  33 # 3.0 baseline
  34 #
  35 # Revision 2.0.1.1  88/07/11  23:26:23  root
  36 # patch2: s2p didn't put a proper prologue on output script
  37 #
  38 # Revision 2.0  88/06/05  00:15:55  root
  39 # Baseline version 2.0.
  40 #
  41 #
  42
  43 $indent = 4;
  44 $shiftwidth = 4;
  45 $l = '{'; $r = '}';
  46
  47 while ($ARGV[0] =~ /^-/) {
  48     $_ = shift;
  49   last if /^--/;
  50     if (/^-D/) {
  51         $debug++;
  52         open(BODY,'>-');
  53         next;
  54     }
  55     if (/^-n/) {
  56         $assumen++;
  57         next;
  58     }
  59     if (/^-p/) {
  60         $assumep++;
  61         next;
  62     }
  63     die "I don't recognize this switch: $_\n";
  64 }
  65
  66 unless ($debug) {
  67     open(BODY,">sperl$$") ||
  68       &Die("Can't open temp file: $!\n");
  69 }
  70
  71 if (!$assumen && !$assumep) {
  72     print BODY <<'EOT';
  73 while ($ARGV[0] =~ /^-/) {
  74     $_ = shift;
  75   last if /^--/;
  76     if (/^-n/) {
  77         $nflag++;
  78         next;
  79     }
  80     die "I don't recognize this switch: $_\\n";
  81 }
  82
  83 EOT
  84 }
  85
  86 print BODY <<'EOT';
  87
  88 #ifdef PRINTIT
  89 #ifdef ASSUMEP
  90 $printit++;
  91 #else
  92 $printit++ unless $nflag;
  93 #endif
  94 #endif
  95 LINE: while (<>) {
  96 EOT
  97
  98 LINE: while (<>) {
  99
 100     # Wipe out surrounding whitespace.
 101
 102     s/[ \t]*(.*)\n$/$1/;
 103
 104     # Perhaps it's a label/comment.
 105
 106     if (/^:/) {
 107         s/^:[ \t]*//;
 108         $label = &make_label($_);
 109         if ($. == 1) {
 110             $toplabel = $label;
 111         }
 112         $_ = "$label:";
 113         if ($lastlinewaslabel++) {
 114             $indent += 4;
 115             print BODY &tab, ";\n";
 116             $indent -= 4;
 117         }
 118         if ($indent >= 2) {
 119             $indent -= 2;
 120             $indmod = 2;
 121         }
 122         next;
 123     } else {
 124         $lastlinewaslabel = '';
 125     }
 126
 127     # Look for one or two address clauses
 128
 129     $addr1 = '';
 130     $addr2 = '';
 131     if (s/^([0-9]+)//) {
 132         $addr1 = "$1";
 133     }
 134     elsif (s/^\$//) {
 135         $addr1 = 'eof()';
 136     }
 137     elsif (s|^/||) {
 138         $addr1 = &fetchpat('/');
 139     }
 140     if (s/^,//) {
 141         if (s/^([0-9]+)//) {
 142             $addr2 = "$1";
 143         } elsif (s/^\$//) {
 144             $addr2 = "eof()";
 145         } elsif (s|^/||) {
 146             $addr2 = &fetchpat('/');
 147         } else {
 148             &Die("Invalid second address at line $.\n");
 149         }
 150         $addr1 .= " .. $addr2";
 151     }
 152
 153     # Now we check for metacommands {, }, and ! and worry
 154     # about indentation.
 155
 156     s/^[ \t]+//;
 157     # a { to keep vi happy
 158     if ($_ eq '}') {
 159         $indent -= 4;
 160         next;
 161     }
 162     if (s/^!//) {
 163         $if = 'unless';
 164         $else = "$r else $l\n";
 165     } else {
 166         $if = 'if';
 167         $else = '';
 168     }
 169     if (s/^{//) {       # a } to keep vi happy
 170         $indmod = 4;
 171         $redo = $_;
 172         $_ = '';
 173         $rmaybe = '';
 174     } else {
 175         $rmaybe = "\n$r";
 176         if ($addr2 || $addr1) {
 177             $space = ' ' x $shiftwidth;
 178         } else {
 179             $space = '';
 180         }
 181         $_ = &transmogrify();
 182     }
 183
 184     # See if we can optimize to modifier form.
 185
 186     if ($addr1) {
 187         if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
 188           $_ !~ / if / && $_ !~ / unless /) {
 189             s/;$/ $if $addr1;/;
 190             $_ = substr($_,$shiftwidth,1000);
 191         } else {
 192             $_ = "$if ($addr1) $l\n$change$_$rmaybe";
 193         }
 194         $change = '';
 195         next LINE;
 196     }
 197 } continue {
 198     @lines = split(/\n/,$_);
 199     for (@lines) {
 200         unless (s/^ *<<--//) {
 201             print BODY &tab;
 202         }
 203         print BODY $_, "\n";
 204     }
 205     $indent += $indmod;
 206     $indmod = 0;
 207     if ($redo) {
 208         $_ = $redo;
 209         $redo = '';
 210         redo LINE;
 211     }
 212 }
 213 if ($lastlinewaslabel++) {
 214     $indent += 4;
 215     print BODY &tab, ";\n";
 216     $indent -= 4;
 217 }
 218
 219 print BODY "}\n";
 220 if ($appendseen || $tseen || !$assumen) {
 221     $printit++ if $dseen || (!$assumen && !$assumep);
 222     print BODY <<'EOT';
 223
 224 continue {
 225 #ifdef PRINTIT
 226 #ifdef DSEEN
 227 #ifdef ASSUMEP
 228     print if $printit++;
 229 #else
 230     if ($printit)
 231         { print; }
 232     else
 233         { $printit++ unless $nflag; }
 234 #endif
 235 #else
 236     print if $printit;
 237 #endif
 238 #else
 239     print;
 240 #endif
 241 #ifdef TSEEN
 242     $tflag = '';
 243 #endif
 244 #ifdef APPENDSEEN
 245     if ($atext) { print $atext; $atext = ''; }
 246 #endif
 247 }
 248 EOT
 249 }
 250
 251 close BODY;
 252
 253 unless ($debug) {
 254     open(HEAD,">sperl2$$.c")
 255       || &Die("Can't open temp file 2: $!\n");
 256     print HEAD "#define PRINTIT\n" if ($printit);
 257     print HEAD "#define APPENDSEEN\n" if ($appendseen);
 258     print HEAD "#define TSEEN\n" if ($tseen);
 259     print HEAD "#define DSEEN\n" if ($dseen);
 260     print HEAD "#define ASSUMEN\n" if ($assumen);
 261     print HEAD "#define ASSUMEP\n" if ($assumep);
 262     if ($opens) {print HEAD "$opens\n";}
 263     open(BODY,"sperl$$")
 264       || &Die("Can't reopen temp file: $!\n");
 265     while (<BODY>) {
 266         print HEAD $_;
 267     }
 268     close HEAD;
 269
 270     print <<"EOT";
 271 #!$bin/perl
 272 eval 'exec $bin/perl -S \$0 \$*'
 273         if \$running_under_some_shell;
 274
 275 EOT
 276     open(BODY,"cc -E sperl2$$.c |") ||
 277         &Die("Can't reopen temp file: $!\n");
 278     while (<BODY>) {
 279         /^# [0-9]/ && next;
 280         /^[ \t]*$/ && next;
 281         s/^<><>//;
 282         print;
 283     }
 284 }
 285
 286 &Cleanup;
 287 exit;
 288
 289 sub Cleanup {
 290     unlink "sperl$$", "sperl2$$", "sperl2$$.c";
 291 }
 292 sub Die {
 293     &Cleanup;
 294     die $_[0];
 295 }
 296 sub tab {
 297     "\t" x ($indent / 8) . ' ' x ($indent % 8);
 298 }
 299 sub make_filehandle {
 300     local($_) = $_[0];
 301     local($fname) = $_;
 302     s/[^a-zA-Z]/_/g;
 303     s/^_*//;
 304     substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
 305     if (!$seen{$_}) {
 306         $opens .= <<"EOT";
 307 open($_,'>$fname') || die "Can't create $fname";
 308 EOT
 309     }
 310     $seen{$_} = $_;
 311 }
 312
 313 sub make_label {
 314     local($label) = @_;
 315     $label =~ s/[^a-zA-Z0-9]/_/g;
 316     if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
 317     $label = substr($label,0,8);
 318
 319     # Could be a reserved word, so capitalize it.
 320     substr($label,0,1) =~ y/a-z/A-Z/
 321       if $label =~ /^[a-z]/;
 322
 323     $label;
 324 }
 325
 326 sub transmogrify {
 327     {   # case
 328         if (/^d/) {
 329             $dseen++;
 330             chop($_ = <<'EOT');
 331 <<--#ifdef PRINTIT
 332 $printit = '';
 333 <<--#endif
 334 next LINE;
 335 EOT
 336             next;
 337         }
 338
 339         if (/^n/) {
 340             chop($_ = <<'EOT');
 341 <<--#ifdef PRINTIT
 342 <<--#ifdef DSEEN
 343 <<--#ifdef ASSUMEP
 344 print if $printit++;
 345 <<--#else
 346 if ($printit)
 347     { print; }
 348 else
 349     { $printit++ unless $nflag; }
 350 <<--#endif
 351 <<--#else
 352 print if $printit;
 353 <<--#endif
 354 <<--#else
 355 print;
 356 <<--#endif
 357 <<--#ifdef APPENDSEEN
 358 if ($atext) {print $atext; $atext = '';}
 359 <<--#endif
 360 $_ = <>;
 361 <<--#ifdef TSEEN
 362 $tflag = '';
 363 <<--#endif
 364 EOT
 365             next;
 366         }
 367
 368         if (/^a/) {
 369             $appendseen++;
 370             $command = $space . '$atext .=' . "\n<<--'";
 371             $lastline = 0;
 372             while (<>) {
 373                 s/^[ \t]*//;
 374                 s/^[\\]//;
 375                 unless (s|\\$||) { $lastline = 1;}
 376                 s/'/\\'/g;
 377                 s/^([ \t]*\n)/<><>$1/;
 378                 $command .= $_;
 379                 $command .= '<<--';
 380                 last if $lastline;
 381             }
 382             $_ = $command . "';";
 383             last;
 384         }
 385
 386         if (/^[ic]/) {
 387             if (/^c/) { $change = 1; }
 388             $addr1 = '$iter = (' . $addr1 . ')';
 389             $command = $space . 'if ($iter == 1) { print'
 390               . "\n<<--'";
 391             $lastline = 0;
 392             while (<>) {
 393                 s/^[ \t]*//;
 394                 s/^[\\]//;
 395                 unless (s/\\$//) { $lastline = 1;}
 396                 s/'/\\'/g;
 397                 s/^([ \t]*\n)/<><>$1/;
 398                 $command .= $_;
 399                 $command .= '<<--';
 400                 last if $lastline;
 401             }
 402             $_ = $command . "';}";
 403             if ($change) {
 404                 $dseen++;
 405                 $change = "$_\n";
 406                 chop($_ = <<"EOT");
 407 <<--#ifdef PRINTIT
 408 $space\$printit = '';
 409 <<--#endif
 410 ${space}next LINE;
 411 EOT
 412             }
 413             last;
 414         }
 415
 416         if (/^s/) {
 417             $delim = substr($_,1,1);
 418             $len = length($_);
 419             $repl = $end = 0;
 420             $inbracket = 0;
 421             for ($i = 2; $i < $len; $i++) {
 422                 $c = substr($_,$i,1);
 423                 if ($c eq $delim) {
 424                     if ($inbracket) {
 425                         substr($_, $i, 0) = '\\';
 426                         $i++;
 427                         $len++;
 428                     }
 429                     else {
 430                         if ($repl) {
 431                             $end = $i;
 432                             last;
 433                         } else {
 434                             $repl = $i;
 435                         }
 436                     }
 437                 }
 438                 elsif ($c eq '\\') {
 439                     $i++;
 440                     if ($i >= $len) {
 441                         $_ .= 'n';
 442                         $_ .= <>;
 443                         $len = length($_);
 444                         $_ = substr($_,0,--$len);
 445                     }
 446                     elsif (substr($_,$i,1) =~ /^[n]$/) {
 447                         ;
 448                     }
 449                     elsif (!$repl &&
 450                       substr($_,$i,1) =~ /^[(){}\w]$/) {
 451                         $i--;
 452                         $len--;
 453                         substr($_, $i, 1) = '';
 454                     }
 455                     elsif (!$repl &&
 456                       substr($_,$i,1) =~ /^[<>]$/) {
 457                         substr($_,$i,1) = 'b';
 458                     }
 459                 }
 460                 elsif ($c eq '[' && !$repl) {
 461                     $i++ if substr($_,$i,1) eq '^';
 462                     $i++ if substr($_,$i,1) eq ']';
 463                     $inbracket = 1;
 464                 }
 465                 elsif ($c eq ']') {
 466                     $inbracket = 0;
 467                 }
 468                 elsif (!$repl && index("()+",$c) >= 0) {
 469                     substr($_, $i, 0) = '\\';
 470                     $i++;
 471                     $len++;
 472                 }
 473             }
 474             &Die("Malformed substitution at line $.\n")
 475               unless $end;
 476             $pat = substr($_, 0, $repl + 1);
 477             $repl = substr($_, $repl+1, $end-$repl-1);
 478             $end = substr($_, $end + 1, 1000);
 479             $dol = '$';
 480             $repl =~ s/\$/\\$/;
 481             $repl =~ s'&'$&'g;
 482             $repl =~ s/[\\]([0-9])/$dol$1/g;
 483             $subst = "$pat$repl$delim";
 484             $cmd = '';
 485             while ($end) {
 486                 if ($end =~ s/^g//) {
 487                     $subst .= 'g';
 488                     next;
 489                 }
 490                 if ($end =~ s/^p//) {
 491                     $cmd .= ' && (print)';
 492                     next;
 493                 }
 494                 if ($end =~ s/^w[ \t]*//) {
 495                     $fh = &make_filehandle($end);
 496                     $cmd .= " && (print $fh \$_)";
 497                     $end = '';
 498                     next;
 499                 }
 500                 &Die("Unrecognized substitution command".
 501                   "($end) at line $.\n");
 502             }
 503             chop ($_ = <<"EOT");
 504 <<--#ifdef TSEEN
 505 $subst && \$tflag++$cmd;
 506 <<--#else
 507 $subst$cmd;
 508 <<--#endif
 509 EOT
 510             next;
 511         }
 512
 513         if (/^p/) {
 514             $_ = 'print;';
 515             next;
 516         }
 517
 518         if (/^w/) {
 519             s/^w[ \t]*//;
 520             $fh = &make_filehandle($_);
 521             $_ = "print $fh \$_;";
 522             next;
 523         }
 524
 525         if (/^r/) {
 526             $appendseen++;
 527             s/^r[ \t]*//;
 528             $file = $_;
 529             $_ = "\$atext .= `cat $file 2>/dev/null`;";
 530             next;
 531         }
 532
 533         if (/^P/) {
 534             $_ = 'print $1 if /(^.*\n)/;';
 535             next;
 536         }
 537
 538         if (/^D/) {
 539             chop($_ = <<'EOT');
 540 s/^.*\n//;
 541 redo LINE if $_;
 542 next LINE;
 543 EOT
 544             next;
 545         }
 546
 547         if (/^N/) {
 548             chop($_ = <<'EOT');
 549 $_ .= <>;
 550 <<--#ifdef TSEEN
 551 $tflag = '';
 552 <<--#endif
 553 EOT
 554             next;
 555         }
 556
 557         if (/^h/) {
 558             $_ = '$hold = $_;';
 559             next;
 560         }
 561
 562         if (/^H/) {
 563             $_ = '$hold .= $_ ? $_ : "\n";';
 564             next;
 565         }
 566
 567         if (/^g/) {
 568             $_ = '$_ = $hold;';
 569             next;
 570         }
 571
 572         if (/^G/) {
 573             $_ = '$_ .= $hold ? $hold : "\n";';
 574             next;
 575         }
 576
 577         if (/^x/) {
 578             $_ = '($_, $hold) = ($hold, $_);';
 579             next;
 580         }
 581
 582         if (/^b$/) {
 583             $_ = 'next LINE;';
 584             next;
 585         }
 586
 587         if (/^b/) {
 588             s/^b[ \t]*//;
 589             $lab = &make_label($_);
 590             if ($lab eq $toplabel) {
 591                 $_ = 'redo LINE;';
 592             } else {
 593                 $_ = "goto $lab;";
 594             }
 595             next;
 596         }
 597
 598         if (/^t$/) {
 599             $_ = 'next LINE if $tflag;';
 600             $tseen++;
 601             next;
 602         }
 603
 604         if (/^t/) {
 605             s/^t[ \t]*//;
 606             $lab = &make_label($_);
 607             $_ = q/if ($tflag) {$tflag = ''; /;
 608             if ($lab eq $toplabel) {
 609                 $_ .= 'redo LINE;}';
 610             } else {
 611                 $_ .= "goto $lab;}";
 612             }
 613             $tseen++;
 614             next;
 615         }
 616
 617         if (/^=/) {
 618             $_ = 'print "$.\n";';
 619             next;
 620         }
 621
 622         if (/^q/) {
 623             chop($_ = <<'EOT');
 624 close(ARGV);
 625 @ARGV = ();
 626 next LINE;
 627 EOT
 628             next;
 629         }
 630     } continue {
 631         if ($space) {
 632             s/^/$space/;
 633             s/(\n)(.)/$1$space$2/g;
 634         }
 635         last;
 636     }
 637     $_;
 638 }
 639
 640 sub fetchpat {
 641     local($outer) = @_;
 642     local($addr) = $outer;
 643     local($inbracket);
 644     local($prefix,$delim,$ch);
 645
 646     # Process pattern one potential delimiter at a time.
 647
 648     DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
 649         $prefix = $1;
 650         $delim = $2;
 651         if ($delim eq '\\') {
 652             s/(.)//;
 653             $ch = $1;
 654             $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
 655             $ch = 'b' if $ch =~ /^[<>]$/;
 656             $delim .= $ch;
 657         }
 658         elsif ($delim eq '[') {
 659             $inbracket = 1;
 660             s/^\^// && ($delim .= '^');
 661             s/^]// && ($delim .= ']');
 662         }
 663         elsif ($delim eq ']') {
 664             $inbracket = 0;
 665         }
 666         elsif ($inbracket || $delim ne $outer) {
 667             $delim = '\\' . $delim;
 668         }
 669         $addr .= $prefix;
 670         $addr .= $delim;
 671         if ($delim eq $outer && !$inbracket) {
 672             last DELIM;
 673         }
 674     }
 675     $addr;
 676 }