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