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