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_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 (" -v : Print the version and exit.\n");
319 printf (" -w : Suppress warning diagnostics.\n");
320 printf (" -x : Execute upon successful compilation and erase executable.\n");
321 printf (" -y : Renumber FORTRAN source code and apply upper stropping.\n");
322 printf (" -z : Set default REAL length to 8 and default COMPLEX length to 16.\n");
323 printf (" -O0 : Do not optimize the object code.\n");
324 printf (" -O : Optimize the object code.\n");
325 printf (" -O1 : Optimize the object code.\n");
326 printf (" -O2 : Optimize the object code.\n");
327 printf (" -O3 : Optimize the object code.\n");
328 printf (" -Of : Optimize the object code.\n");
329 }
330
331 void version (void)
332 {
333 printf ("VIF %s - experimental VIntage Fortran compiler.\n", VERSION);
334 printf ("Copyright 2020-2025 J.M. van der Veer.\n\n");
335 printf ("Backend compiler : %s\n", BACKEND);
336 printf ("Install directory: %s\n\n", LOCDIR);
337 printf ("This is free software covered by the GNU General Public License.\n");
338 printf ("There is ABSOLUTELY NO WARRANTY for VIF;\n");
339 printf ("not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n");
340 printf ("See the GNU General Public License for more details.\n");
341 }
342
343 #define OPTION(s) EQUAL (opt, (s))
344
345 void option (char *opt)
346 {
347 if (OPTION ("--frequency")) {
348 frequency = TRUE;
349 } else if (OPTION ("--go")) {
350 load_go = TRUE;
351 } else if (OPTION ("--keep")) {
352 keep_object = TRUE;
353 } else if (OPTION ("--keep-listing")) {
354 keep_listing = TRUE;
355 } else if (OPTION ("--lib")) {
356 new_libnam = TRUE;
357 } else if (OPTION ("--pdf")) {
358 keep_listing = TRUE;
359 pretty = TRUE;
360 } else if (OPTION ("--f4-do-loops")) {
361 f4_do_loops = TRUE;
362 } else if (OPTION ("--renumber")) {
363 renum = TRUE;
364 } else if (OPTION ("--tidy")) {
365 renum = TRUE;
366 tidy = TRUE;
367 } else if (OPTION ("--hollerith")) {
368 hollerith = TRUE;
369 } else if (OPTION ("--no-source")) {
370 no_source = TRUE;
371 } else if (OPTION ("--license")) {
372 version ();
373 exit (EXIT_SUCCESS);
374 } else if (OPTION ("--version")) {
375 version ();
376 exit (EXIT_SUCCESS);
377 } else if (opt[1] == '-' && opt[2] == '\0') {
378 return;
379 } else for (int_4 k = 1; opt[k] != '\0'; k++) {
380 if (opt[k] == 'O') {
381 optimise = 0;
382 if (opt[k + 1] == '0') {
383 _srecordf(oflags, "%s", "-O0 -ggdb");
384 k++;
385 } else if (opt[k + 1] == '1') {
386 _srecordf(oflags, "%s", "-O1");
387 optimise = 1;
388 k++;
389 } else if (opt[k + 1] == '2') {
390 _srecordf(oflags, "%s", "-O2");
391 optimise = 2;
392 k++;
393 } else if (opt[k + 1] == '3') {
394 _srecordf(oflags, "%s", "-funroll-all-loops -O3");
395 optimise = 3;
396 k++;
397 } else if (opt[k + 1] == 'f') {
398 _srecordf(oflags, "%s", "-Ofast");
399 optimise = 4;
400 k++;
401 } else {
402 _srecordf(oflags, "%s", "-O");
403 optimise = 1;
404 }
405 } else if (opt[k] == 'b') {
406 no_source = TRUE;
407 } else if (opt[k] == 'c') {
408 compile_only = TRUE;
409 } else if (opt[k] == 'd') {
410 f4_do_loops = TRUE;
411 } else if (opt[k] == 'e') {
412 keep_object = TRUE;
413 } else if (opt[k] == 'f') {
414 frequency = TRUE;
415 } else if (opt[k] == 'g') {
416 load_go = TRUE;
417 } else if (opt[k] == 'k') {
418 gcc_ftn_lines = FALSE;
419 } else if (opt[k] == 'l') {
420 keep_listing = TRUE;
421 } else if (opt[k] == 'o') {
422 new_object = TRUE;
423 } else if (opt[k] == 'p') {
424 keep_listing = TRUE;
425 pretty = TRUE;
426 } else if (opt[k] == 'q') {
427 quiet_mode = TRUE;
428 } else if (opt[k] == 'r') {
429 renum = TRUE;
430 } else if (opt[k] == 's') {
431 syntax_only = TRUE;
432 } else if (opt[k] == 't') {
433 trace = TRUE;
434 } else if (opt[k] == 'u') {
435 use_strcasecmp = TRUE;
436 } else if (opt[k] == 'v') {
437 version ();
438 exit (EXIT_SUCCESS);
439 } else if (opt[k] == 'w') {
440 no_warnings = TRUE;
441 } else if (opt[k] == 'x') {
442 load_go = TRUE;
443 load_go_erase = TRUE;
444 } else if (opt[k] == 'y') {
445 renum = TRUE;
446 tidy = TRUE;
447 } else if (opt[k] == 'z') {
448 implicit_r8 = TRUE;
449 } else {
450 usage ();
451 exit (EXIT_FAILURE);
452 }
453 }
454 }
455
456 #undef OPTION
457
458 int_4 main (int_4 argc, char **argv)
459 {
460 int_4 rc = EXIT_SUCCESS, start = 1;
461 NEW_RECORD (c_file);
462 NEW_RECORD (f_file);
463 NEW_RECORD (lst_file);
464 NEW_RECORD (cmd);
465 //
466 for (int k = 0; k < MAX_FILES; k++) {
467 _reset_ftnfile (&_ffile[k]);
468 }
469 //
470 MAX_FTN_LINES = INCREMENT;
471 MAX_C_SRC = INCREMENT;
472 source = (FTN_LINE *) f_malloc (MAX_FTN_LINES * sizeof (FTN_LINE));
473 object = (C_SRC *) f_malloc (MAX_C_SRC * sizeof (C_SRC));
474 files = (FTN_LINE *) f_malloc (MAX_SOURCE_FILES * sizeof (FTN_LINE));
475 memset (_ffile, 0, sizeof (_ffile));
476 // Options
477 f4_do_loops = FALSE;
478 new_libnam = FALSE;
479 new_object = FALSE;
480 oflags[0] = '\0';
481 RECCLR (libnam);
482 RECCLR (object_name);
483 while (argv[start] != NO_TEXT && argv[start][0] == '-') {
484 option (argv[start]);
485 start++;
486 if (new_libnam) {
487 new_libnam = FALSE;
488 if (strlen (libnam) == 0 && argv[start] != NO_TEXT) {
489 RECCPY (libnam, argv[start]);
490 start++;
491 } else {
492 usage ();
493 exit (EXIT_FAILURE);
494 }
495 } else if (new_object) {
496 new_object = FALSE;
497 if (strlen (object_name) == 0 && argv[start] != NO_TEXT) {
498 RECCPY (object_name, argv[start]);
499 start++;
500 } else {
501 usage ();
502 exit (EXIT_FAILURE);
503 }
504 }
505 }
506 if (argv[start] == NO_TEXT) {
507 usage ();
508 exit (EXIT_FAILURE);
509 }
510 RECCLR (program);
511 RECCLR (block);
512 RECCLR (curlex);
513 RECCLR (prelex);
514 for (int_4 k = 0; k < MAX_STRLENS; k++) {
515 strlens[k] = FALSE;
516 }
517 date ();
518 RECCPY (hmodule, "global-scope");
519 RECCPY (hsection, "global-section");
520 // Import all sources.
521 NEW_RECORD (argv_start);
522 _srecordf (argv_start, argv[start]);
523 for (int k = start; k < argc; k++) {
524 get_source (f_stralloc (argv[k]), 0);
525 }
526 // Name for project derives from first source file.
527 if (strlen (libnam) == 0) {
528 if (new_object) {
529 RECCPY (libnam, object_name);
530 } else {
531 RECCPY (libnam, argv_start);
532 }
533 for (int k = (int_4) strlen (libnam); k >= 0; k--) {
534 if (libnam[k] == '.') {
535 libnam[k] = '\0';
536 break;
537 }
538 }
539 }
540 // Fill in what we know at the start.
541 prelude (argc, argv, libnam);
542 // Compile all subprograms.
543 nmodules = 0;
544 curlin = 1;
545 curcol = START_OF_LINE;
546 jcllin = 0;
547 scan_modules ();
548 curlin = 1;
549 curcol = START_OF_LINE;
550 macro_nest = 0;
551 lhs_factor = FALSE;
552 subprograms ();
553 // Fill in what we know afterwards, and write C source.
554 postlude ();
555 // Remove stale files.
556 RECCLR (c_file);
557 _srecordf (c_file, "%s.c", libnam);
558 _srecordf (f_file, "%s.f~", libnam);
559 _srecordf (lst_file, "%s.l", libnam);
560 //
561 write_object (c_file);
562 // Compile intermediate code.
563 if (syntax_only) {
564 NEW_RECORD (str);
565 _srecordf (str, "** linker ** no object file generated");
566 diagnostic (0, str);
567 if (nerrors == 0) {
568 rc = EXIT_SUCCESS;
569 } else {
570 rc = EXIT_FAILURE;
571 }
572 } else if (nerrors != 0) {
573 NEW_RECORD (str);
574 nerrors++;
575 _srecordf (str, "** linker ** no object file generated");
576 diagnostic (0, str);
577 rc = EXIT_FAILURE;
578 } else {
579 NEW_RECORD (str);
580 if (compile_only) {
581 if (optimise > 0) {
582 rc = _sys (cmd, BACKEND, NO_TEXT, "%s %s -c %s.c -o %s.o", oflags, CFLAGS, libnam, libnam);
583 } else {
584 rc = _sys (cmd, BACKEND, NO_TEXT, "-O0 -ggdb %s -c %s.c -o %s.o", CFLAGS, libnam, libnam);
585 }
586 } else {
587 if (optimise > 0) {
588 #if defined (BOOTSTRAP)
589 rc = _sys (cmd, BACKEND, NO_TEXT, "%s %s %s.c -o %s %s", oflags, CFLAGS, libnam, libnam, LD_FLAGS);
590 #else
591 rc = _sys (cmd, BACKEND, NO_TEXT, "%s %s %s.c -o %s -L%s %s", oflags, CFLAGS, libnam, libnam, LOCDIR, LD_FLAGS);
592 #endif
593 } else {
594 #if defined (BOOTSTRAP)
595 rc = _sys (cmd, BACKEND, NO_TEXT, "-O0 -ggdb %s %s.c -o %s %s", CFLAGS, libnam, libnam, LD_FLAGS);
596 #else
597 rc = _sys (cmd, BACKEND, NO_TEXT, "-O0 -ggdb %s %s.c -o %s -L%s %s", CFLAGS, libnam, libnam, LOCDIR, LD_FLAGS);
598 #endif
599 }
600 }
601 if (rc == EXIT_SUCCESS) {
602 struct stat s;
603 if (compile_only) {
604 NEW_RECORD (obj);
605 _srecordf (obj, "%s.o", libnam);
606 stat (obj, &s);
607 } else {
608 stat (libnam, &s);
609 }
610 _srecordf (str, "** linker ** object size %ld bytes", s.st_size);
611 diagnostic (0, str);
612 } else {
613 nerrors++;
614 _srecordf (str, "** linker ** no object file generated");
615 diagnostic (0, str);
616 rc = EXIT_FAILURE;
617 }
618 if (keep_listing) {
619 _sys (cmd, "cp", NO_TEXT, "%s %s", c_file, lst_file);
620 }
621 }
622 // Wrap it up
623 {
624 NEW_RECORD (str);
625 NEW_RECORD (sub);
626 NEW_RECORD (err);
627 NEW_RECORD (war);
628 // if (nprocs > 0 && ! compile_only) {
629 // nprocs--; // discount 'main'
630 // }
631 if (nprocs == 0) {
632 _srecordf (sub, "no subprograms");
633 } else if (nprocs == 1) {
634 _srecordf (sub, "1 subprogram");
635 } else {
636 _srecordf (sub, "%d subprograms", nprocs);
637 }
638 if (nerrors == 0) {
639 _srecordf (err, "no errors");
640 } else if (nerrors == 1) {
641 _srecordf (err, "1 error");
642 } else {
643 _srecordf (err, "%d errors", nerrors);
644 }
645 if (nwarns == 0) {
646 _srecordf (war, "no warnings");
647 } else if (nwarns == 1) {
648 _srecordf (war, "1 warning");
649 } else {
650 _srecordf (war, "%d warnings", nwarns);
651 }
652 _srecordf (str, "** statistics ** %s, %s, %s", sub, err, war);
653 diagnostic (0, str);
654 }
655 // Execution.
656 if (!renum && load_go && nerrors == 0 && ! syntax_only) {
657 fprintf (stderr, "** execution **\n");
658 NEW_RECORD (exec);
659 if (libnam[0] == '/') {
660 _srecordf (exec, "%s | tee %s.%s.%s", libnam, libnam, date_fn (), PACKAGE);
661 } else {
662 _srecordf (exec, "./%s | tee %s.%s.%s", libnam, libnam, date_fn (), PACKAGE);
663 }
664 rc = _sys (cmd, exec, NO_TEXT, NO_TEXT);
665 if (load_go_erase) {
666 _sys (cmd, "rm", NO_TEXT, "-f ./%s", exec);
667 }
668 }
669 // Write C source again with post-compile information.
670 remove (c_file);
671 write_object (c_file);
672 _sys (cmd, "cp", NO_TEXT, "%s %s", c_file, lst_file);
673 // Write tidied fortran file.
674 if (renum) {
675 write_tidy (f_file);
676 }
677 // Pretty listing file as PDF.
678 if (keep_listing && pretty) {
679 NEW_RECORD (tmp);
680 _srecordf (tmp, "./.vif_pdf");
681 _sys (cmd, "enscript", "ps2pdf", "--quiet --font=Courier-Bold@9 -l -H1 -r --margins=25:25:40:40 -p - %s > %s", c_file, tmp);
682 _sys (cmd, "ps2pdf", "enscript", "%s %s.pdf", tmp, libnam);
683 _sys (cmd, "rm", NO_TEXT, "-f %s", tmp);
684 }
685 if (!keep_object) {
686 _sys (cmd, "rm", NO_TEXT, "-f %s.c", libnam);
687 _sys (cmd, "rm", NO_TEXT, "-f %s.s", libnam);
688 }
689 // Exeunt.
690 exit (rc);
691 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
