Commit | Line | Data |
a687059c |
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 | |
0a12ae7d |
31 | # $Header: s2p.SH,v 3.0.1.5 90/10/16 11:32:40 lwall Locked $ |
378cc40b |
32 | # |
a687059c |
33 | # $Log: s2p.SH,v $ |
0a12ae7d |
34 | # Revision 3.0.1.5 90/10/16 11:32:40 lwall |
35 | # patch29: s2p modernized |
36 | # |
00bf170e |
37 | # Revision 3.0.1.4 90/08/09 05:50:43 lwall |
38 | # patch19: s2p didn't translate \n right |
39 | # |
9f68db38 |
40 | # Revision 3.0.1.3 90/03/01 10:31:21 lwall |
41 | # patch9: s2p didn't handle \< and \> |
42 | # |
ffed7fef |
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 | # |
ae986130 |
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 | # |
a687059c |
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 | # |
378cc40b |
57 | # Revision 2.0 88/06/05 00:15:55 root |
58 | # Baseline version 2.0. |
59 | # |
60 | # |
8d063cd8 |
61 | |
62 | $indent = 4; |
63 | $shiftwidth = 4; |
64 | $l = '{'; $r = '}'; |
8d063cd8 |
65 | |
0a12ae7d |
66 | while ($ARGV[0] =~ /^-/) { |
8d063cd8 |
67 | $_ = shift; |
68 | last if /^--/; |
69 | if (/^-D/) { |
70 | $debug++; |
0a12ae7d |
71 | open(BODY,'>-'); |
8d063cd8 |
72 | next; |
73 | } |
74 | if (/^-n/) { |
75 | $assumen++; |
76 | next; |
77 | } |
78 | if (/^-p/) { |
79 | $assumep++; |
80 | next; |
81 | } |
378cc40b |
82 | die "I don't recognize this switch: $_\n"; |
8d063cd8 |
83 | } |
84 | |
85 | unless ($debug) { |
0a12ae7d |
86 | open(BODY,">/tmp/sperl$$") || |
87 | &Die("Can't open temp file: $!\n"); |
8d063cd8 |
88 | } |
89 | |
90 | if (!$assumen && !$assumep) { |
0a12ae7d |
91 | print BODY <<'EOT'; |
92 | while ($ARGV[0] =~ /^-/) { |
8d063cd8 |
93 | $_ = shift; |
94 | last if /^--/; |
95 | if (/^-n/) { |
96 | $nflag++; |
97 | next; |
98 | } |
0a12ae7d |
99 | die "I don't recognize this switch: $_\\n"; |
8d063cd8 |
100 | } |
101 | |
0a12ae7d |
102 | EOT |
8d063cd8 |
103 | } |
104 | |
0a12ae7d |
105 | print BODY <<'EOT'; |
106 | |
8d063cd8 |
107 | #ifdef PRINTIT |
108 | #ifdef ASSUMEP |
109 | $printit++; |
110 | #else |
111 | $printit++ unless $nflag; |
112 | #endif |
113 | #endif |
0a12ae7d |
114 | LINE: while (<>) { |
115 | EOT |
116 | |
117 | LINE: while (<>) { |
118 | |
119 | # Wipe out surrounding whitespace. |
8d063cd8 |
120 | |
8d063cd8 |
121 | s/[ \t]*(.*)\n$/$1/; |
0a12ae7d |
122 | |
123 | # Perhaps it's a label/comment. |
124 | |
8d063cd8 |
125 | if (/^:/) { |
126 | s/^:[ \t]*//; |
0a12ae7d |
127 | $label = &make_label($_); |
8d063cd8 |
128 | if ($. == 1) { |
129 | $toplabel = $label; |
130 | } |
131 | $_ = "$label:"; |
ffed7fef |
132 | if ($lastlinewaslabel++) { |
133 | $indent += 4; |
0a12ae7d |
134 | print BODY &tab, ";\n"; |
ffed7fef |
135 | $indent -= 4; |
136 | } |
8d063cd8 |
137 | if ($indent >= 2) { |
138 | $indent -= 2; |
139 | $indmod = 2; |
140 | } |
141 | next; |
142 | } else { |
143 | $lastlinewaslabel = ''; |
144 | } |
0a12ae7d |
145 | |
146 | # Look for one or two address clauses |
147 | |
8d063cd8 |
148 | $addr1 = ''; |
149 | $addr2 = ''; |
150 | if (s/^([0-9]+)//) { |
151 | $addr1 = "$1"; |
152 | } |
153 | elsif (s/^\$//) { |
154 | $addr1 = 'eof()'; |
155 | } |
156 | elsif (s|^/||) { |
0a12ae7d |
157 | $addr1 = &fetchpat('/'); |
8d063cd8 |
158 | } |
159 | if (s/^,//) { |
160 | if (s/^([0-9]+)//) { |
161 | $addr2 = "$1"; |
162 | } elsif (s/^\$//) { |
163 | $addr2 = "eof()"; |
164 | } elsif (s|^/||) { |
0a12ae7d |
165 | $addr2 = &fetchpat('/'); |
8d063cd8 |
166 | } else { |
0a12ae7d |
167 | &Die("Invalid second address at line $.\n"); |
8d063cd8 |
168 | } |
169 | $addr1 .= " .. $addr2"; |
170 | } |
0a12ae7d |
171 | |
172 | # Now we check for metacommands {, }, and ! and worry |
173 | # about indentation. |
174 | |
378cc40b |
175 | s/^[ \t]+//; |
0a12ae7d |
176 | # a { to keep vi happy |
8d063cd8 |
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) { |
a687059c |
196 | $space = ' ' x $shiftwidth; |
8d063cd8 |
197 | } else { |
198 | $space = ''; |
199 | } |
0a12ae7d |
200 | $_ = &transmogrify(); |
8d063cd8 |
201 | } |
202 | |
0a12ae7d |
203 | # See if we can optimize to modifier form. |
204 | |
8d063cd8 |
205 | if ($addr1) { |
206 | if ($_ !~ /[\n{}]/ && $rmaybe && !$change && |
207 | $_ !~ / if / && $_ !~ / unless /) { |
208 | s/;$/ $if $addr1;/; |
209 | $_ = substr($_,$shiftwidth,1000); |
210 | } else { |
0a12ae7d |
211 | $_ = "$if ($addr1) $l\n$change$_$rmaybe"; |
8d063cd8 |
212 | } |
213 | $change = ''; |
0a12ae7d |
214 | next LINE; |
8d063cd8 |
215 | } |
216 | } continue { |
217 | @lines = split(/\n/,$_); |
0a12ae7d |
218 | for (@lines) { |
8d063cd8 |
219 | unless (s/^ *<<--//) { |
0a12ae7d |
220 | print BODY &tab; |
8d063cd8 |
221 | } |
0a12ae7d |
222 | print BODY $_, "\n"; |
8d063cd8 |
223 | } |
224 | $indent += $indmod; |
225 | $indmod = 0; |
226 | if ($redo) { |
227 | $_ = $redo; |
228 | $redo = ''; |
0a12ae7d |
229 | redo LINE; |
8d063cd8 |
230 | } |
231 | } |
ffed7fef |
232 | if ($lastlinewaslabel++) { |
233 | $indent += 4; |
0a12ae7d |
234 | print BODY &tab, ";\n"; |
ffed7fef |
235 | $indent -= 4; |
236 | } |
8d063cd8 |
237 | |
0a12ae7d |
238 | print BODY "}\n"; |
8d063cd8 |
239 | if ($appendseen || $tseen || !$assumen) { |
240 | $printit++ if $dseen || (!$assumen && !$assumep); |
0a12ae7d |
241 | print BODY <<'EOT'; |
242 | |
8d063cd8 |
243 | continue { |
244 | #ifdef PRINTIT |
245 | #ifdef DSEEN |
246 | #ifdef ASSUMEP |
247 | print if $printit++; |
248 | #else |
0a12ae7d |
249 | if ($printit) |
250 | { print; } |
251 | else |
252 | { $printit++ unless $nflag; } |
8d063cd8 |
253 | #endif |
254 | #else |
255 | print if $printit; |
256 | #endif |
257 | #else |
258 | print; |
259 | #endif |
260 | #ifdef TSEEN |
0a12ae7d |
261 | $tflag = ''; |
8d063cd8 |
262 | #endif |
263 | #ifdef APPENDSEEN |
0a12ae7d |
264 | if ($atext) { print $atext; $atext = ''; } |
8d063cd8 |
265 | #endif |
266 | } |
0a12ae7d |
267 | EOT |
8d063cd8 |
268 | } |
269 | |
0a12ae7d |
270 | close BODY; |
8d063cd8 |
271 | |
272 | unless ($debug) { |
0a12ae7d |
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 $_; |
8d063cd8 |
286 | } |
0a12ae7d |
287 | close HEAD; |
8d063cd8 |
288 | |
0a12ae7d |
289 | print <<"EOT"; |
290 | #!$bin/perl |
291 | eval 'exec $bin/perl -S \$0 \$*' |
a687059c |
292 | if \$running_under_some_shell; |
293 | |
0a12ae7d |
294 | EOT |
295 | open(BODY,"cc -E /tmp/sperl2$$.c |") || |
296 | &Die("Can't reopen temp file: $!\n"); |
297 | while (<BODY>) { |
8d063cd8 |
298 | /^# [0-9]/ && next; |
299 | /^[ \t]*$/ && next; |
300 | s/^<><>//; |
301 | print; |
302 | } |
303 | } |
304 | |
0a12ae7d |
305 | &Cleanup; |
306 | exit; |
8d063cd8 |
307 | |
0a12ae7d |
308 | sub Cleanup { |
309 | chdir "/tmp"; |
310 | unlink "sperl$$", "sperl2$$", "sperl2$$.c"; |
311 | } |
8d063cd8 |
312 | sub Die { |
0a12ae7d |
313 | &Cleanup; |
8d063cd8 |
314 | die $_[0]; |
315 | } |
0a12ae7d |
316 | sub tab { |
317 | "\t" x ($indent / 8) . ' ' x ($indent % 8); |
318 | } |
8d063cd8 |
319 | sub make_filehandle { |
0a12ae7d |
320 | local($_) = $_[0]; |
321 | local($fname) = $_; |
8d063cd8 |
322 | s/[^a-zA-Z]/_/g; |
323 | s/^_*//; |
0a12ae7d |
324 | substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/; |
8d063cd8 |
325 | if (!$seen{$_}) { |
0a12ae7d |
326 | $opens .= <<"EOT"; |
327 | open($_,'>$fname') || die "Can't create $fname"; |
328 | EOT |
8d063cd8 |
329 | } |
330 | $seen{$_} = $_; |
331 | } |
332 | |
333 | sub make_label { |
0a12ae7d |
334 | local($label) = @_; |
8d063cd8 |
335 | $label =~ s/[^a-zA-Z0-9]/_/g; |
336 | if ($label =~ /^[0-9_]/) { $label = 'L' . $label; } |
337 | $label = substr($label,0,8); |
0a12ae7d |
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 | |
8d063cd8 |
343 | $label; |
344 | } |
345 | |
346 | sub transmogrify { |
347 | { # case |
348 | if (/^d/) { |
349 | $dseen++; |
0a12ae7d |
350 | chop($_ = <<'EOT'); |
8d063cd8 |
351 | <<--#ifdef PRINTIT |
0a12ae7d |
352 | $printit = ''; |
8d063cd8 |
353 | <<--#endif |
0a12ae7d |
354 | next LINE; |
355 | EOT |
8d063cd8 |
356 | next; |
357 | } |
358 | |
359 | if (/^n/) { |
0a12ae7d |
360 | chop($_ = <<'EOT'); |
361 | <<--#ifdef PRINTIT |
8d063cd8 |
362 | <<--#ifdef DSEEN |
363 | <<--#ifdef ASSUMEP |
364 | print if $printit++; |
365 | <<--#else |
0a12ae7d |
366 | if ($printit) |
367 | { print; } |
368 | else |
369 | { $printit++ unless $nflag; } |
8d063cd8 |
370 | <<--#endif |
371 | <<--#else |
372 | print if $printit; |
373 | <<--#endif |
374 | <<--#else |
375 | print; |
376 | <<--#endif |
377 | <<--#ifdef APPENDSEEN |
0a12ae7d |
378 | if ($atext) {print $atext; $atext = '';} |
8d063cd8 |
379 | <<--#endif |
380 | $_ = <>; |
381 | <<--#ifdef TSEEN |
0a12ae7d |
382 | $tflag = ''; |
383 | <<--#endif |
384 | EOT |
8d063cd8 |
385 | next; |
386 | } |
387 | |
388 | if (/^a/) { |
389 | $appendseen++; |
0a12ae7d |
390 | $command = $space . '$atext .=' . "\n<<--'"; |
8d063cd8 |
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 . ')'; |
0a12ae7d |
409 | $command = $space . 'if ($iter == 1) { print' |
410 | . "\n<<--'"; |
8d063cd8 |
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"; |
0a12ae7d |
426 | chop($_ = <<"EOT"); |
8d063cd8 |
427 | <<--#ifdef PRINTIT |
428 | $space\$printit = ''; |
429 | <<--#endif |
0a12ae7d |
430 | ${space}next LINE; |
431 | EOT |
8d063cd8 |
432 | } |
433 | last; |
434 | } |
435 | |
436 | if (/^s/) { |
437 | $delim = substr($_,1,1); |
438 | $len = length($_); |
439 | $repl = $end = 0; |
a687059c |
440 | $inbracket = 0; |
8d063cd8 |
441 | for ($i = 2; $i < $len; $i++) { |
442 | $c = substr($_,$i,1); |
a687059c |
443 | if ($c eq $delim) { |
444 | if ($inbracket) { |
0a12ae7d |
445 | substr($_, $i, 0) = '\\'; |
a687059c |
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 '\\') { |
8d063cd8 |
459 | $i++; |
460 | if ($i >= $len) { |
461 | $_ .= 'n'; |
462 | $_ .= <>; |
463 | $len = length($_); |
464 | $_ = substr($_,0,--$len); |
465 | } |
00bf170e |
466 | elsif (substr($_,$i,1) =~ /^[n]$/) { |
467 | ; |
468 | } |
0a12ae7d |
469 | elsif (!$repl && |
470 | substr($_,$i,1) =~ /^[(){}\w]$/) { |
8d063cd8 |
471 | $i--; |
472 | $len--; |
0a12ae7d |
473 | substr($_, $i, 1) = ''; |
8d063cd8 |
474 | } |
0a12ae7d |
475 | elsif (!$repl && |
476 | substr($_,$i,1) =~ /^[<>]$/) { |
9f68db38 |
477 | substr($_,$i,1) = 'b'; |
478 | } |
8d063cd8 |
479 | } |
a687059c |
480 | elsif ($c eq '[' && !$repl) { |
481 | $i++ if substr($_,$i,1) eq '^'; |
482 | $i++ if substr($_,$i,1) eq ']'; |
483 | $inbracket = 1; |
8d063cd8 |
484 | } |
a687059c |
485 | elsif ($c eq ']') { |
486 | $inbracket = 0; |
487 | } |
ae986130 |
488 | elsif (!$repl && index("()+",$c) >= 0) { |
0a12ae7d |
489 | substr($_, $i, 0) = '\\'; |
8d063cd8 |
490 | $i++; |
491 | $len++; |
492 | } |
493 | } |
0a12ae7d |
494 | &Die("Malformed substitution at line $.\n") |
495 | unless $end; |
8d063cd8 |
496 | $pat = substr($_, 0, $repl + 1); |
0a12ae7d |
497 | $repl = substr($_, $repl+1, $end-$repl-1); |
8d063cd8 |
498 | $end = substr($_, $end + 1, 1000); |
499 | $dol = '$'; |
378cc40b |
500 | $repl =~ s/\$/\\$/; |
8d063cd8 |
501 | $repl =~ s'&'$&'g; |
502 | $repl =~ s/[\\]([0-9])/$dol$1/g; |
503 | $subst = "$pat$repl$delim"; |
504 | $cmd = ''; |
505 | while ($end) { |
0a12ae7d |
506 | if ($end =~ s/^g//) { |
507 | $subst .= 'g'; |
508 | next; |
509 | } |
510 | if ($end =~ s/^p//) { |
511 | $cmd .= ' && (print)'; |
512 | next; |
513 | } |
8d063cd8 |
514 | if ($end =~ s/^w[ \t]*//) { |
0a12ae7d |
515 | $fh = &make_filehandle($end); |
8d063cd8 |
516 | $cmd .= " && (print $fh \$_)"; |
517 | $end = ''; |
518 | next; |
519 | } |
0a12ae7d |
520 | &Die("Unrecognized substitution command". |
521 | "($end) at line $.\n"); |
8d063cd8 |
522 | } |
0a12ae7d |
523 | chop ($_ = <<"EOT"); |
524 | <<--#ifdef TSEEN |
a687059c |
525 | $subst && \$tflag++$cmd; |
526 | <<--#else |
527 | $subst$cmd; |
0a12ae7d |
528 | <<--#endif |
529 | EOT |
8d063cd8 |
530 | next; |
531 | } |
532 | |
533 | if (/^p/) { |
534 | $_ = 'print;'; |
535 | next; |
536 | } |
537 | |
538 | if (/^w/) { |
539 | s/^w[ \t]*//; |
0a12ae7d |
540 | $fh = &make_filehandle($_); |
8d063cd8 |
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/) { |
a687059c |
554 | $_ = 'print $1 if /(^.*\n)/;'; |
8d063cd8 |
555 | next; |
556 | } |
557 | |
558 | if (/^D/) { |
0a12ae7d |
559 | chop($_ = <<'EOT'); |
560 | s/^.*\n//; |
561 | redo LINE if $_; |
562 | next LINE; |
563 | EOT |
8d063cd8 |
564 | next; |
565 | } |
566 | |
567 | if (/^N/) { |
0a12ae7d |
568 | chop($_ = <<'EOT'); |
8d063cd8 |
569 | $_ .= <>; |
570 | <<--#ifdef TSEEN |
0a12ae7d |
571 | $tflag = ''; |
572 | <<--#endif |
573 | EOT |
8d063cd8 |
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$/) { |
0a12ae7d |
603 | $_ = 'next LINE;'; |
8d063cd8 |
604 | next; |
605 | } |
606 | |
607 | if (/^b/) { |
608 | s/^b[ \t]*//; |
0a12ae7d |
609 | $lab = &make_label($_); |
8d063cd8 |
610 | if ($lab eq $toplabel) { |
0a12ae7d |
611 | $_ = 'redo LINE;'; |
8d063cd8 |
612 | } else { |
613 | $_ = "goto $lab;"; |
614 | } |
615 | next; |
616 | } |
617 | |
618 | if (/^t$/) { |
0a12ae7d |
619 | $_ = 'next LINE if $tflag;'; |
8d063cd8 |
620 | $tseen++; |
621 | next; |
622 | } |
623 | |
624 | if (/^t/) { |
625 | s/^t[ \t]*//; |
0a12ae7d |
626 | $lab = &make_label($_); |
627 | $_ = q/if ($tflag) {$tflag = ''; /; |
8d063cd8 |
628 | if ($lab eq $toplabel) { |
0a12ae7d |
629 | $_ .= 'redo LINE;}'; |
8d063cd8 |
630 | } else { |
0a12ae7d |
631 | $_ .= "goto $lab;}"; |
8d063cd8 |
632 | } |
633 | $tseen++; |
634 | next; |
635 | } |
636 | |
637 | if (/^=/) { |
638 | $_ = 'print "$.\n";'; |
639 | next; |
640 | } |
641 | |
642 | if (/^q/) { |
0a12ae7d |
643 | chop($_ = <<'EOT'); |
644 | close(ARGV); |
8d063cd8 |
645 | @ARGV = (); |
0a12ae7d |
646 | next LINE; |
647 | EOT |
8d063cd8 |
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 | |
a687059c |
660 | sub fetchpat { |
661 | local($outer) = @_; |
662 | local($addr) = $outer; |
663 | local($inbracket); |
664 | local($prefix,$delim,$ch); |
665 | |
0a12ae7d |
666 | # Process pattern one potential delimiter at a time. |
667 | |
668 | DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) { |
a687059c |
669 | $prefix = $1; |
670 | $delim = $2; |
a687059c |
671 | if ($delim eq '\\') { |
672 | s/(.)//; |
673 | $ch = $1; |
00bf170e |
674 | $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/; |
9f68db38 |
675 | $ch = 'b' if $ch =~ /^[<>]$/; |
676 | $delim .= $ch; |
a687059c |
677 | } |
678 | elsif ($delim eq '[') { |
679 | $inbracket = 1; |
680 | s/^\^// && ($delim .= '^'); |
681 | s/^]// && ($delim .= ']'); |
a687059c |
682 | } |
683 | elsif ($delim eq ']') { |
684 | $inbracket = 0; |
685 | } |
686 | elsif ($inbracket || $delim ne $outer) { |
a687059c |
687 | $delim = '\\' . $delim; |
688 | } |
689 | $addr .= $prefix; |
690 | $addr .= $delim; |
691 | if ($delim eq $outer && !$inbracket) { |
0a12ae7d |
692 | last DELIM; |
a687059c |
693 | } |
694 | } |
695 | $addr; |
696 | } |
697 | |
698 | !NO!SUBS! |
699 | chmod 755 s2p |
700 | $eunicefix s2p |