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