statements.c
1 //! @file statements.c
2 //! @author J. Marcel van der Veer
3 //
4 //! @section Copyright
5 //
6 // This file is part of VIF - vintage FORTRAN compiler.
7 // Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
8 //
9 //! @section License
10 //
11 // This program is free software; you can redistribute it and/or modify it
12 // under the terms of the GNU General Public License as published by the
13 // Free Software Foundation; either version 3 of the License, or
14 // (at your option) any later version.
15 //
16 // This program is distributed in the hope that it will be useful, but
17 // WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 // or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 // more details. You should have received a copy of the GNU General Public
20 // License along with this program. If not, see <http://www.gnu.org/licenses/>.
21
22 //! @section Synopsis
23 //!
24 //! Compile statements.
25
26 #include <vif.h>
27
28 int_4 patch (int_4 where, char *str)
29 {
30 if (where >= 0 && where < n_c_src) {
31 C_SRC *lin = &object[where];
32 if (str != NO_TEXT) {
33 lin->text = f_stralloc (str);
34 } else {
35 lin->text = NO_TEXT;
36 }
37 } else {
38 BUG ("patch");
39 }
40 return where;
41 }
42
43 void patch_args (void)
44 {
45 for (int_4 k = 0; k < nlocals; k++) {
46 IDENT *idf = &locals[k];
47 if (idf->arg) {
48 NEW_RECORD (str);
49 if (idf->external) {
50 _srecordf (str, "%s (*%s)()", wtype (&idf->mode, NOARG, FUN), edit_f (C_NAME (idf)));
51 } else if (IS_SCALAR (idf->mode)) {
52 _srecordf (str, "%s%s", wtype (&idf->mode, ARG, NOFUN), C_NAME (idf));
53 } else {
54 _srecordf (str, "%s _p_ %s", wtype (&idf->mode, NOARG, FUN), C_NAME (idf));
55 }
56 if (idf->patch1 != 0) {
57 patch (idf->patch1, str);
58 }
59 if (idf->patch2 != 0) {
60 patch (idf->patch2, str);
61 }
62 }
63 }
64 }
65
66 //
67 // EXECUTABLE STATEMENTS
68 //
69
70 void vif_extensions(void)
71 {
72 if (TOKEN ("exit")) {
73 code (nprocs, BODY, "break;\n");
74 } else if (TOKEN ("break")) {
75 code (nprocs, BODY, "break;\n");
76 } else if (TOKEN ("cycle")) {
77 // CYCLE
78 code (nprocs, BODY, "continue;\n");
79 } else {
80 ERROR (3001, "syntax", curlex);
81 }
82 skip_card (FALSE);
83 }
84
85 void condit (int_4 depth)
86 {
87 int_4 rc = scan ("(");
88 int_4 apatch = code (nprocs, BODY, NO_TEXT);
89 EXPR reg;
90 rc = scan (EXPECT_NONE);
91 express (®, NOTYPE, NOLEN);
92 rc = scan (")");
93 rc = scan (EXPECT_NONE);
94 if (TOKEN ("then")) {
95 // Block IF.
96 skip_card (FALSE);
97 NEW_RECORD (str);
98 if (reg.mode.type != LOGICAL) {
99 EXPECT (3002, "logical expression");
100 }
101 _srecordf (str, "if (%s) {\n", reg.str);
102 patch (apatch, str);
103 gen_statements (NO_LABEL, depth + 1);
104 while (TOKEN ("elseif")) {
105 EXPR reh;
106 rc = scan ("(");
107 rc = scan (EXPECT_NONE);
108 express (&reh, NOTYPE, NOLEN);
109 rc = scan (")");
110 rc = scan ("THEN");
111 if (reh.mode.type != LOGICAL) {
112 EXPECT (3003, "logical expression");
113 }
114 code (nprocs, BODY, "}\n");
115 _srecordf (str, "else if (%s) {\n", reh.str);
116 code (nprocs, BODY, str);
117 gen_statements (NO_LABEL, depth + 1);
118 }
119 if (TOKEN ("else")) {
120 skip_card (FALSE);
121 code (nprocs, BODY, "}\n");
122 code (nprocs, BODY, "else {\n");
123 gen_statements (NO_LABEL, depth + 1);
124 }
125 if (TOKEN ("endif")) {
126 skip_card (FALSE);
127 } else {
128 EXPECT (3004, "endif");
129 }
130 code (nprocs, BODY, "}\n");
131 } else if (rc == INT_NUMBER) {
132 // Arithmetic IF.
133 NEW_RECORD (str);
134 NEW_RECORD (tmp);
135 NEW_RECORD (l1);
136 NEW_RECORD (l2);
137 NEW_RECORD (l3);
138 LBL *lab1, *lab2, *lab3;
139 IDENT *idf;
140 int_4 N = 0;
141 // Gather the labels
142 RECCPY (l1, curlex);
143 lab1 = find_label (l1);
144 if (lab1 == NO_LABEL) {
145 ERROR (3005, "no such label", l1);
146 return;
147 }
148 lab1->jumped++;
149 rc = scan (",");
150 rc = scan (EXPECT_NONE);
151 if (rc != INT_NUMBER) {
152 EXPECT (3006, "label");
153 return;
154 }
155 RECCPY (l2, curlex);
156 lab2 = find_label (l2);
157 if (lab2 == NO_LABEL) {
158 ERROR (3007, "no such label", l2);
159 return;
160 }
161 lab2->jumped++;
162 rc = scan (",");
163 if (rc == END_OF_LINE) {
164 N = 2;
165 } else {
166 N = 3;
167 rc = scan (EXPECT_NONE);
168 if (rc != INT_NUMBER) {
169 EXPECT (3008, "label");
170 return;
171 }
172 RECCPY (l3, curlex);
173 lab3 = find_label (l3);
174 if (lab3 == NO_LABEL) {
175 ERROR (3009, "no such label", l3);
176 return;
177 }
178 lab3->jumped++;
179 }
180 if (N == 3) {
181 // ANSI FORTRAN three-branch arithmetic statement.
182 if (reg.mode.type != INTEGER && reg.mode.type != REAL) {
183 EXPECT (3010, "integer or real expression");
184 }
185 _srecordf (tmp, "%s", edit_tmp (nloctmps++));
186 idf = add_local (tmp, reg.mode.type, reg.mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
187 _srecordf (str, "%s = %s;\n", C_NAME (idf), reg.str);
188 code (nprocs, BODY, str);
189 _srecordf (str, "if (%s < 0) {\n", C_NAME (idf));
190 code (nprocs, BODY, str);
191 _srecordf (str, "goto _l%d;\n", lab1->num);
192 code (nprocs, BODY, str);
193 _srecordf (str, "}");
194 code (nprocs, BODY, str);
195 _srecordf (str, "else if (%s == 0) {\n", C_NAME (idf));
196 code (nprocs, BODY, str);
197 _srecordf (str, "goto _l%d;\n", lab2->num);
198 code (nprocs, BODY, str);
199 _srecordf (str, "}");
200 code (nprocs, BODY, str);
201 _srecordf (str, "else {\n");
202 code (nprocs, BODY, str);
203 _srecordf (str, "goto _l%d;\n", lab3->num);
204 code (nprocs, BODY, str);
205 _srecordf (str, "}\n");
206 code (nprocs, BODY, str);
207 } else {
208 // CRAY FORTRAN two-branch arithmetic statement.
209 if (reg.mode.type != INTEGER && reg.mode.type != REAL && reg.mode.type != LOGICAL) {
210 EXPECT (3011, "integer, real or logical expression");
211 }
212 if (reg.mode.type == INTEGER || reg.mode.type == REAL) {
213 if (reg.variant == EXPR_VAR || reg.variant == EXPR_SLICE) {
214 _srecordf (str, "if (%s != 0) {\n", reg.str);
215 } else {
216 _srecordf (str, "if ((%s) != 0) {\n", reg.str);
217 }
218 } else {
219 if (reg.variant == EXPR_VAR || reg.variant == EXPR_SLICE) {
220 _srecordf (str, "if (%s == TRUE) {\n", reg.str);
221 } else {
222 _srecordf (str, "if ((%s) == TRUE) {\n", reg.str);
223 }
224 }
225 code (nprocs, BODY, str);
226 _srecordf (str, "goto _l%d;\n", lab1->num);
227 code (nprocs, BODY, str);
228 _srecordf (str, "}");
229 code (nprocs, BODY, str);
230 _srecordf (str, "else {\n");
231 code (nprocs, BODY, str);
232 _srecordf (str, "goto _l%d;\n", lab2->num);
233 code (nprocs, BODY, str);
234 _srecordf (str, "}\n");
235 code (nprocs, BODY, str);
236 }
237 skip_card (FALSE);
238 } else {
239 // Logical IF.
240 NEW_RECORD (str);
241 if (reg.mode.type != LOGICAL) {
242 EXPECT (3012, "logical expression");
243 }
244 _srecordf (str, "if (%s) {\n", reg.str);
245 patch (apatch, str);
246 if (TOKEN ("if")) {
247 condit (depth);
248 } else {
249 executable ();
250 }
251 code (nprocs, BODY, "}\n");
252 }
253 }
254
255 void do_loop (LBL * curlbl, int_4 depth)
256 {
257 int_4 rc;
258 LBL *newlbl;
259 EXPR lhs, from, to, by;
260 NEW_RECORD (str);
261 lhs.mode.type = NOTYPE;
262 lhs.mode.len = 0;
263 rc = scan (EXPECT_LABEL);
264 if (rc != LABEL) {
265 newlbl = NO_LABEL;
266 } else {
267 newlbl = find_label (curlex);
268 if (newlbl == NO_LABEL) {
269 ERROR (3013, "no such label", curlex);
270 return;
271 }
272 if (curlbl != NO_LABEL && newlbl->line > curlbl->line) {
273 ERROR (3014, "incorrect loop nesting", NO_TEXT);
274 return;
275 }
276 rc = scan (EXPECT_NONE);
277 }
278 if (TOKEN ("repeat")) {
279 skip_card (FALSE);
280 code (nprocs, BODY, "do {\n");
281 gen_statements (newlbl, depth + 1);
282 code (nprocs, BODY, "} while (TRUE);\n");
283 } else if (TOKEN ("while")) {
284 rc = scan ("(");
285 EXPR reg;
286 rc = scan (EXPECT_NONE);
287 express (®, NOTYPE, NOLEN);
288 rc = scan (")");
289 skip_card (FALSE);
290 if (reg.mode.type != LOGICAL) {
291 EXPECT (3015, "logical expression");
292 }
293 _srecordf (str, "while (%s) {\n", reg.str);
294 code (nprocs, BODY, str);
295 gen_statements (newlbl, depth + 1);
296 code (nprocs, BODY, "}\n");
297 } else {
298 // DO 1, I = 1, 10, 2
299 if (TOKEN (",")) {
300 rc = scan (EXPECT_NONE);
301 }
302 if (rc != WORD) {
303 EXPECT (3016, "variable");
304 } else {
305 impl_decl (curlex, NO_MODE);
306 express (&lhs, NOTYPE, NOLEN);
307 if (lhs.variant != EXPR_VAR) {
308 EXPECT (3017, "variable");
309 return;
310 }
311 }
312 rc = scan ("=");
313 rc = scan (EXPECT_NONE);
314 express (&from, lhs.mode.type, lhs.mode.len);
315 rc = scan (",");
316 rc = scan (EXPECT_NONE);
317 express (&to, lhs.mode.type, lhs.mode.len);
318 rc = scan (EXPECT_NONE);
319 if (TOKEN (",")) {
320 rc = scan (EXPECT_NONE);
321 express (&by, lhs.mode.type, lhs.mode.len);
322 } else {
323 UNSCAN;
324 RECCPY (by.str, "1");
325 }
326 skip_card (TRUE);
327 if (f4_do_loops) {
328 _srecordf (str, "%s = %s;\n", lhs.str, from.str);
329 code (nprocs, BODY, str);
330 code (nprocs, BODY, "do {\n");
331 gen_statements (newlbl, depth + 1);
332 if (strcmp (by.str, "1") == 0) {
333 _srecordf (str, "(%s)++;\n", lhs.str);
334 code (nprocs, BODY, str);
335 code (nprocs, BODY, "}\n");
336 _srecordf (str, "while (%s <= %s);\n", lhs.str, to.str);
337 code (nprocs, BODY, str);
338 } else if (strcmp (by.str, "-1") == 0) {
339 _srecordf (str, "(%s)--;\n", lhs.str);
340 code (nprocs, BODY, str);
341 code (nprocs, BODY, "}\n");
342 _srecordf (str, "while (%s >= %s);\n", lhs.str, to.str);
343 code (nprocs, BODY, str);
344 } else {
345 _srecordf (str, "%s += %s;\n", lhs.str, by.str);
346 code (nprocs, BODY, str);
347 code (nprocs, BODY, "}\n");
348 _srecordf (str, "while (%s > 0 ? %s <= %s : %s >= %s);\n", by.str, lhs.str, to.str, lhs.str, to.str);
349 code (nprocs, BODY, str);
350 }
351 } else {
352 if (strcmp (by.str, "1") == 0) {
353 _srecordf (str, "for (%s = %s; %s <= %s; (%s)++) {\n", lhs.str, from.str, lhs.str, to.str, lhs.str);
354 } else if (strcmp (by.str, "-1") == 0) {
355 _srecordf (str, "for (%s = %s; %s >= %s; (%s)--) {\n", lhs.str, from.str, lhs.str, to.str, lhs.str);
356 } else {
357 _srecordf (str, "for (%s = %s; (%s > 0 ? %s <= %s : %s >= %s); %s += %s) {\n", lhs.str, from.str, by.str, lhs.str, to.str, lhs.str, to.str, lhs.str, by.str);
358 }
359 code (nprocs, BODY, str);
360 gen_statements (newlbl, depth + 1);
361 code (nprocs, BODY, "}\n");
362 }
363 }
364 }
365
366 LBL *lbl = NO_LABEL;
367
368 void executable (void)
369 {
370 int_4 rc = curret;
371 if (TOKEN ("call")) {
372 // CALL
373 cpp_direct (nprocs, prelin, BODY);
374 call ();
375 code (nprocs, BODY, ";\n");
376 skip_card (FALSE);
377 } else if (TOKEN ("close")) {
378 cpp_direct (nprocs, prelin, BODY);
379 vif_close ();
380 skip_card (FALSE);
381 } else if (TOKEN ("decode")) {
382 // DECODE
383 int_4 nest = 0;
384 cpp_direct (nprocs, prelin, BODY);
385 do_io ("decode", &nest);
386 if (nest != 0) {
387 ERROR (3018, "unbalanced parentheses", NO_TEXT);
388 }
389 skip_card (FALSE);
390 } else if (TOKEN ("encode")) {
391 // ENCODE
392 int_4 nest = 0;
393 cpp_direct (nprocs, prelin, BODY);
394 do_io ("encode", &nest);
395 if (nest != 0) {
396 ERROR (3019, "unbalanced parentheses", NO_TEXT);
397 }
398 skip_card (FALSE);
399 } else if (TOKEN ("endfile")) {
400 cpp_direct (nprocs, prelin, BODY);
401 vif_endfile ();
402 skip_card (FALSE);
403 } else if (TOKEN ("continue")) {
404 // CONTINUE
405 code (nprocs, BODY, ";\n");
406 skip_card (FALSE);
407 } else if (TOKEN ("goto")) {
408 // GOTO
409 cpp_direct (nprocs, prelin, BODY);
410 jump ();
411 } else if (TOKEN ("open")) {
412 cpp_direct (nprocs, prelin, BODY);
413 vif_open ();
414 skip_card (FALSE);
415 } else if (TOKEN ("pause")) {
416 // PAUSE
417 NEW_RECORD (str);
418 cpp_direct (nprocs, prelin, BODY);
419 rc = scan (EXPECT_NONE);
420 if (rc == INT_NUMBER) {
421 sscanf (curlex, "%d", &rc);
422 _srecordf (str, "printf (\"PAUSE: %d\\n.\");\n", rc);
423 } else if (rc == TEXT && strlen (curlex) > 0) {
424 curlex[strlen(curlex) - 1] = '\0';
425 _srecordf (str, "printf (\"PAUSE: %s\\n.\");\n", &curlex[1]);
426 } else {
427 _srecordf (str, "printf (\"PAUSE\\n\");\n");
428 }
429 code (nprocs, BODY, str);
430 code (nprocs, BODY, "(void) fgetc (stdin);\n");
431 skip_card (FALSE);
432 } else if (TOKEN ("read")) {
433 // READ
434 int_4 nest = 0;
435 cpp_direct (nprocs, prelin, BODY);
436 do_io ("read", &nest);
437 if (nest != 0) {
438 ERROR (3020, "unbalanced parentheses", NO_TEXT);
439 }
440 skip_card (FALSE);
441 } else if (TOKEN ("accept")) {
442 // ACCEPT
443 int_4 nest = 0;
444 cpp_direct (nprocs, prelin, BODY);
445 do_io ("accept", &nest);
446 if (nest != 0) {
447 ERROR (3021, "unbalanced parentheses", NO_TEXT);
448 }
449 skip_card (FALSE);
450 } else if (TOKEN ("return")) {
451 // RETURN
452 cpp_direct (nprocs, prelin, BODY);
453 labels[0].jumped++;
454 code (nprocs, BODY, RETURN);
455 skip_card (FALSE);
456 // ENTRY
457 } else if (TOKEN ("entry")) {
458 ERROR (3022, "obsolete feature", "entry");
459 skip_card (FALSE);
460 } else if (TOKEN ("backspace")) {
461 // BACKSPACE
462 cpp_direct (nprocs, prelin, BODY);
463 vif_backspace ();
464 skip_card (FALSE);
465 } else if (TOKEN ("rewind")) {
466 // REWIND
467 cpp_direct (nprocs, prelin, BODY);
468 vif_rewind ();
469 skip_card (FALSE);
470 } else if (TOKEN ("stop")) {
471 // STOP
472 NEW_RECORD (str);
473 cpp_direct (nprocs, prelin, BODY);
474 rc = scan (EXPECT_NONE);
475 if (rc == INT_NUMBER) {
476 sscanf (curlex, "%d", &rc);
477 _srecordf (str, "exit (%d);\n", rc);
478 } else {
479 _srecordf (str, "exit (EXIT_SUCCESS);\n");
480 }
481 code (nprocs, BODY, str);
482 skip_card (FALSE);
483 } else if (TOKEN ("write")) {
484 // WRITE
485 int_4 nest = 0;
486 cpp_direct (nprocs, prelin, BODY);
487 do_io ("write", &nest);
488 if (nest != 0) {
489 ERROR (3023, "unbalanced parentheses", NO_TEXT);
490 }
491 skip_card (FALSE);
492 } else if (TOKEN ("print")) {
493 // PRINT
494 int_4 nest = 0;
495 cpp_direct (nprocs, prelin, BODY);
496 do_io ("print", &nest);
497 if (nest != 0) {
498 ERROR (3024, "unbalanced parentheses", NO_TEXT);
499 }
500 skip_card (FALSE);
501 } else if (TOKEN ("punch")) {
502 // PUNCH
503 int_4 nest = 0;
504 cpp_direct (nprocs, prelin, BODY);
505 do_io ("punch", &nest);
506 if (nest != 0) {
507 ERROR (3025, "unbalanced parentheses", NO_TEXT);
508 }
509 skip_card (FALSE);
510 } else if (rc == WORD) {
511 // Single-word extensions EXIT, CYCLE, BREAK, etcetera.
512 SAVE_POS;
513 rc = scan (EXPECT_NONE);
514 if (rc == END_OF_LINE || rc == END_OF_MODULE) {
515 RESTORE_POS;
516 RECCPY (curlex, prelex);
517 vif_extensions ();
518 } else {
519 UNSCAN;
520 // Primary - Assignation or call
521 EXPR reg;
522 MODE mode;
523 cpp_direct (nprocs, prelin, BODY);
524 (void) impl_decl (curlex, &mode);
525 memset (®, 0, sizeof (EXPR));
526 assign (®);
527 code (nprocs, BODY, reg.str);
528 code (nprocs, BODY, ";\n");
529 skip_card (FALSE);
530 }
531 }
532 }
533
534 void gen_statements (LBL * dolbl, int_4 depth)
535 {
536 int_4 rc;
537 while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
538 // Common mistakes.
539 if (TOKEN ("program")) {
540 ERROR (3026, "check for missing end statement", NO_TEXT);
541 } else if (TOKEN ("function")) {
542 ERROR (3027, "check for missing end statement", NO_TEXT);
543 } else if (TOKEN ("subroutine")) {
544 ERROR (3028, "check for missing end statement", NO_TEXT);
545 } else if (TOKEN ("block")) {
546 ERROR (3029, "check for missing end statement", NO_TEXT);
547 }
548 // FORTRAN statements.
549 LBL *statlbl = NO_LABEL;
550 if (rc == LABEL) {
551 NEW_RECORD (str);
552 statlbl = lbl = find_label (curlex);
553 if (lbl == NO_LABEL) {
554 ERROR (3030, "no such label", curlex);
555 } else {
556 _srecordf (str, "_l%d:;\n", lbl->num);
557 lbl->patch = code (nprocs, BODY, str);
558 }
559 rc = scan (EXPECT_NONE);
560 if (TOKEN ("continue")) {
561 continue; // Sic!
562 }
563 }
564 _srecordf (stat_start, "%s:%s:%d", libnam, modnam, CUR_LIN.num);
565 if (rc == DECLAR) {
566 ERROR (3031, "declaration amidst executable statements", NO_TEXT);
567 } else if (TOKEN ("assign")) {
568 // ASSIGN statement, from before the Chicxulub impact.
569 // Relic from when computers had no way to organize subroutine calls.
570 rc = scan (EXPECT_LABEL);
571 if (rc != LABEL) {
572 SYNTAX (3032, "label expected");
573 } else {
574 LBL *slbl = find_label (curlex);
575 if (slbl == NO_LABEL) {
576 ERROR (3033, "no such label", NO_TEXT);
577 }
578 rc = scan ("to");
579 EXPR reg;
580 rc = scan (EXPECT_NONE);
581 express (®, INTEGER, 4);
582 NEW_RECORD (str);
583 _srecordf (str, "%s = %d;\n", reg.str, slbl->index);
584 code (nprocs, BODY, str);
585 }
586 skip_card (FALSE);
587 } else if (TOKEN ("end")) {
588 skip_card (FALSE);
589 end_statements++;
590 // END is not executable.
591 NEW_RECORD (str);
592 if (depth != 0) {
593 SYNTAX (3034, "end must end a subprogram");
594 abend = TRUE;
595 }
596 // Peephole optimisation, END following RETURN which is typical.
597 if (n_c_src > 0) {
598 C_SRC *lin = &object[n_c_src - 1];
599 if (EQUAL (lin->text, RETURN)) {
600 lin->text = NO_TEXT;
601 labels[0].jumped--;
602 }
603 }
604 // Return.
605 labels[0].patch = code (nprocs, BODY, "_l0:;\n");
606 _srecordf (str, "__calls[%d].calls++;\n", nprocs - 1);
607 code (nprocs, BODY, str);
608 if (func) {
609 _srecordf (str, "return %s;\n", retnam);
610 } else {
611 _srecordf (str, "return 0;\n");
612 }
613 cpp_direct (nprocs, prelin, BODY);
614 code (nprocs, BODY, str);
615 return;
616 } else if (TOKEN ("elseif")) {
617 if (depth > 0) {
618 return;
619 } else {
620 SYNTAX (3035, "stray symbol");
621 }
622 } else if (TOKEN ("else")) {
623 if (depth > 0) {
624 return;
625 } else {
626 SYNTAX (3036, "stray symbol");
627 }
628 } else if (TOKEN ("endif")) {
629 if (depth > 0) {
630 return;
631 } else {
632 SYNTAX (3037, "stray symbol");
633 }
634 } else if (TOKEN ("until")) {
635 NEW_RECORD (str);
636 rc = scan ("(");
637 EXPR reg;
638 rc = scan (EXPECT_NONE);
639 express (®, NOTYPE, NOLEN);
640 rc = scan (")");
641 if (reg.mode.type != LOGICAL) {
642 EXPECT (3038, "logical expression");
643 }
644 _srecordf (str, "if (%s) {\n", reg.str);
645 code (nprocs, BODY, str);
646 _srecordf (str, "break;\n");
647 code (nprocs, BODY, str);
648 _srecordf (str, "}\n");
649 code (nprocs, BODY, str);
650 skip_card (FALSE);
651 } else if (TOKEN ("if")) {
652 cpp_direct (nprocs, prelin, BODY);
653 condit (depth);
654 } else if (TOKEN ("do")) {
655 // DO
656 cpp_direct (nprocs, prelin, BODY);
657 do_loop (dolbl, depth);
658 skip_card (FALSE);
659 } else if (TOKEN ("enddo")) {
660 if (dolbl != NO_LABEL) {
661 ERROR (3039, "misplaced end do", NO_TEXT);
662 }
663 if (depth > 0) {
664 return;
665 } else {
666 SYNTAX (3040, "stray symbol");
667 }
668 } else if (TOKEN ("format")) {
669 cpp_direct (nprocs, prelin, FMT);
670 format (statlbl);
671 skip_card (FALSE);
672 } else {
673 executable ();
674 }
675 // Return for DO loop (ending label reached).
676 if (dolbl != NO_LABEL && lbl != NO_LABEL && dolbl->num == lbl->num) {
677 if (depth == 0) {
678 BUG ("nesting");
679 }
680 return;
681 }
682 }
683 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
