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