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