x2p/s2p.SH

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