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