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