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 code (nprocs, PARAMETERS, newpage (modnam, "parameters"));
177 code (nprocs, MESSAGES, newpage (modnam, "diagnostics"));
178 merrors = 0;
179 prescan ();
180 //
181 SAVE_POS (1);
182 if (merrors == 0) {
183 get_impl ();
184 RESTORE_POS (1);
185 get_decls ();
186 RESTORE_POS (1);
187 decl_autosave ();
188 RESTORE_POS (1);
189 decl_equiv ();
190 merge_commons ();
191 RESTORE_POS (1);
192 decl_data ();
193 }
194 if (merrors == 0) {
195 idfs_unused ();
196 RESTORE_POS (1);
197 decl_macros ();
198 } else {
199 skip_to_end ();
200 return;
201 }
202 if (merrors == 0) {
203 gen_statements (NO_LABEL, 0);
204 code_idfs (locals, nlocals, LOCAL, nprocs, DECL);
205 code_exts (locals, nlocals, LOCAL, nprocs, DECL);
206 } else {
207 skip_to_end ();
208 return;
209 }
210 if (merrors == 0) {
211 patch_args ();
212 }
213 }
214
215 void gen_program (void)
216 {
217 int_4 rc;
218 // PROGRAM
219 nprocs++;
220 code (0, PROTOTYPE, "\n");
221 code (0, PROTOTYPE, "prototype int_4 ");
222 code (nprocs, PRE, "int_4 ");
223 SAVE_POS (1);
224 rc = scan (EXPECT_NONE);
225 if (rc != WORD) {
226 ERROR (2610, "missing name for ", "program");
227 RECCPY (modnam, "program");
228 } else {
229 RECCPY (modnam, curlex);
230 }
231 _srecordf (procnam, "%s", edit_f (modnam));
232 RECCPY (retnam, "");
233 if (strlen (program) == 0) {
234 RECCPY (program, procnam);
235 } else {
236 ERROR (2611, "redefinition", "program");
237 }
238 code_args (0, PROTOTYPE);
239 code (0, PROTOTYPE, ";");
240 RESTORE_POS (1);
241 rc = scan (EXPECT_NONE);
242 code_args (nprocs, PRE);
243 code (nprocs, PRE, "\n");
244 code (nprocs, PRE, "{\n");
245 cpp_direct (nprocs, prelin, PRE);
246 gen_code ();
247 code (nprocs, POST, "}");
248 }
249
250 void gen_anon_program (void)
251 {
252 if (! ALLOW_ANON) {
253 EXPECT (2612, "valid subprogram");
254 return;
255 }
256 if (nprocs == 0) {
257 curlin = 1;
258 }
259 curcol = START_OF_LINE;
260 nprocs++;
261 RECCPY (modnam, "anonymous");
262 _srecordf (procnam, "%s", edit_f (modnam));
263 RECCPY (retnam, "");
264 if (strlen (program) == 0) {
265 RECCPY (program, procnam);
266 } else {
267 ERROR (2613, "redefinition", "program");
268 }
269 code (0, PROTOTYPE, "\n");
270 code (0, PROTOTYPE, "prototype int_4 ");
271 code (0, PROTOTYPE, procnam);
272 code (0, PROTOTYPE, " (void);");
273 code (nprocs, PRE, "int_4 ");
274 code (nprocs, PRE, procnam);
275 code (nprocs, PRE, " (void)");
276 code (nprocs, PRE, "\n");
277 code (nprocs, PRE, "{\n");
278 cpp_direct (nprocs, prelin, PRE);
279 gen_code ();
280 code (nprocs, POST, "}");
281 }
282
283 void gen_subroutine (void)
284 {
285 // SUBROUTINE
286 int_4 rc;
287 nprocs++;
288 code (0, PROTOTYPE, "\n");
289 if (compile_only || optimise < 3) {
290 code (0, PROTOTYPE, "prototype int_4 ");
291 code (nprocs, PRE, "int_4 ");
292 } else {
293 code (0, PROTOTYPE, "prototype static inline int_4 ");
294 code (nprocs, PRE, "static inline int_4 ");
295 }
296 SAVE_POS (1);
297 rc = scan (EXPECT_NONE);
298 if (rc != WORD) {
299 ERROR (2614, "missing name for ", "subroutine");
300 RECCPY (modnam, "routine");
301 } else {
302 RECCPY (modnam, curlex);
303 }
304 _srecordf (procnam, "%s", edit_f (modnam));
305 RECCPY (retnam, "");
306 code_args (0, PROTOTYPE);
307 code (0, PROTOTYPE, ";");
308 RESTORE_POS (1);
309 rc = scan (EXPECT_NONE);
310 code_args (nprocs, PRE);
311 code (nprocs, PRE, "\n");
312 code (nprocs, PRE, "{\n");
313 cpp_direct (nprocs, prelin, PRE);
314 gen_code ();
315 code (nprocs, POST, "}");
316 }
317
318 void gen_block_data (void)
319 {
320 // BLOCK DATA
321 NEW_RECORD (str);
322 int_4 rc = scan (EXPECT_NONE);
323 nprocs++;
324 if (!TOKEN ("data")) {
325 EXPECT (2615, "block data");
326 }
327 rc = scan (EXPECT_NONE);
328 if (prelin == curlin) {
329 RECCPY (modnam, curlex);
330 rc = scan (EXPECT_NONE);
331 } else {
332 RECCPY (modnam, "block_data");
333 }
334 RECCPY (retnam, "");
335 _srecordf (block, "%s", edit_f (modnam));
336 if (compile_only || optimise < 3) {
337 _srecordf (str, "int_4 %s (void)", block);
338 } else {
339 _srecordf (str, "static inline int_4 %s (void)", block);
340 }
341 code (0, PROTOTYPE, "\n");
342 code (0, PROTOTYPE, "prototype ");
343 code (0, PROTOTYPE, str);
344 code (0, PROTOTYPE, ";");
345 code (nprocs, PRE, str);
346 code (nprocs, PRE, "{\n");
347 cpp_direct (nprocs, prelin, PRE);
348 gen_code ();
349 code (nprocs, POST, "}");
350 (void) rc;
351 }
352
353 void gen_function (void)
354 {
355 int_4 rc;
356 // FUNCTION with implicit type.
357 int_4 patchp, patchf;
358 SAVE_POS (1);
359 IDENT *ret;
360 NEW_RECORD (str);
361 nprocs++;
362 func = TRUE;
363 code (0, PROTOTYPE, "\n");
364 code (0, PROTOTYPE, "prototype ");
365 if (compile_only == FALSE || optimise >= 3) {
366 code (0, PROTOTYPE, "static inline ");
367 }
368 patchp = code (0, PROTOTYPE, NO_TEXT);
369 code (0, PROTOTYPE, " ");
370 if (compile_only == FALSE || optimise >= 3) {
371 code (nprocs, PRE, "static inline ");
372 }
373 patchf = code (nprocs, PRE, NO_TEXT);
374 code (nprocs, PRE, " ");
375 rc = scan (EXPECT_NONE);
376 if (rc != WORD) {
377 ERROR (2616, "missing name for ", "function");
378 RECCPY (modnam, "function");
379 } else {
380 RECCPY (modnam, curlex);
381 }
382 _srecordf (procnam, "%s", edit_f (modnam));
383 ret = add_local (modnam, NOTYPE, NOLEN, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
384 ret->mode.fun = TRUE;
385 ret->mode.save = AUTOMATIC;
386 _srecordf (retnam, "%s", C_NAME (ret));
387 code_args (0, PROTOTYPE);
388 code (0, PROTOTYPE, ";");
389 RESTORE_POS (1);
390 rc = scan (EXPECT_NONE);
391 code_args (nprocs, PRE);
392 code (nprocs, PRE, "\n");
393 code (nprocs, PRE, "{\n");
394 cpp_direct (nprocs, prelin, PRE);
395 gen_code ();
396 code (nprocs, POST, "}\n");
397 _srecordf (str, "%s", wtype (&ret->mode, NOARG, FUN));
398 patch (patchp, str);
399 patch (patchf, str);
400 }
401
402 MODE gen_typed_function (void)
403 {
404 int_4 rc;
405 // TYPE FUNCTION
406 MODE mode;
407 f2c_type (curlex, &mode, NOARG, NOFUN);
408 rc = scan (EXPECT_NONE);
409 if (!TOKEN ("function")) {
410 mode.type = NOTYPE;
411 mode.len = 0;
412 return mode;
413 } else {
414 SAVE_POS (1);
415 IDENT *ret;
416 nprocs++;
417 func = TRUE;
418 code (0, PROTOTYPE, "\n");
419 code (0, PROTOTYPE, "prototype ");
420 if (compile_only == FALSE || optimise >= 3) {
421 code (0, PROTOTYPE, "static inline ");
422 }
423 code (0, PROTOTYPE, f2c_type (prelex, NO_MODE, NOARG, FUN));
424 code (0, PROTOTYPE, " ");
425 if (compile_only == FALSE || optimise >= 3) {
426 code (nprocs, PRE, "static inline ");
427 }
428 code (nprocs, PRE, f2c_type (prelex, NO_MODE, NOARG, FUN));
429 code (nprocs, PRE, " ");
430 rc = scan (EXPECT_NONE);
431 if (rc != WORD) {
432 ERROR (2617, "missing name for ", "function");
433 RECCPY (modnam, "function");
434 } else {
435 RECCPY (modnam, curlex);
436 }
437 _srecordf (procnam, "%s", edit_f (modnam));
438 ret = add_local (modnam, mode.type, mode.len, UNIQ, NOPATCH, NOARG, LOCAL, SOURCE);
439 ret->mode.fun = TRUE;
440 ret->mode.save = AUTOMATIC;
441 _srecordf (retnam, "%s", C_NAME (ret));
442 code_args (0, PROTOTYPE);
443 code (0, PROTOTYPE, ";");
444 RESTORE_POS (1);
445 rc = scan (EXPECT_NONE);
446 code_args (nprocs, PRE);
447 code (nprocs, PRE, "\n");
448 code (nprocs, PRE, "{\n");
449 cpp_direct (nprocs, prelin, PRE);
450 gen_code ();
451 code (nprocs, POST, "}");
452 }
453 return mode;
454 }
455
456 void subprograms (void)
457 {
458 int_4 rc;
459 NEW_RECORD (type);
460 NEW_RECORD (kind);
461 NEW_RECORD (str);
462 NEW_RECORD (endof);
463 while (!abend) {
464 SAVE_POS (1);
465 rc = scan (EXPECT_NONE);
466 if (rc == END_OF_MODULE) {
467 break;
468 }
469 nlocals = 0;
470 type[0] = '\0';
471 // Label '0' is the label for subprogram exit.
472 labels[0].num = 0;
473 labels[0].line = 0;
474 labels[0].jumped = FALSE;
475 nlabels = 1;
476 //
477 lbl = NO_LABEL;
478 nloctmps = 0;
479 func = FALSE;
480 if (rc == END_OF_LINE) {
481 continue;
482 }
483 kind[0] = '\0';
484 end_statements = 0;
485 aborted = FALSE;
486 if (rc == WORD) {
487 if (TOKEN ("program")) {
488 bufcpy (kind, "program", RECLN);
489 gen_program ();
490 } else if (TOKEN ("subroutine")) {
491 bufcpy (kind, "subroutine", RECLN);
492 gen_subroutine ();
493 if (renum && merrors == 0) {
494 RESTORE_POS (1);
495 tidy_source (procnam);
496 }
497 } else if (TOKEN ("block")) {
498 bufcpy (kind, "block data", RECLN);
499 gen_block_data ();
500 if (renum && merrors == 0) {
501 RESTORE_POS (1);
502 tidy_source (procnam);
503 }
504 } else if (TOKEN ("function")) {
505 bufcpy (kind, "function", RECLN);
506 gen_function ();
507 if (renum && merrors == 0) {
508 RESTORE_POS (1);
509 tidy_source (procnam);
510 }
511 } else {
512 if (ALLOW_ANON) {
513 gen_anon_program ();
514 bufcpy (kind, "program", RECLN);
515 if (renum && merrors == 0) {
516 RESTORE_POS (1);
517 tidy_source (procnam);
518 }
519 }
520 }
521 } else if (rc == DECLAR) {
522 bufcpy (kind, "function", RECLN);
523 MODE ret = gen_typed_function ();
524 if (ret.type == NOTYPE && ALLOW_ANON) {
525 gen_anon_program ();
526 bufcpy (kind, "program", RECLN);
527 } else {
528 _srecordf (type, qtype (&ret));
529 }
530 if (renum && merrors == 0) {
531 RESTORE_POS (1);
532 tidy_source (procnam);
533 }
534 // } else if (rc == LABEL) {
535 // WARNING (2618, "ignored label", curlex);
536 } else {
537 if (ALLOW_ANON) {
538 gen_anon_program ();
539 bufcpy (kind, "program", RECLN);
540 if (renum && merrors == 0) {
541 RESTORE_POS (1);
542 tidy_source (procnam);
543 }
544 } else {
545 EXPECT (2619, "valid subprogram");
546 }
547 return;
548 }
549 if (!aborted && end_statements == 0) {
550 EXPECT (2620, "end statement");
551 }
552 if (nprocs == 0) {
553 // BUG ("no subprogram found");
554 FATAL (2621, "no subprogram", "check program statement");
555 }
556 // Prune 'sleeping' labels.
557 for (int_4 k = 0; k < nlabels; k++) {
558 LBL *L = &labels[k];
559 if (!L->jumped) {
560 patch (L->patch, NO_TEXT);
561 }
562 }
563 //
564 if (nprocs == pnprocs) {
565 FATAL (2622, "invalid fortran source", modnam);
566 }
567 NEW_RECORD (sub);
568 _srecordf (endof, "** %-10s ** end of compilation %d", _bufsub (sub, modnam, 1, 10), nprocs);
569 pnprocs = nprocs;
570 code (nprocs, BANNER, newpage (modnam, modnam));
571 if (strlen (type) > 0) {
572 banner (nprocs, BANNER, _strupper (type));
573 code (nprocs, BANNER, "\n");
574 _srecordf (str, " {\"%s\", 0}, // %s %s\n", modnam, type, kind);
575 code (0, FREQ, str);
576 } else {
577 _srecordf (str, " {\"%s\", 0}, // %s\n", modnam, kind);
578 code (0, FREQ, str);
579 }
580 banner (nprocs, BANNER, _strupper (kind));
581 code (nprocs, BANNER, "\n");
582 banner (nprocs, BANNER, _strupper (modnam));
583 code (nprocs, BANNER, "\n");
584 if (!quiet_mode) {
585 diagnostic (nprocs, endof);
586 }
587 proc_listing (nprocs);
588 }
589 }
590
591 logical_4 find_module (char *name)
592 {
593 for (int_4 k = 0; k < nmodules; k++) {
594 if (same_name (name, modules[k])) {
595 return TRUE;
596 }
597 }
598 return FALSE;
599 }
600
601 void list_module (void)
602 {
603 int_4 rc = scan (EXPECT_NONE);
604 if (rc == WORD) {
605 if (nmodules >= MAX_MODULES) {
606 FATAL (2623, "too many modules", NO_TEXT);
607 }
608 modules[nmodules++] = f_stralloc (curlex);
609 } else {
610 ERROR (2624, "missing name", "module");
611 }
612 }
613
614 void scan_modules (void)
615 {
616 int_4 rc;
617 while ((rc = scan (EXPECT_NONE)) != END_OF_MODULE && !abend) {
618 if (rc == WORD) {
619 if (TOKEN ("program")) {
620 list_module ();
621 } else if (TOKEN ("subroutine")) {
622 list_module ();
623 } else if (TOKEN ("function")) {
624 list_module ();
625 } else if (rc == DECLAR) {
626 rc = scan (EXPECT_NONE);
627 if (TOKEN ("function")) {
628 list_module ();
629 }
630 } else if (TOKEN ("block")) {
631 rc = scan (EXPECT_NONE);
632 if (TOKEN ("data")) {
633 list_module ();
634 }
635 }
636 }
637 }
638 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
