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