modules.c
1 //! @file modules.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 BLOCK DATA, FUNCTION, PROGRAM and SUBROUTINE.
25
26 #include <vif.h>
27
28 #define ALLOW_ANON (nprocs >= 0)
29
30 int_4 aborted;
31 int_4 nmodules = 0;
32 char *modules[MAX_MODULES];
33
34 void common_errors (int_4 *nest)
35 {
36 NEW_RECORD (str);
37 _srecordf (str, "%s %s", prelex, curlex);
38 if (TOKEN ("(")) {
39 (*nest)++;
40 } else if (TOKEN (")")) {
41 (*nest)--;
42 } else if (strlen (curlex) == 1 && strchr ("{}[];\\?~`@#$%", curlex[0]) != NO_TEXT) {
43 SYNTAX (2601, "stray symbol");
44 } else if (preret == WORD && curret == WORD) {
45 if (!reserved (prelex)) {
46 ADJACENT (2602, str);
47 }
48 } else if (IS_NUMBER (preret) && IS_NUMBER (curret)) {
49 ADJACENT (2603, str);
50 }
51 }
52
53 void skip_to_end (void)
54 {
55 int_4 rc, go_on = TRUE;
56 while (go_on && (rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
57 if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
58 go_on = FALSE;
59 } else {
60 rc = scan (EXPECT_NONE);
61 while (WITHIN) {
62 rc = scan (EXPECT_NONE);
63 }
64 }
65 }
66 aborted = TRUE;
67 }
68
69 void prescan (void)
70 {
71 SAVE_POS (1);
72 int_4 rc, go_on = TRUE;
73 while (go_on && (rc = scan (EXPECT_NONE)) != END_OF_MODULE) {
74 LBL *statlbl = NO_LABEL;
75 if (curlex[0] == '\0') {
76 continue;
77 }
78 if (rc == LABEL) {
79 sscanf (curlex, "%d", &CUR_LIN.label);
80 if (nlabels >= MAX_LABELS) {
81 ERROR (2604, "too many labels", NO_TEXT);
82 }
83 for (int_4 k = 1; k < nlabels; k++) {
84 if (labels[k].num == CUR_LIN.label) {
85 ERROR (2605, "duplicate label", curlex);
86 break;
87 }
88 }
89 statlbl = &labels[nlabels];
90 statlbl->index = nlabels;
91 statlbl->num = CUR_LIN.label;
92 statlbl->line = curlin;
93 statlbl->nonexe = FALSE;
94 statlbl->data = FALSE;
95 statlbl->format = FALSE;
96 statlbl->jumped = FALSE;
97 statlbl->renum = nlabels++;
98 rc = scan (EXPECT_NONE);
99 }
100 if (TOKEN ("end") && IS_NOT_ASSIGNMENT) {
101 go_on = FALSE;
102 } else if (TOKEN ("data") && IS_NOT_ASSIGNMENT) {
103 if (statlbl != NO_LABEL) {
104 statlbl->nonexe = TRUE;
105 statlbl->data = TRUE;
106 }
107 skip_card (FALSE);
108 } else if (TOKEN ("format") && IS_NOT_ASSIGNMENT) {
109 if (statlbl == NO_LABEL) {
110 ERROR (2606, "format statement needs a label", NO_TEXT);
111 } else {
112 statlbl->nonexe = TRUE;
113 statlbl->format = TRUE;
114 }
115 skip_card (FALSE);
116 } else {
117 int_4 nest = 0;
118 rc = scan (EXPECT_NONE);
119 while (WITHIN) {
120 common_errors (&nest);
121 rc = scan (EXPECT_NONE);
122 }
123 if (nest != 0) {
124 SYNTAX (2607, "unbalanced parentheses");
125 }
126 }
127 }
128 RESTORE_POS (1);
129 }
130
131 void code_args (int_4 proc, int_4 phase)
132 {
133 int_4 rc;
134 code (proc, phase, procnam);
135 code (proc, phase, " ");
136 rc = scan (EXPECT_NONE);
137 if (TOKEN ("(")) {
138 rc = scan (EXPECT_NONE);
139 if (TOKEN (")")) {
140 code (proc, phase, "(void)");
141 } else if (rc == WORD) {
142 int_4 go_on;
143 code (proc, phase, "(");
144 do {
145 int_4 apatch = code (proc, phase, NO_TEXT);
146 if (rc == WORD) {
147 add_local (curlex, NOTYPE, NOLEN, UNIQ, apatch, ARG, LOCAL, SOURCE);
148 } else {
149 EXPECT (2608, "variable");
150 }
151 rc = scan (EXPECT_NONE);
152 if (TOKEN (",")) {
153 go_on = TRUE;
154 code (proc, phase, ", ");
155 rc = scan (EXPECT_NONE);
156 } else if (TOKEN (")")) {
157 go_on = FALSE;
158 code (proc, phase, ")");
159 } else {
160 go_on = FALSE;
161 EXPECT (2609, ", or )");
162 }
163 } while (go_on);
164 }
165 } else {
166 code (proc, phase, "(void)");
167 }
168 (void) rc;
169 skip_card (FALSE);
170 }
171
172 void gen_code (void)
173 {
174 // Generate code for one module.
175 code (nprocs, TITLE, newpage (modnam, "generated-code"));
176 if (!no_source) {
177 code (nprocs, PARAMETERS, newpage (modnam, "parameters"));
178 }
179 code (nprocs, MESSAGES, newpage (modnam, "diagnostics"));
180 merrors = 0;
181 prescan ();
182 //
183 SAVE_POS (1);
184 if (merrors == 0) {
185 get_impl ();
186 RESTORE_POS (1);
187 get_decls ();
188 RESTORE_POS (1);
189 decl_autosave ();
190 RESTORE_POS (1);
191 decl_equiv ();
192 merge_commons ();
193 RESTORE_POS (1);
194 decl_data ();
195 }
196 if (merrors == 0) {
197 idfs_unused ();
198 RESTORE_POS (1);
199 decl_macros ();
200 } else {
201 skip_to_end ();
202 return;
203 }
204 if (merrors == 0) {
205 gen_statements (NO_LABEL, 0);
206 code_idfs (locals, nlocals, LOCAL, nprocs, DECL);
207 code_exts (locals, nlocals, LOCAL, nprocs, DECL);
208 } else {
209 skip_to_end ();
210 return;
211 }
212 if (merrors == 0) {
213 patch_args ();
214 }
215 }
216
217 void gen_program (void)
218 {
219 int_4 rc;
220 // PROGRAM
221 nprocs++;
222 code (0, PROTOTYPE, "\n");
223 code (0, PROTOTYPE, "prototype int_4 ");
224 code (nprocs, PRE, "int_4 ");
225 SAVE_POS (1);
226 rc = scan (EXPECT_NONE);
227 if (rc != WORD) {
228 ERROR (2610, "missing name for ", "program");
229 RECCPY (modnam, "program");
230 } else {
231 RECCPY (modnam, curlex);
232 }
233 _srecordf (procnam, "%s", edit_f (modnam));
234 RECCPY (retnam, "");
235 if (strlen (program) == 0) {
236 RECCPY (program, procnam);
237 } else {
238 ERROR (2611, "redefinition", "program");
239 }
240 code_args (0, PROTOTYPE);
241 code (0, PROTOTYPE, ";");
242 RESTORE_POS (1);
243 rc = scan (EXPECT_NONE);
244 code_args (nprocs, PRE);
245 code (nprocs, PRE, "\n");
246 code (nprocs, PRE, "{\n");
247 cpp_direct (nprocs, prelin, PRE);
248 gen_code ();
249 code (nprocs, POST, "}");
250 }
251
252 void gen_anon_program (void)
253 {
254 if (! ALLOW_ANON) {
255 EXPECT (2612, "valid subprogram");
256 return;
257 }
258 if (nprocs == 0) {
259 curlin = 1;
260 }
261 curcol = START_OF_LINE;
262 nprocs++;
263 RECCPY (modnam, "anonymous");
264 _srecordf (procnam, "%s", edit_f (modnam));
265 RECCPY (retnam, "");
266 if (strlen (program) == 0) {
267 RECCPY (program, procnam);
268 } else {
269 ERROR (2613, "redefinition", "program");
270 }
271 code (0, PROTOTYPE, "\n");
272 code (0, PROTOTYPE, "prototype int_4 ");
273 code (0, PROTOTYPE, procnam);
274 code (0, PROTOTYPE, " (void);");
275 code (nprocs, PRE, "int_4 ");
276 code (nprocs, PRE, procnam);
277 code (nprocs, PRE, " (void)");
278 code (nprocs, PRE, "\n");
279 code (nprocs, PRE, "{\n");
280 cpp_direct (nprocs, prelin, PRE);
281 gen_code ();
282 code (nprocs, POST, "}");
283 }
284
285 void gen_subroutine (void)
286 {
287 // SUBROUTINE
288 int_4 rc;
289 nprocs++;
290 code (0, PROTOTYPE, "\n");
291 if (compile_only || optimise < 3) {
292 code (0, PROTOTYPE, "prototype int_4 ");
293 code (nprocs, PRE, "int_4 ");
294 } else {
295 code (0, PROTOTYPE, "prototype static inline int_4 ");
296 code (nprocs, PRE, "static inline int_4 ");
297 }
298 SAVE_POS (1);
299 rc = scan (EXPECT_NONE);
300 if (rc != WORD) {
301 ERROR (2614, "missing name for ", "subroutine");
302 RECCPY (modnam, "routine");
303 } else {
304 RECCPY (modnam, curlex);
305 }
306 _srecordf (procnam, "%s", edit_f (modnam));
307 RECCPY (retnam, "");
308 code_args (0, PROTOTYPE);
309 code (0, PROTOTYPE, ";");
310 RESTORE_POS (1);
311 rc = scan (EXPECT_NONE);
312 code_args (nprocs, PRE);
313 code (nprocs, PRE, "\n");
314 code (nprocs, PRE, "{\n");
315 cpp_direct (nprocs, prelin, PRE);
316 gen_code ();
317 code (nprocs, POST, "}");
318 }
319
320 void gen_block_data (void)
321 {
322 // BLOCK DATA
323 NEW_RECORD (str);
324 int_4 rc = scan (EXPECT_NONE);
325 nprocs++;
326 if (!TOKEN ("data")) {
327 EXPECT (2615, "block data");
328 }
329 rc = scan (EXPECT_NONE);
330 if (prelin == curlin) {
331 RECCPY (modnam, curlex);
332 rc = scan (EXPECT_NONE);
333 } else {
334 RECCPY (modnam, "block_data");
335 }
336 RECCPY (retnam, "");
337 _srecordf (block, "%s", edit_f (modnam));
338 if (compile_only || optimise < 3) {
339 _srecordf (str, "int_4 %s (void)", block);
340 } else {
341 _srecordf (str, "static inline int_4 %s (void)", block);
342 }
343 code (0, PROTOTYPE, "\n");
344 code (0, PROTOTYPE, "prototype ");
345 code (0, PROTOTYPE, str);
346 code (0, PROTOTYPE, ";");
347 code (nprocs, PRE, str);
348 code (nprocs, PRE, "{\n");
349 cpp_direct (nprocs, prelin, PRE);
350 gen_code ();
351 code (nprocs, POST, "}");
352 (void) rc;
353 }
354
355 void gen_function (void)
356 {
357 int_4 rc;
358 // FUNCTION with implicit type.
359 int_4 patchp, patchf;
360 SAVE_POS (1);
361 IDENT *ret;
362 NEW_RECORD (str);
363 nprocs++;
364 func = TRUE;
365 code (0, PROTOTYPE, "\n");
366 code (0, PROTOTYPE, "prototype ");
367 if (compile_only == FALSE || optimise >= 3) {
368 code (0, PROTOTYPE, "static inline ");
369 }
370 patchp = code (0, PROTOTYPE, NO_TEXT);
371 code (0, PROTOTYPE, " ");
372 if (compile_only == FALSE || optimise >= 3) {
373 code (nprocs, PRE, "static inline ");
374 }
375 patchf = code (nprocs, PRE, NO_TEXT);
376 code (nprocs, PRE, " ");
377 rc = scan (EXPECT_NONE);
378 if (rc != WORD) {
379 ERROR (2616, "missing name for ", "function");
380 RECCPY (modnam, "function");
381 } else {
382 RECCPY (modnam, curlex);
383 }
384 _srecordf (procnam, "%s", edit_f (modnam));
385 ret = add_local (modnam, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
386 ret->mode.fun = TRUE;
387 ret->mode.save = AUTOMATIC;
388 _srecordf (retnam, "%s", C_NAME (ret));
389 code_args (0, PROTOTYPE);
390 code (0, PROTOTYPE, ";");
391 RESTORE_POS (1);
392 rc = scan (EXPECT_NONE);
393 code_args (nprocs, PRE);
394 code (nprocs, PRE, "\n");
395 code (nprocs, PRE, "{\n");
396 cpp_direct (nprocs, prelin, PRE);
397 gen_code ();
398 code (nprocs, POST, "}\n");
399 _srecordf (str, "%s", wtype (&ret->mode, NOARG, FUN));
400 patch (patchp, str);
401 patch (patchf, str);
402 }
403
404 MODE gen_typed_function (void)
405 {
406 int_4 rc;
407 // TYPE FUNCTION
408 MODE mode;
409 f2c_type (curlex, &mode, NOARG, NOFUN);
410 rc = scan (EXPECT_NONE);
411 if (!TOKEN ("function")) {
412 mode.type = NOTYPE;
413 mode.len = 0;
414 return mode;
415 } else {
416 SAVE_POS (1);
417 IDENT *ret;
418 nprocs++;
419 func = TRUE;
420 code (0, PROTOTYPE, "\n");
421 code (0, PROTOTYPE, "prototype ");
422 if (compile_only == FALSE || optimise >= 3) {
423 code (0, PROTOTYPE, "static inline ");
424 }
425 code (0, PROTOTYPE, f2c_type (prelex, NO_MODE, NOARG, FUN));
426 code (0, PROTOTYPE, " ");
427 if (compile_only == FALSE || optimise >= 3) {
428 code (nprocs, PRE, "static inline ");
429 }
430 code (nprocs, PRE, f2c_type (prelex, NO_MODE, NOARG, FUN));
431 code (nprocs, PRE, " ");
432 rc = scan (EXPECT_NONE);
433 if (rc != WORD) {
434 ERROR (2617, "missing name for ", "function");
435 RECCPY (modnam, "function");
436 } else {
437 RECCPY (modnam, curlex);
438 }
439 _srecordf (procnam, "%s", edit_f (modnam));
440 ret = add_local (modnam, mode.type, mode.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
441 ret->mode.fun = TRUE;
442 ret->mode.save = AUTOMATIC;
443 _srecordf (retnam, "%s", C_NAME (ret));
444 code_args (0, PROTOTYPE);
445 code (0, PROTOTYPE, ";");
446 RESTORE_POS (1);
447 rc = scan (EXPECT_NONE);
448 code_args (nprocs, PRE);
449 code (nprocs, PRE, "\n");
450 code (nprocs, PRE, "{\n");
451 cpp_direct (nprocs, prelin, PRE);
452 gen_code ();
453 code (nprocs, POST, "}");
454 }
455 return mode;
456 }
457
458 void subprograms (void)
459 {
460 int_4 rc;
461 NEW_RECORD (type);
462 NEW_RECORD (kind);
463 NEW_RECORD (str);
464 NEW_RECORD (endof);
465 while (!abend) {
466 SAVE_POS (1);
467 rc = scan (EXPECT_NONE);
468 if (rc == END_OF_MODULE) {
469 break;
470 }
471 nlocals = 0;
472 type[0] = '\0';
473 // Label '0' is the label for subprogram exit.
474 labels[0].num = 0;
475 labels[0].line = 0;
476 labels[0].jumped = FALSE;
477 nlabels = 1;
478 //
479 lbl = NO_LABEL;
480 nloctmps = 0;
481 func = FALSE;
482 if (rc == END_OF_LINE) {
483 continue;
484 }
485 kind[0] = '\0';
486 end_statements = 0;
487 aborted = FALSE;
488 if (rc == WORD) {
489 if (TOKEN ("program")) {
490 bufcpy (kind, "program", RECLN);
491 gen_program ();
492 } else if (TOKEN ("subroutine")) {
493 bufcpy (kind, "subroutine", RECLN);
494 gen_subroutine ();
495 if (renum && merrors == 0) {
496 RESTORE_POS (1);
497 tidy_source (procnam);
498 }
499 } else if (TOKEN ("block")) {
500 bufcpy (kind, "block data", RECLN);
501 gen_block_data ();
502 if (renum && merrors == 0) {
503 RESTORE_POS (1);
504 tidy_source (procnam);
505 }
506 } else if (TOKEN ("function")) {
507 bufcpy (kind, "function", RECLN);
508 gen_function ();
509 if (renum && merrors == 0) {
510 RESTORE_POS (1);
511 tidy_source (procnam);
512 }
513 } else {
514 if (ALLOW_ANON) {
515 gen_anon_program ();
516 bufcpy (kind, "program", RECLN);
517 if (renum && merrors == 0) {
518 RESTORE_POS (1);
519 tidy_source (procnam);
520 }
521 }
522 }
523 } else if (rc == DECLAR) {
524 bufcpy (kind, "function", RECLN);
525 MODE ret = gen_typed_function ();
526 if (ret.type == NOTYPE && ALLOW_ANON) {
527 gen_anon_program ();
528 bufcpy (kind, "program", RECLN);
529 } else {
530 _srecordf (type, qtype (&ret));
531 }
532 if (renum && merrors == 0) {
533 RESTORE_POS (1);
534 tidy_source (procnam);
535 }
536 // } else if (rc == LABEL) {
537 // WARNING (2618, "ignored label", curlex);
538 } else {
539 if (ALLOW_ANON) {
540 gen_anon_program ();
541 bufcpy (kind, "program", RECLN);
542 if (renum && merrors == 0) {
543 RESTORE_POS (1);
544 tidy_source (procnam);
545 }
546 } else {
547 EXPECT (2619, "valid subprogram");
548 }
549 return;
550 }
551 if (!aborted && end_statements == 0) {
552 EXPECT (2620, "end statement");
553 }
554 if (nprocs == 0) {
555 // BUG ("no subprogram found");
556 FATAL (2621, "no subprogram", "check program statement");
557 }
558 // Prune 'sleeping' labels.
559 for (int_4 k = 0; k < nlabels; k++) {
560 LBL *L = &labels[k];
561 if (!L->jumped) {
562 patch (L->patch, NO_TEXT);
563 }
564 }
565 //
566 if (nprocs == pnprocs) {
567 FATAL (2622, "invalid fortran source", modnam);
568 }
569 NEW_RECORD (sub);
570 _srecordf (endof, "** %-10s ** end of compilation %d", _bufsub (sub, modnam, 1, 10), nprocs);
571 pnprocs = nprocs;
572 code (nprocs, BANNER, newpage (modnam, modnam));
573 if (strlen (type) > 0) {
574 banner (nprocs, BANNER, _strupper (type));
575 code (nprocs, BANNER, "\n");
576 _srecordf (str, " {\"%s\", 0}, // %s %s\n", modnam, type, kind);
577 code (0, FREQ, str);
578 } else {
579 _srecordf (str, " {\"%s\", 0}, // %s\n", modnam, kind);
580 code (0, FREQ, str);
581 }
582 banner (nprocs, BANNER, _strupper (kind));
583 code (nprocs, BANNER, "\n");
584 banner (nprocs, BANNER, _strupper (modnam));
585 code (nprocs, BANNER, "\n");
586 if (!quiet_mode) {
587 diagnostic (nprocs, endof);
588 }
589 proc_listing (nprocs);
590 }
591 }
592
593 logical_4 find_module (char *name)
594 {
595 for (int_4 k = 0; k < nmodules; k++) {
596 if (same_name (name, modules[k])) {
597 return TRUE;
598 }
599 }
600 return FALSE;
601 }
602
603 void list_module (void)
604 {
605 int_4 rc = scan (EXPECT_NONE);
606 if (rc == WORD) {
607 if (nmodules >= MAX_MODULES) {
608 FATAL (2623, "too many modules", NO_TEXT);
609 }
610 modules[nmodules++] = f_stralloc (curlex);
611 } else {
612 ERROR (2624, "missing name", "module");
613 }
614 }
615
616 void scan_modules (void)
617 {
618 int_4 rc;
619 while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE && !abend) {
620 if (rc == WORD) {
621 if (TOKEN ("program")) {
622 list_module ();
623 } else if (TOKEN ("subroutine")) {
624 list_module ();
625 } else if (TOKEN ("function")) {
626 list_module ();
627 } else if (rc == DECLAR) {
628 rc = scan (EXPECT_NONE);
629 if (TOKEN ("function")) {
630 list_module ();
631 }
632 } else if (TOKEN ("block")) {
633 rc = scan (EXPECT_NONE);
634 if (TOKEN ("data")) {
635 list_module ();
636 }
637 }
638 }
639 }
640 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
