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 ("accept") && IS_NOT_ASSIGNMENT) {
396 // ACCEPT
397 int_4 nest = 0;
398 cpp_direct (nprocs, prelin, BODY);
399 do_io ("accept", &nest);
400 if (nest != 0) {
401 ERROR (3020, "unbalanced parentheses", NO_TEXT);
402 }
403 skip_card (FALSE);
404 } else if (TOKEN ("backspace") && IS_NOT_ASSIGNMENT) {
405 // BACKSPACE
406 cpp_direct (nprocs, prelin, BODY);
407 vif_backspace ();
408 skip_card (FALSE);
409 } else if (TOKEN ("call") && IS_NOT_ASSIGNMENT) {
410 // CALL
411 cpp_direct (nprocs, prelin, BODY);
412 call ();
413 code (nprocs, BODY, ";\n");
414 skip_card (FALSE);
415 } else if (TOKEN ("close") && IS_NOT_ASSIGNMENT) {
416 // CLOSE
417 cpp_direct (nprocs, prelin, BODY);
418 vif_close ();
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 ("decode") && IS_NOT_ASSIGNMENT) {
425 // DECODE
426 int_4 nest = 0;
427 cpp_direct (nprocs, prelin, BODY);
428 do_io ("decode", &nest);
429 if (nest != 0) {
430 ERROR (3021, "unbalanced parentheses", NO_TEXT);
431 }
432 skip_card (FALSE);
433 } else if (TOKEN ("encode") && IS_NOT_ASSIGNMENT) {
434 // ENCODE
435 int_4 nest = 0;
436 cpp_direct (nprocs, prelin, BODY);
437 do_io ("encode", &nest);
438 if (nest != 0) {
439 ERROR (3022, "unbalanced parentheses", NO_TEXT);
440 }
441 skip_card (FALSE);
442 } else if (TOKEN ("endfile") && IS_NOT_ASSIGNMENT) {
443 // ENDFILE
444 cpp_direct (nprocs, prelin, BODY);
445 vif_endfile ();
446 skip_card (FALSE);
447 } else if (TOKEN ("entry") && IS_NOT_ASSIGNMENT) {
448 // ENTRY
449 ERROR (3023, "obsolete feature", "entry");
450 skip_card (FALSE);
451 } else if (TOKEN ("goto") && IS_NOT_ASSIGNMENT) {
452 // GOTO
453 cpp_direct (nprocs, prelin, BODY);
454 jump ();
455 } else if (TOKEN ("inquire") && IS_NOT_ASSIGNMENT) {
456 // INQUIRE
457 cpp_direct (nprocs, prelin, BODY);
458 vif_inquire ();
459 skip_card (FALSE);
460 } else if (TOKEN ("open") && IS_NOT_ASSIGNMENT) {
461 // OPEN
462 cpp_direct (nprocs, prelin, BODY);
463 vif_open ();
464 skip_card (FALSE);
465 } else if (TOKEN ("pause") && IS_NOT_ASSIGNMENT) {
466 // PAUSE
467 NEW_RECORD (str);
468 cpp_direct (nprocs, prelin, BODY);
469 rc = scan (EXPECT_NONE);
470 if (rc == INT_NUMBER) {
471 sscanf (curlex, "%d", &rc);
472 _srecordf (str, "printf (\"PAUSE: %d\\n.\");\n", rc);
473 } else if (rc == TEXT && strlen (curlex) > 0) {
474 curlex[strlen(curlex) - 1] = '\0';
475 _srecordf (str, "printf (\"PAUSE: %s\\n.\");\n", &curlex[1]);
476 } else {
477 _srecordf (str, "printf (\"PAUSE\\n\");\n");
478 }
479 code (nprocs, BODY, str);
480 code (nprocs, BODY, "(void) fgetc (stdin);\n");
481 skip_card (FALSE);
482 } else if (TOKEN ("print") && IS_NOT_ASSIGNMENT) {
483 // PRINT
484 int_4 nest = 0;
485 cpp_direct (nprocs, prelin, BODY);
486 do_io ("print", &nest);
487 if (nest != 0) {
488 ERROR (3024, "unbalanced parentheses", NO_TEXT);
489 }
490 skip_card (FALSE);
491 } else if (TOKEN ("punch") && IS_NOT_ASSIGNMENT) {
492 // PUNCH
493 int_4 nest = 0;
494 cpp_direct (nprocs, prelin, BODY);
495 do_io ("punch", &nest);
496 if (nest != 0) {
497 ERROR (3025, "unbalanced parentheses", NO_TEXT);
498 }
499 skip_card (FALSE);
500 } else if (TOKEN ("read") && IS_NOT_ASSIGNMENT) {
501 // READ
502 int_4 nest = 0;
503 cpp_direct (nprocs, prelin, BODY);
504 do_io ("read", &nest);
505 if (nest != 0) {
506 ERROR (3026, "unbalanced parentheses", NO_TEXT);
507 }
508 skip_card (FALSE);
509 } else if (TOKEN ("return") && IS_NOT_ASSIGNMENT) {
510 // RETURN
511 cpp_direct (nprocs, prelin, BODY);
512 labels[0].jumped++;
513 code (nprocs, BODY, RETURN);
514 skip_card (FALSE);
515 } else if (TOKEN ("rewind") && IS_NOT_ASSIGNMENT) {
516 // REWIND
517 cpp_direct (nprocs, prelin, BODY);
518 vif_rewind ();
519 skip_card (FALSE);
520 } else if (TOKEN ("stop") && IS_NOT_ASSIGNMENT) {
521 // STOP
522 NEW_RECORD (str);
523 cpp_direct (nprocs, prelin, BODY);
524 rc = scan (EXPECT_NONE);
525 if (rc == INT_NUMBER) {
526 sscanf (curlex, "%d", &rc);
527 _srecordf (str, "exit (%d);\n", rc);
528 } else {
529 _srecordf (str, "exit (EXIT_SUCCESS);\n");
530 }
531 code (nprocs, BODY, str);
532 skip_card (FALSE);
533 } else if (TOKEN ("write") && IS_NOT_ASSIGNMENT) {
534 // WRITE
535 int_4 nest = 0;
536 cpp_direct (nprocs, prelin, BODY);
537 do_io ("write", &nest);
538 if (nest != 0) {
539 ERROR (3027, "unbalanced parentheses", NO_TEXT);
540 }
541 skip_card (FALSE);
542 } else if (rc == WORD) {
543 // Single-word extensions EXIT, CYCLE, BREAK, etcetera.
544 SAVE_POS (1);
545 rc = scan (EXPECT_NONE);
546 if (rc == END_OF_LINE || rc == END_OF_MODULE) {
547 RESTORE_POS (1);
548 // RECCPY (curlex, prelex);
549 vif_extensions ();
550 } else {
551 UNSCAN;
552 // Primary - Assignation or call
553 EXPR reg;
554 MODE mode;
555 cpp_direct (nprocs, prelin, BODY);
556 (void) impl_decl (curlex, &mode);
557 memset (®, 0, sizeof (EXPR));
558 assign (®);
559 code (nprocs, BODY, reg.str);
560 code (nprocs, BODY, ";\n");
561 skip_card (FALSE);
562 }
563 }
564 }
565
566 void gen_statements (LBL * dolbl, int_4 depth)
567 {
568 int_4 rc;
569 while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
570 macro_depth = 0;
571 // Common mistakes.
572 if (TOKEN ("program") && IS_NOT_ASSIGNMENT) {
573 ERROR (3028, "check for missing END statement", NO_TEXT);
574 } else if (TOKEN ("function") && IS_NOT_ASSIGNMENT) {
575 ERROR (3029, "check for missing END statement", NO_TEXT);
576 } else if (TOKEN ("subroutine") && IS_NOT_ASSIGNMENT) {
577 ERROR (3030, "check for missing END statement", NO_TEXT);
578 } else if (TOKEN ("block") && IS_NOT_ASSIGNMENT) {
579 ERROR (3031, "check for missing END statement", NO_TEXT);
580 }
581 // FORTRAN statements.
582 LBL *statlbl = NO_LABEL;
583 if (rc == LABEL) {
584 NEW_RECORD (str);
585 statlbl = lbl = find_label (curlex);
586 if (lbl == NO_LABEL) {
587 ERROR (3032, "no such label", curlex);
588 } else {
589 _srecordf (str, "_l%d:;\n", lbl->num);
590 lbl->patch = code (nprocs, BODY, str);
591 }
592 rc = scan (EXPECT_NONE);
593 if (TOKEN ("continue")) {
594 continue; // Sic!
595 }
596 }
597 _srecordf (stat_start, "%s:%s:%d", libnam, modnam, CUR_LIN.num);
598 if (rc == DECLAR) {
599 ERROR (3033, "declaration amidst executable statements", NO_TEXT);
600 } else if (TOKEN ("assign")) {
601 // ASSIGN statement, from before the Chicxulub impact.
602 // Relic from when computers had no way to organize subroutine calls.
603 rc = scan (EXPECT_LABEL);
604 if (rc != LABEL) {
605 SYNTAX (3034, "label expected");
606 } else {
607 LBL *slbl = find_label (curlex);
608 if (slbl == NO_LABEL) {
609 ERROR (3035, "no such label", NO_TEXT);
610 }
611 rc = scan ("to");
612 EXPR reg;
613 rc = scan (EXPECT_NONE);
614 macro_depth = 0;
615 express (®, INTEGER, 4);
616 NEW_RECORD (str);
617 _srecordf (str, "%s = %d;\n", reg.str, slbl->index);
618 code (nprocs, BODY, str);
619 }
620 skip_card (FALSE);
621 } else if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
622 skip_card (FALSE);
623 end_statements++;
624 // END is not executable.
625 NEW_RECORD (str);
626 if (depth != 0) {
627 SYNTAX (3036, "end must end a subprogram");
628 abend = TRUE;
629 }
630 // Peephole optimisation, END following RETURN which is typical.
631 if (n_c_src > 0) {
632 C_SRC *lin = &object[n_c_src - 1];
633 if (EQUAL (lin->text, RETURN)) {
634 lin->text = NO_TEXT;
635 labels[0].jumped--;
636 }
637 }
638 // Return.
639 labels[0].patch = code (nprocs, BODY, "_l0:;\n");
640 _srecordf (str, "__calls[%d].calls++;\n", nprocs - 1);
641 code (nprocs, BODY, str);
642 if (func) {
643 _srecordf (str, "return %s;\n", retnam);
644 } else {
645 _srecordf (str, "return 0;\n");
646 }
647 cpp_direct (nprocs, prelin, BODY);
648 code (nprocs, BODY, str);
649 return;
650 } else if (TOKEN ("elseif") && IS_NOT_ASSIGNMENT) {
651 if (depth > 0) {
652 return;
653 } else {
654 SYNTAX (3037, "stray symbol");
655 }
656 } else if (TOKEN ("else") && IS_NOT_ASSIGNMENT) {
657 if (depth > 0) {
658 return;
659 } else {
660 SYNTAX (3038, "stray symbol");
661 }
662 } else if (TOKEN ("endif") && IS_NOT_ASSIGNMENT) {
663 if (depth > 0) {
664 return;
665 } else {
666 SYNTAX (3039, "stray symbol");
667 }
668 } else if (TOKEN ("until") && IS_NOT_ASSIGNMENT) {
669 NEW_RECORD (str);
670 rc = scan ("(");
671 EXPR reg;
672 rc = scan (EXPECT_NONE);
673 macro_depth = 0;
674 express (®, NOTYPE, NOLEN);
675 rc = scan (")");
676 if (reg.mode.type != LOGICAL) {
677 EXPECT (3040, "logical expression");
678 }
679 _srecordf (str, "if (%s) {\n", reg.str);
680 code (nprocs, BODY, str);
681 _srecordf (str, "break;\n");
682 code (nprocs, BODY, str);
683 _srecordf (str, "}\n");
684 code (nprocs, BODY, str);
685 skip_card (FALSE);
686 } else if (TOKEN ("if") && IS_NOT_ASSIGNMENT) {
687 cpp_direct (nprocs, prelin, BODY);
688 conditional (depth, TRUE);
689 } else if (TOKEN ("do") && IS_NOT_ASSIGNMENT) {
690 // DO
691 cpp_direct (nprocs, prelin, BODY);
692 do_loop (dolbl, depth);
693 skip_card (FALSE);
694 } else if (TOKEN ("enddo") && IS_NOT_ASSIGNMENT) {
695 if (dolbl != NO_LABEL) {
696 ERROR (3041, "misplaced end do", NO_TEXT);
697 }
698 if (depth > 0) {
699 return;
700 } else {
701 SYNTAX (3042, "stray symbol");
702 }
703 } else if (TOKEN ("format") && IS_NOT_ASSIGNMENT) {
704 cpp_direct (nprocs, prelin, FMT);
705 format (statlbl);
706 skip_card (FALSE);
707 } else {
708 executable ();
709 }
710 // Return for DO loop (ending label reached).
711 if (dolbl != NO_LABEL && lbl != NO_LABEL && dolbl->num == lbl->num) {
712 if (depth == 0) {
713 BUG ("nesting");
714 }
715 return;
716 }
717 }
718 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
