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