vif.c
1 //! @file vif.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-2026 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 //! VIF driver.
25
26 #include <vif.h>
27
28 int_4 MAX_FTN_LINES;
29 FTN_LINE *source, *files;
30
31 int_4 MAX_C_SRC;
32 C_SRC *object;
33
34 IDENT globals[MAX_IDENTS];
35 IDENT locals[MAX_IDENTS];
36 char *commons[MAX_COMMONS];
37 IMPLICIT implic[26];
38 LBL labels[MAX_LABELS];
39
40 int_4 strlens[MAX_STRLENS];
41
42 int_4 curlin = 1, curcol = START_OF_LINE;
43 int_4 curret, preret;
44 int_4 end_statements;
45 int_4 func;
46 int_4 indent = 0;
47 int_4 line = 0;
48 int_4 ncommons = 2; // 0 means local, 1 external
49 int_4 n_c_src = 0;
50 int_4 nfiles = 0;
51 int_4 nftnlines = 1;
52 int_4 nglobals = 0;
53 int_4 nglobtmps = 0;
54 int_4 nlabels = 0;
55 int_4 nlocals = 0;
56 int_4 nloctmps = 0;
57 int_4 optimise = 0;
58 int_4 page = 0;
59 int_4 pcalls = 0;
60 int_4 pnprocs = -1, nprocs = 0;
61 int_4 prelin, precol;
62
63 logical_4 abend = FALSE;
64 logical_4 column_72 = FALSE;
65 logical_4 compile_only = FALSE;
66 logical_4 f4_do_loops = FALSE;
67 logical_4 frequency = FALSE;
68 logical_4 gcc_ftn_lines = TRUE;
69 logical_4 hollerith = FALSE;
70 logical_4 implicit_r8 = FALSE;
71 logical_4 keep_object = FALSE;
72 logical_4 keep_listing = FALSE;
73 logical_4 load_go_erase = FALSE;
74 logical_4 load_go = FALSE;
75 logical_4 new_libnam = FALSE;
76 logical_4 new_object = FALSE;
77 logical_4 no_source = FALSE;
78 logical_4 no_warnings = FALSE;
79 logical_4 pretty = FALSE;
80 logical_4 quiet_mode = FALSE;
81 logical_4 renum = FALSE;
82 logical_4 tidy = FALSE;
83 logical_4 syntax_only = FALSE;
84 logical_4 trace = FALSE;
85 logical_4 use_strcasecmp = FALSE;
86
87 RECORD hdate;
88 RECORD hmodule, hsection;
89 RECORD libnam, modnam, procnam;
90 RECORD object_name;
91 RECORD oflags;
92 RECORD prelex, curlex, retnam;
93 RECORD program, block;
94 RECORD stat_start;
95
96 logical_4 reserved (char *lex)
97 {
98 static char *words[] = {
99 "accept", "assign", "automatic", "backspace", "call", "character",
100 "close", "common", "complex", "continue", "decode", "dimension", "data",
101 "do", "double", "else", "elseif", "encode", "end", "enddo", "endfile",
102 "endif", "entry", "external", "format", "function", "go", "goto",
103 "if", "implicit", "integer", "intrinsic", "logical", "open",
104 "pause", "precision", "print", "program", "punch", "read", "real",
105 "repeat", "return", "rewind", "save", "subroutine", "stop", "then",
106 "to", "until", "while", "write", NO_TEXT
107 };
108 for (char **sym = words; *sym != NO_TEXT; sym++) {
109 if (EQUAL (*sym, lex)) {
110 return TRUE;
111 }
112 }
113 return FALSE;
114 }
115
116 logical_4 is_int4 (char *s, int_4 *val)
117 {
118 // Is 's' an integer denotation, and what is its value?
119 char *end;
120 int_4 k = strtol (s, &end, 10);
121 int_4 rc = (end != NO_TEXT && end[0] == '\0');
122 if (val != NO_REF_INTEGER && rc) {
123 *val = k;
124 }
125 return rc;
126 }
127
128 char *date (void)
129 {
130 time_t t;
131 struct tm *info;
132 t = time ((time_t *) NULL);
133 info = localtime (&t);
134 strftime (hdate, RECLN, "%a %d-%b-%Y %H:%M:%S", info);
135 return hdate;
136 }
137
138 char *date_fn (void)
139 {
140 time_t t;
141 struct tm *info;
142 t = time ((time_t *) NULL);
143 info = localtime (&t);
144 strftime (hdate, RECLN, "%Y-%m-%d-%H-%M-%S", info);
145 return hdate;
146 }
147
148 char *tod (void)
149 {
150 static RECORD str;
151 time_t t;
152 struct tm *info;
153 t = time ((time_t *) NULL);
154 info = localtime (&t);
155 strftime (str, RECLN, "%H:%M:%S", info);
156 return str;
157 }
158
159 void prelude (int_4 argc, char **argv, char *project)
160 {
161 {
162 NEW_RECORD (usr);
163 if (getlogin_r (usr, RECLN) == 0) {
164 code (0, HEADER, newpage (usr, basename (project)));
165 } else {
166 code (0, HEADER, newpage (VERSION, project));
167 }
168 code (0, HEADER, "\n");
169 if (getlogin_r (usr, RECLN) == 0) {
170 banner (0, BANNER, _strupper (usr));
171 code (0, BANNER, "\n");
172 }
173 banner (0, BANNER, _strupper (basename (project)));
174 code (0, BANNER, "\n");
175 }
176 code (0, CONSTANTS, newpage ("global-scope", "definitions"));
177 NEW_RECORD (str);
178 code (0, CONSTANTS, "/*\nGenerated by VIF - experimental VIntage Fortran compiler.\n");
179 _srecordf (str, "VIF release %s\n*/\n\n", VERSION);
180 code (0, CONSTANTS, str);
181 // Several pragmas to relax GCC for sloppy vintage FORTRAN type checking.
182 code (0, CONSTANTS, "#if defined (__GNUC__)\n");
183 code (0, CONSTANTS, " #pragma GCC diagnostic ignored \"-Wimplicit-function-declaration\"\n");
184 code (0, CONSTANTS, " #pragma GCC diagnostic ignored \"-Wincompatible-pointer-types\"\n");
185 code (0, CONSTANTS, " #if (__GNUC__ >= 14)\n");
186 code (0, CONSTANTS, " #pragma GCC diagnostic ignored \"-Wdeclaration-missing-parameter-type\"\n");
187 code (0, CONSTANTS, " #pragma GCC diagnostic ignored \"-Wimplicit-int\"\n");
188 code (0, CONSTANTS, " #pragma GCC diagnostic ignored \"-Wint-conversion\"\n");
189 code (0, CONSTANTS, " #pragma GCC diagnostic ignored \"-Wreturn-mismatch\"\n");
190 code (0, CONSTANTS, " #endif\n");
191 code (0, CONSTANTS, "#else\n");
192 code (0, CONSTANTS, " #error VIF requires GCC\n");
193 code (0, CONSTANTS, "#endif\n");
194 code (0, CONSTANTS, "\n");
195 code (0, CONSTANTS, "#include <vif.h>\n");
196 code (0, CONSTANTS, "\n");
197 code (0, CONSTANTS, "static int_4 _km1 = -1, _k0 = 0, _k1 = 1;\n");
198 code (0, CONSTANTS, "\n");
199 code (0, COMMON, "\n");
200 code (0, MESSAGES, newpage ("global-scope", "diagnostics"));
201 code (0, JCL, newpage ("global-scope", "job-control"));
202 code (0, TYPEDEF, newpage ("global-scope", "typedefs"));
203 code (0, TYPEDEF, "static FORMAT *__fmt_a = NULL;\n");
204 code (0, PROTOTYPE, newpage ("global-scope", "prototypes"));
205 code (0, FREQ, newpage ("global-scope", "frequency-table"));
206 code (0, FREQ, "#define __ncalls ");
207 pcalls = code (0, FREQ, NO_TEXT);
208 code (0, FREQ, "\n");
209 code (0, FREQ, "static CALLS __calls[__ncalls] = {\n");
210 }
211
212 void postlude (void)
213 {
214 NEW_RECORD (str);
215 code (0, PROTOTYPE, "\n");
216 code (0, FREQ, " {NULL , 0}\n");
217 _srecordf (str, "%d", nprocs + 1);
218 patch (pcalls, str);
219 code (0, FREQ, "};\n");
220 // Write the common blocks.
221 if (ncommons > EXTERN) {
222 code (0, COMMON, newpage ("global-scope", "common-blocks"));
223 code_common ();
224 }
225 // Define character array types encountered.
226 for (int k = 0, len = 2; k < MAX_STRLENS; k++, len *= 2) {
227 if (strlens[k]) {
228 _srecordf (str, "typedef char char_%d[%d];\n", len - 1, len);
229 code (0, TYPEDEF, str);
230 }
231 }
232 // Add an entry procedure.
233 if (! compile_only) {
234 nprocs++;
235 code (nprocs, BODY, newpage ("global-scope", "entry-point"));
236 code (nprocs, BODY, "// Global entry point.\n");
237 code (nprocs, BODY, "int_4 main (int_4 argc, char **argv)\n");
238 code (nprocs, BODY, "{\n");
239 code (nprocs, BODY, "_vif_init ();\n");
240 code (nprocs, BODY, "_ffile[0] = NEW_FTN_FILE (NULL, form_formatted, action_readwrite, 0);\n");
241 for (int k = 0; k < MAX_FTN_FILES; k++) {
242 if (_ffile[k].in_stream) {
243 _srecordf (str, "_ffile[%d].in_stream = TRUE;\n", k);
244 code (nprocs, BODY, str);
245 _srecordf (str, "_ffile[%d].action = action_read;\n", k);
246 code (nprocs, BODY, str);
247 _srecordf (str, "_ffile[%d].buff = _ffile[%d].rewind = f_stralloc (%s);\n", k, k, _ffile[k].name);
248 code (nprocs, BODY, str);
249 }
250 }
251 // SYSIN
252 if (! (_ffile[STDF_IN].in_stream || _ffile[STDF_IN].redirect)) {
253 _srecordf (str, "_ffile[%d] = NEW_FTN_FILE (stdin, form_formatted, action_read, MAX_LRECL);\n", STDF_IN);
254 code (nprocs, BODY, str);
255 _srecordf (str, "_ffile[%d].buff = (char *) f_malloc (MAX_LRECL + 1);\n", STDF_IN);
256 code (nprocs, BODY, str);
257 }
258 //SYSOUT
259 if (_ffile[STDF_OUT].in_stream) {
260 ERROR (3501, "standard output", "JCL in-stream is read only");
261 } else if (! _ffile[STDF_OUT].redirect) {
262 _srecordf (str, "_ffile[%d] = NEW_FTN_FILE (stdout, form_formatted, action_write, 0);\n", STDF_OUT);
263 code (nprocs, BODY, str);
264 }
265 //SYSPUNCH
266 #if STDF_OUT != STDF_PUN
267 if (_ffile[STDF_PUN].in_stream) {
268 ERROR (3502, "standard punch", "JCL in-stream is read only");
269 } else if (! _ffile[STDF_PUN].redirect) {
270 _srecordf (str, "_ffile[%d] = NEW_FTN_FILE (stdout, form_formatted, action_write, 0);\n", STDF_PUN);
271 code (nprocs, BODY, str);
272 }
273 #endif
274 // SYSERR
275 if (_ffile[STDF_ERR].in_stream) {
276 ERROR (3503, "standard error", "JCL in-stream is read only");
277 } else if (! _ffile[STDF_ERR].redirect) {
278 _srecordf (str, "_ffile[%d] = NEW_FTN_FILE (stdout, form_formatted, action_write, 0);\n", STDF_ERR);
279 code (nprocs, BODY, str);
280 }
281 //
282 if (strlen (block) > 0) {
283 NEW_RECORD (call);
284 _srecordf (call, "%s (); // Block data.\n", block);
285 code (nprocs, BODY, call);
286 }
287 if (strlen (program) > 0) {
288 NEW_RECORD (call);
289 _srecordf (call, "%s (); // Fortran entry point.\n", program);
290 code (nprocs, BODY, call);
291 }
292 if (frequency) {
293 code (nprocs, BODY, "_vif_freq (__calls);");
294 }
295 code (nprocs, BODY, "_vif_exit ();\n");
296 code (nprocs, BODY, "return EXIT_SUCCESS;\n");
297 code (nprocs, BODY, "}\n");
298 }
299 }
300
301 static void usage (void)
302 {
303 printf ("Usage: %s [-O][-f][-g][-k][-p][-v] file [, file, ...]\n", PACKAGE);
304 printf ("\n");
305 printf (" -b : Do not include source code in listing.\n");
306 printf (" -c : Compile as a library.\n");
307 printf (" -d : FORTRAN IV style do loops.\n");
308 printf (" -e : Keep object file.\n");
309 printf (" -f : Generate a call frequency table.\n");
310 printf (" -g : Execute upon successful compilation.\n");
311 printf (" -h : Disable Hollerith strings.\n");
312 printf (" -i : Ignore text after column 72.\n");
313 printf (" -k : Backend compiler reports diagnostics at object code line.\n");
314 printf (" -l : Generate a verbose listing file.\n");
315 printf (" -o name: sets name for object file to `name.c' and for executable to `name'.\n");
316 printf (" -p : Keep the generated code upon successful compilation in pdf format.\n");
317 printf (" -q : Quiet mode.\n");
318 printf (" -r : Renumber FORTRAN source code.\n");
319 printf (" -s : Check syntax only.\n");
320 printf (" -t : Trace mode.\n");
321 printf (" -u : Case insensitive string comparisons.\n");
322 printf (" -v : Print VIF version and exit.\n");
323 printf (" -w : Suppress warning diagnostics.\n");
324 printf (" -x : Execute upon successful compilation and erase executable.\n");
325 printf (" -y : Renumber FORTRAN source code and apply upper stropping.\n");
326 printf (" -z : Set default REAL length to 8 and default COMPLEX length to 16.\n");
327 printf (" -O0 : Do not optimize the object code (default).\n");
328 printf (" -O : Optimize the object code.\n");
329 printf (" -O1 : Optimize the object code.\n");
330 printf (" -O2 : Optimize the object code.\n");
331 printf (" -O3 : Optimize the object code.\n");
332 printf (" -Of : Optimize the object code.\n");
333 }
334
335 void version (void)
336 {
337 printf ("VIF %s - experimental VIntage Fortran compiler.\n", VERSION);
338 printf ("Copyright 2020-2026 J.M. van der Veer.\n\n");
339 printf ("Backend compiler : %s\n", BACKEND);
340 printf ("Install directory: %s\n\n", LOCDIR);
341 printf ("This is free software covered by the GNU General Public License.\n");
342 printf ("There is ABSOLUTELY NO WARRANTY for VIF;\n");
343 printf ("not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n");
344 printf ("See the GNU General Public License for more details.\n");
345 }
346
347 #define OPTION(s) EQUAL (opt, (s))
348
349 void option (char *opt)
350 {
351 if (OPTION ("--frequency")) {
352 frequency = TRUE;
353 } else if (OPTION ("--go")) {
354 load_go = TRUE;
355 } else if (OPTION ("--keep")) {
356 keep_object = TRUE;
357 } else if (OPTION ("--keep-listing")) {
358 keep_listing = TRUE;
359 } else if (OPTION ("--lib")) {
360 new_libnam = TRUE;
361 } else if (OPTION ("--pdf")) {
362 keep_listing = TRUE;
363 pretty = TRUE;
364 } else if (OPTION ("--f4-do-loops")) {
365 f4_do_loops = TRUE;
366 } else if (OPTION ("--renumber")) {
367 renum = TRUE;
368 } else if (OPTION ("--tidy")) {
369 renum = TRUE;
370 tidy = TRUE;
371 } else if (OPTION ("--hollerith")) {
372 hollerith = TRUE;
373 } else if (OPTION ("--no-source")) {
374 no_source = TRUE;
375 } else if (OPTION ("--license")) {
376 version ();
377 exit (EXIT_SUCCESS);
378 } else if (OPTION ("--version")) {
379 version ();
380 exit (EXIT_SUCCESS);
381 } else if (opt[1] == '-' && opt[2] == '\0') {
382 return;
383 } else for (int_4 k = 1; opt[k] != '\0'; k++) {
384 if (opt[k] == 'O') {
385 optimise = 0;
386 if (opt[k + 1] == '0') {
387 _srecordf(oflags, "%s", "-O0 -ggdb");
388 k++;
389 } else if (opt[k + 1] == '1') {
390 _srecordf(oflags, "%s", "-O1");
391 optimise = 1;
392 k++;
393 } else if (opt[k + 1] == '2') {
394 _srecordf(oflags, "%s", "-O2");
395 optimise = 2;
396 k++;
397 } else if (opt[k + 1] == '3') {
398 _srecordf(oflags, "%s", "-funroll-all-loops -O3");
399 optimise = 3;
400 k++;
401 } else if (opt[k + 1] == 'f') {
402 _srecordf(oflags, "%s", "-Ofast");
403 optimise = 4;
404 k++;
405 } else {
406 _srecordf(oflags, "%s", "-O");
407 optimise = 1;
408 }
409 } else if (opt[k] == 'b') {
410 no_source = TRUE;
411 } else if (opt[k] == 'c') {
412 compile_only = TRUE;
413 } else if (opt[k] == 'd') {
414 f4_do_loops = TRUE;
415 } else if (opt[k] == 'e') {
416 keep_object = TRUE;
417 } else if (opt[k] == 'f') {
418 frequency = TRUE;
419 } else if (opt[k] == 'g') {
420 load_go = TRUE;
421 } else if (opt[k] == 'h') {
422 hollerith = TRUE;
423 } else if (opt[k] == 'i') {
424 column_72 = TRUE;
425 } else if (opt[k] == 'k') {
426 gcc_ftn_lines = FALSE;
427 } else if (opt[k] == 'l') {
428 keep_listing = TRUE;
429 } else if (opt[k] == 'o') {
430 new_object = TRUE;
431 } else if (opt[k] == 'p') {
432 keep_listing = TRUE;
433 pretty = TRUE;
434 } else if (opt[k] == 'q') {
435 quiet_mode = TRUE;
436 } else if (opt[k] == 'r') {
437 renum = TRUE;
438 } else if (opt[k] == 's') {
439 syntax_only = TRUE;
440 } else if (opt[k] == 't') {
441 trace = TRUE;
442 } else if (opt[k] == 'u') {
443 use_strcasecmp = TRUE;
444 } else if (opt[k] == 'v') {
445 version ();
446 exit (EXIT_SUCCESS);
447 } else if (opt[k] == 'w') {
448 no_warnings = TRUE;
449 } else if (opt[k] == 'x') {
450 load_go = TRUE;
451 load_go_erase = TRUE;
452 } else if (opt[k] == 'y') {
453 renum = TRUE;
454 tidy = TRUE;
455 } else if (opt[k] == 'z') {
456 implicit_r8 = TRUE;
457 } else {
458 usage ();
459 exit (EXIT_FAILURE);
460 }
461 }
462 }
463
464 #undef OPTION
465
466 int_4 main (int_4 argc, char **argv)
467 {
468 int_4 rc = EXIT_SUCCESS, start = 1;
469 NEW_RECORD (c_file);
470 NEW_RECORD (f_file);
471 NEW_RECORD (lst_file);
472 NEW_RECORD (cmd);
473 //
474 for (int k = 0; k < MAX_FTN_FILES; k++) {
475 _reset_ftn_file (&_ffile[k]);
476 }
477 //
478 MAX_FTN_LINES = INCREMENT;
479 MAX_C_SRC = INCREMENT;
480 source = (FTN_LINE *) f_malloc (MAX_FTN_LINES * sizeof (FTN_LINE));
481 object = (C_SRC *) f_malloc (MAX_C_SRC * sizeof (C_SRC));
482 files = (FTN_LINE *) f_malloc (MAX_SOURCE_FILES * sizeof (FTN_LINE));
483 memset (_ffile, 0, sizeof (_ffile));
484 // Options
485 f4_do_loops = FALSE;
486 new_libnam = FALSE;
487 new_object = FALSE;
488 oflags[0] = '\0';
489 RECCLR (libnam);
490 RECCLR (object_name);
491 while (argv[start] != NO_TEXT && argv[start][0] == '-') {
492 option (argv[start]);
493 start++;
494 if (new_libnam) {
495 new_libnam = FALSE;
496 if (strlen (libnam) == 0 && argv[start] != NO_TEXT) {
497 RECCPY (libnam, argv[start]);
498 start++;
499 } else {
500 usage ();
501 exit (EXIT_FAILURE);
502 }
503 } else if (new_object) {
504 new_object = FALSE;
505 if (strlen (object_name) == 0 && argv[start] != NO_TEXT) {
506 RECCPY (object_name, argv[start]);
507 start++;
508 } else {
509 usage ();
510 exit (EXIT_FAILURE);
511 }
512 }
513 }
514 if (argv[start] == NO_TEXT) {
515 usage ();
516 exit (EXIT_FAILURE);
517 }
518 RECCLR (program);
519 RECCLR (block);
520 RECCLR (curlex);
521 RECCLR (prelex);
522 for (int_4 k = 0; k < MAX_STRLENS; k++) {
523 strlens[k] = FALSE;
524 }
525 date ();
526 RECCPY (hmodule, "global-scope");
527 RECCPY (hsection, "global-section");
528 // Import all sources.
529 NEW_RECORD (argv_start);
530 _srecordf (argv_start, argv[start]);
531 for (int k = start; k < argc; k++) {
532 get_source (f_stralloc (argv[k]), 0);
533 }
534 // Name for project derives from first source file.
535 if (strlen (libnam) == 0) {
536 if (new_object) {
537 RECCPY (libnam, object_name);
538 } else {
539 RECCPY (libnam, argv_start);
540 }
541 for (int k = (int_4) strlen (libnam); k >= 0; k--) {
542 if (libnam[k] == '.') {
543 libnam[k] = '\0';
544 break;
545 }
546 }
547 }
548 // Fill in what we know at the start.
549 prelude (argc, argv, libnam);
550 // Compile all subprograms.
551 nmodules = 0;
552 curlin = 1;
553 curcol = START_OF_LINE;
554 jcllin = 0;
555 scan_modules ();
556 curlin = 1;
557 curcol = START_OF_LINE;
558 macro_nest = 0;
559 lhs_factor = FALSE;
560 subprograms ();
561 // Fill in what we know afterwards, and write C source.
562 postlude ();
563 // Remove stale files.
564 RECCLR (c_file);
565 _srecordf (c_file, "%s.c", libnam);
566 _srecordf (f_file, "%s.f~", libnam);
567 _srecordf (lst_file, "%s.l", libnam);
568 //
569 write_object (c_file);
570 // Compile intermediate code.
571 if (syntax_only) {
572 NEW_RECORD (str);
573 _srecordf (str, "** linker ** no object file generated");
574 diagnostic (0, str);
575 if (nerrors == 0) {
576 rc = EXIT_SUCCESS;
577 } else {
578 rc = EXIT_FAILURE;
579 }
580 } else if (nerrors != 0) {
581 NEW_RECORD (str);
582 nerrors++;
583 _srecordf (str, "** linker ** no object file generated");
584 diagnostic (0, str);
585 rc = EXIT_FAILURE;
586 } else {
587 NEW_RECORD (str);
588 if (compile_only) {
589 if (optimise > 0) {
590 rc = _sys (cmd, BACKEND, NO_TEXT, "%s %s -c %s.c -o %s.o", oflags, CFLAGS, libnam, libnam);
591 } else {
592 rc = _sys (cmd, BACKEND, NO_TEXT, "-O0 -ggdb %s -c %s.c -o %s.o", CFLAGS, libnam, libnam);
593 }
594 } else {
595 if (optimise > 0) {
596 #if defined (BOOTSTRAP)
597 rc = _sys (cmd, BACKEND, NO_TEXT, "%s %s %s.c -o %s %s", oflags, CFLAGS, libnam, libnam, LD_FLAGS);
598 #else
599 rc = _sys (cmd, BACKEND, NO_TEXT, "%s %s %s.c -o %s -L%s %s", oflags, CFLAGS, libnam, libnam, LOCDIR, LD_FLAGS);
600 #endif
601 } else {
602 #if defined (BOOTSTRAP)
603 rc = _sys (cmd, BACKEND, NO_TEXT, "-O0 -ggdb %s %s.c -o %s %s", CFLAGS, libnam, libnam, LD_FLAGS);
604 #else
605 rc = _sys (cmd, BACKEND, NO_TEXT, "-O0 -ggdb %s %s.c -o %s -L%s %s", CFLAGS, libnam, libnam, LOCDIR, LD_FLAGS);
606 #endif
607 }
608 }
609 if (rc == EXIT_SUCCESS) {
610 struct stat s;
611 if (compile_only) {
612 NEW_RECORD (obj);
613 _srecordf (obj, "%s.o", libnam);
614 stat (obj, &s);
615 } else {
616 stat (libnam, &s);
617 }
618 _srecordf (str, "** linker ** object size %ld bytes", s.st_size);
619 diagnostic (0, str);
620 } else {
621 nerrors++;
622 _srecordf (str, "** linker ** no object file generated");
623 diagnostic (0, str);
624 rc = EXIT_FAILURE;
625 }
626 if (keep_listing) {
627 _sys (cmd, "cp", NO_TEXT, "%s %s", c_file, lst_file);
628 }
629 }
630 // Wrap it up
631 {
632 NEW_RECORD (str);
633 NEW_RECORD (sub);
634 NEW_RECORD (err);
635 NEW_RECORD (war);
636 if (! compile_only) {
637 nprocs--; // Discount entry point "main".
638 }
639 if (nprocs == 0) {
640 _srecordf (sub, "no subprograms");
641 } else if (nprocs == 1) {
642 _srecordf (sub, "1 subprogram");
643 } else {
644 _srecordf (sub, "%d subprograms", nprocs);
645 }
646 if (nerrors == 0) {
647 _srecordf (err, "no errors");
648 } else if (nerrors == 1) {
649 _srecordf (err, "1 error");
650 } else {
651 _srecordf (err, "%d errors", nerrors);
652 }
653 if (nwarns == 0) {
654 _srecordf (war, "no warnings");
655 } else if (nwarns == 1) {
656 _srecordf (war, "1 warning");
657 } else {
658 _srecordf (war, "%d warnings", nwarns);
659 }
660 _srecordf (str, "** statistics ** %s, %s, %s", sub, err, war);
661 diagnostic (0, str);
662 }
663 // Execution.
664 if (!renum && load_go && nerrors == 0 && ! syntax_only) {
665 fprintf (stderr, "** execution **\n");
666 NEW_RECORD (exec);
667 if (libnam[0] == '/') {
668 _srecordf (exec, "%s | tee %s.%s.%s", libnam, libnam, date_fn (), PACKAGE);
669 } else {
670 _srecordf (exec, "./%s | tee %s.%s.%s", libnam, libnam, date_fn (), PACKAGE);
671 }
672 rc = _sys (cmd, exec, NO_TEXT, NO_TEXT);
673 if (load_go_erase) {
674 _sys (cmd, "rm", NO_TEXT, "-f ./%s", exec);
675 }
676 }
677 // Write C source again with post-compile information.
678 remove (c_file);
679 write_object (c_file);
680 _sys (cmd, "cp", NO_TEXT, "%s %s", c_file, lst_file);
681 // Write tidied fortran file.
682 if (renum) {
683 write_tidy (f_file);
684 }
685 // Pretty listing file as PDF.
686 if (keep_listing && pretty) {
687 NEW_RECORD (tmp);
688 _srecordf (tmp, "./.vif_pdf");
689 _sys (cmd, "enscript", "ps2pdf", "--quiet --font=Courier-Bold@9 -l -H1 -r --margins=25:25:40:40 -p - %s > %s", c_file, tmp);
690 _sys (cmd, "ps2pdf", "enscript", "%s %s.pdf", tmp, libnam);
691 _sys (cmd, "rm", NO_TEXT, "-f %s", tmp);
692 }
693 if (!keep_object) {
694 _sys (cmd, "rm", NO_TEXT, "-f %s.c", libnam);
695 _sys (cmd, "rm", NO_TEXT, "-f %s.s", libnam);
696 }
697 // Exeunt.
698 exit (rc);
699 }
|
© 2002-2026 J.M. van der Veer (jmvdveer@xs4all.nl)
|
