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