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