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