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