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