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