a68g.c
You can download the current version of Algol 68 Genie and its documentation here.
1 //! @file a68g.c
2 //! @author J. Marcel van der Veer
3 //!
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2023 J. Marcel van der Veer .
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 .
21
22 //! @section Synopsis
23 //!
24 //! Algol 68 Genie main driver.
25
26 #include "a68g.h"
27 #include "a68g-prelude.h"
28 #include "a68g-mp.h"
29 #include "a68g-genie.h"
30 #include "a68g-prelude-mathlib.h"
31 #include "a68g-postulates.h"
32 #include "a68g-parser.h"
33 #include "a68g-options.h"
34 #include "a68g-optimiser.h"
35 #include "a68g-listing.h"
36
37 #if defined (HAVE_MATHLIB)
38 #include
39 #endif
40
41 GLOBALS_T common;
42
43 #define EXTENSIONS 11
44 static char *extensions[EXTENSIONS] = {
45 NO_TEXT,
46 ".a68", ".A68",
47 ".a68g", ".A68G",
48 ".algol", ".ALGOL",
49 ".algol68", ".ALGOL68",
50 ".algol68g", ".ALGOL68G"
51 };
52
53 void compiler_interpreter (void);
54
55 //! @brief Verbose statistics, only useful when debugging a68g.
56
57 void verbosity (void)
58 {
59 #if defined (A68_DEBUG)
60 ;
61 #else
62 ;
63 #endif
64 }
65
66 //! @brief State license of running a68g image.
67
68 void state_license (FILE_T f)
69 {
70 #define PR(s)\
71 ASSERT (snprintf(A68 (output_line), SNPRINTF_SIZE, "%s\n", (s)) >= 0);\
72 WRITE (f, A68 (output_line));
73 //
74 if (f == STDOUT_FILENO) {
75 io_close_tty_line ();
76 }
77 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Algol 68 Genie %s\n", PACKAGE_VERSION) >= 0);
78 WRITE (f, A68 (output_line));
79 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Copyright 2001-2023 %s.\n", PACKAGE_BUGREPORT) >= 0);
80 WRITE (f, A68 (output_line));
81 PR ("");
82 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "This is free software covered by the GNU General Public License.\n") >= 0);
83 WRITE (f, A68 (output_line));
84 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "There is ABSOLUTELY NO WARRANTY for Algol 68 Genie;\n") >= 0);
85 WRITE (f, A68 (output_line));
86 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n") >= 0);
87 WRITE (f, A68 (output_line));
88 PR ("See the GNU General Public License for more details.");
89 PR ("");
90 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Please report bugs to %s.\n", PACKAGE_BUGREPORT) >= 0);
91 WRITE (f, A68 (output_line));
92 #undef PR
93 }
94
95 //! @brief State version of running a68g image.
96
97 void state_version (FILE_T f)
98 {
99 #define PR(s)\
100 ASSERT (snprintf(A68 (output_line), SNPRINTF_SIZE, "%s\n", (s)) >= 0);\
101 WRITE (f, A68 (output_line));
102 //
103 if (f == STDOUT_FILENO) {
104 io_close_tty_line ();
105 }
106 state_license (f);
107 PR ("");
108 #if defined (BUILD_WIN32)
109 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "WIN32 executable\n") >= 0);
110 WRITE (f, A68 (output_line));
111 WRITELN (f, "");
112 #endif
113 //ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Algol 68 Genie version %d\n", A68_LEVEL) >= 0);
114 //WRITE (f, A68 (output_line));
115 #if (A68_LEVEL >= 3)
116 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With hardware support for long modes\n") >= 0);
117 WRITE (f, A68 (output_line));
118 #endif
119 #if defined (BUILD_A68_COMPILER)
120 WRITE (f, A68 (output_line));
121 #if defined (C_COMPILER)
122 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With plugin-compilation support (back-end is %s)\n", C_COMPILER) >= 0);
123 #else
124 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With compilation support\n") >= 0);
125 #endif
126 WRITE (f, A68 (output_line));
127 #endif
128 #if defined (BUILD_PARALLEL_CLAUSE)
129 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With parallel-clause support\n") >= 0);
130 WRITE (f, A68 (output_line));
131 #endif
132 #if defined (HAVE_GNU_MPFR)
133 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With GNU MP %s\n", gmp_version) >= 0);
134 WRITE (f, A68 (output_line));
135 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With GNU MPFR %s\n", mpfr_get_version ()) >= 0);
136 WRITE (f, A68 (output_line));
137 #endif
138 #if defined (HAVE_MATHLIB)
139 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With mathlib from R %s\n", R_VERSION_STRING) >= 0);
140 WRITE (f, A68 (output_line));
141 #endif
142 #if defined (HAVE_GSL)
143 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With GNU Scientific Library %s\n", GSL_VERSION) >= 0);
144 WRITE (f, A68 (output_line));
145 #endif
146 #if defined (HAVE_GNU_PLOTUTILS)
147 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With GNU plotutils %s\n", PL_LIBPLOT_VER_STRING) >= 0);
148 WRITE (f, A68 (output_line));
149 #endif
150 #if defined (HAVE_CURSES)
151 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With curses %s\n", NCURSES_VERSION) >= 0);
152 WRITE (f, A68 (output_line));
153 #endif
154 #if defined (BUILD_HTTP)
155 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With TCP/IP support\n") >= 0);
156 WRITE (f, A68 (output_line));
157 #endif
158 #if defined (HAVE_POSTGRESQL)
159 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "With PostgreSQL support\n") >= 0);
160 WRITE (f, A68 (output_line));
161 #endif
162 #if defined (_CS_GNU_LIBC_VERSION) && defined (BUILD_UNIX)
163 if (confstr (_CS_GNU_LIBC_VERSION, A68 (input_line), BUFFER_SIZE) > (size_t) 0) {
164 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "GNU libc version %s\n", A68 (input_line)) >= 0);
165 WRITE (f, A68 (output_line));
166 }
167 #if (defined (BUILD_PARALLEL_CLAUSE) && defined (_CS_GNU_LIBPTHREAD_VERSION))
168 if (confstr (_CS_GNU_LIBPTHREAD_VERSION, A68 (input_line), BUFFER_SIZE) > (size_t) 0) {
169 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "GNU libpthread version %s\n", A68 (input_line)) >= 0);
170 WRITE (f, A68 (output_line));
171 }
172 #endif
173 #endif
174 #undef PR
175 }
176
177 //! @brief Give brief help if someone types 'a68g --help'.
178
179 void online_help (FILE_T f)
180 {
181 if (f == STDOUT_FILENO) {
182 io_close_tty_line ();
183 }
184 state_license (f);
185 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Usage: %s [options | filename]", A68 (a68_cmd_name)) >= 0);
186 WRITELN (f, A68 (output_line));
187 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "For help: %s --apropos [keyword]", A68 (a68_cmd_name)) >= 0);
188 WRITELN (f, A68 (output_line));
189 }
190
191 //! @brief Start book keeping for a phase.
192
193 void announce_phase (char *t)
194 {
195 if (OPTION_VERBOSE (&A68_JOB)) {
196 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: %s", A68 (a68_cmd_name), t) >= 0);
197 io_close_tty_line ();
198 WRITE (STDOUT_FILENO, A68 (output_line));
199 }
200 }
201
202 //! @brief Test extension and strip.
203
204 BOOL_T strip_extension (char *ext)
205 {
206 if (ext == NO_TEXT) {
207 return A68_FALSE;
208 }
209 int nlen = (int) strlen (FILE_SOURCE_NAME (&A68_JOB)), xlen = (int) strlen (ext);
210 if (nlen > xlen && strcmp (&(FILE_SOURCE_NAME (&A68_JOB)[nlen - xlen]), ext) == 0) {
211 char *fn = (char *) get_heap_space ((size_t) (nlen + 1));
212 bufcpy (fn, FILE_SOURCE_NAME (&A68_JOB), nlen);
213 fn[nlen - xlen] = NULL_CHAR;
214 a68_free (FILE_GENERIC_NAME (&A68_JOB));
215 FILE_GENERIC_NAME (&A68_JOB) = new_string (fn, NO_TEXT);
216 a68_free (fn);
217 return A68_TRUE;
218 } else {
219 return A68_FALSE;
220 }
221 }
222
223 //! @brief Try opening with an extension.
224
225 void open_with_extensions (void)
226 {
227 int k;
228 FILE_SOURCE_FD (&A68_JOB) = -1;
229 for (k = 0; k < EXTENSIONS && FILE_SOURCE_FD (&A68_JOB) == -1; k++) {
230 int len;
231 char *fn = NULL;
232 if (extensions[k] == NO_TEXT) {
233 len = (int) strlen (FILE_INITIAL_NAME (&A68_JOB)) + 1;
234 fn = (char *) get_heap_space ((size_t) len);
235 bufcpy (fn, FILE_INITIAL_NAME (&A68_JOB), len);
236 } else {
237 len = (int) strlen (FILE_INITIAL_NAME (&A68_JOB)) + (int) strlen (extensions[k]) + 1;
238 fn = (char *) get_heap_space ((size_t) len);
239 bufcpy (fn, FILE_INITIAL_NAME (&A68_JOB), len);
240 bufcat (fn, extensions[k], len);
241 }
242 FILE_SOURCE_FD (&A68_JOB) = open (fn, O_RDONLY | O_BINARY);
243 if (FILE_SOURCE_FD (&A68_JOB) != -1) {
244 int l;
245 BOOL_T cont = A68_TRUE;
246 a68_free (FILE_SOURCE_NAME (&A68_JOB));
247 a68_free (FILE_GENERIC_NAME (&A68_JOB));
248 FILE_SOURCE_NAME (&A68_JOB) = new_string (fn, NO_TEXT);
249 FILE_GENERIC_NAME (&A68_JOB) = new_string (a68_basename (fn), NO_TEXT);
250 FILE_PATH (&A68_JOB) = new_string (a68_dirname (fn), NO_TEXT);
251 for (l = 0; l < EXTENSIONS && cont; l++) {
252 if (strip_extension (extensions[l])) {
253 cont = A68_FALSE;
254 }
255 }
256 }
257 a68_free (fn);
258 }
259 }
260
261 //! @brief Remove a regular file.
262
263 void a68_rm (char *fn)
264 {
265 struct stat path_stat;
266 if (stat (fn, &path_stat) == 0) {
267 if (S_ISREG (path_stat.st_mode)) {
268 ABEND (remove (fn) != 0, ERROR_ACTION, FILE_OBJECT_NAME (&A68_JOB));
269 }
270 }
271 }
272
273 //! @brief Drives compilation and interpretation.
274
275 void compiler_interpreter (void)
276 {
277 int len, num;
278 #if defined (BUILD_A68_COMPILER)
279 BOOL_T emitted = A68_FALSE;
280 #endif
281 TREE_LISTING_SAFE (&A68_JOB) = A68_FALSE;
282 CROSS_REFERENCE_SAFE (&A68_JOB) = A68_FALSE;
283 A68 (in_execution) = A68_FALSE;
284 A68 (new_nodes) = 0;
285 A68 (new_modes) = 0;
286 A68 (new_postulates) = 0;
287 A68 (new_node_infos) = 0;
288 A68 (new_genie_infos) = 0;
289 A68 (symbol_table_count) = 0;
290 A68 (mode_count) = 0;
291 A68 (node_register) = NO_VAR;
292 init_postulates ();
293 A68 (do_confirm_exit) = A68_TRUE;
294 A68 (f_entry) = NO_NODE;
295 A68 (global_level) = 0;
296 A68 (max_lex_lvl) = 0;
297 A68_PARSER (stop_scanner) = A68_FALSE;
298 A68_PARSER (read_error) = A68_FALSE;
299 A68_PARSER (no_preprocessing) = A68_FALSE;
300 A68_PARSER (reductions) = 0;
301 A68_PARSER (tag_number) = 0;
302 A68 (curses_mode) = A68_FALSE;
303 A68 (top_soid_list) = NO_SOID;
304 A68 (max_simplout_size) = 0;
305 A68_MON (in_monitor) = A68_FALSE;
306 A68_MP (mp_ln_scale_size) = -1;
307 A68_MP (mp_ln_10_size) = -1;
308 A68_MP (mp_gamma_size) = -1;
309 A68_MP (mp_one_size) = -1;
310 A68_MP (mp_pi_size) = -1;
311 // File set-up.
312 SCAN_ERROR (FILE_INITIAL_NAME (&A68_JOB) == NO_TEXT, NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE);
313 FILE_BINARY_OPENED (&A68_JOB) = A68_FALSE;
314 FILE_BINARY_WRITEMOOD (&A68_JOB) = A68_TRUE;
315 FILE_PLUGIN_OPENED (&A68_JOB) = A68_FALSE;
316 FILE_PLUGIN_WRITEMOOD (&A68_JOB) = A68_TRUE;
317 FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE;
318 FILE_LISTING_WRITEMOOD (&A68_JOB) = A68_TRUE;
319 FILE_OBJECT_OPENED (&A68_JOB) = A68_FALSE;
320 FILE_OBJECT_WRITEMOOD (&A68_JOB) = A68_TRUE;
321 FILE_PRETTY_OPENED (&A68_JOB) = A68_FALSE;
322 FILE_SCRIPT_OPENED (&A68_JOB) = A68_FALSE;
323 FILE_SCRIPT_WRITEMOOD (&A68_JOB) = A68_FALSE;
324 FILE_SOURCE_OPENED (&A68_JOB) = A68_FALSE;
325 FILE_SOURCE_WRITEMOOD (&A68_JOB) = A68_FALSE;
326 FILE_DIAGS_OPENED (&A68_JOB) = A68_FALSE;
327 FILE_DIAGS_WRITEMOOD (&A68_JOB) = A68_TRUE;
328 // Open the source file.
329 // Open it for binary reading for systems that require so (Win32).
330 // Accept various silent extensions.
331 errno = 0;
332 FILE_SOURCE_NAME (&A68_JOB) = NO_TEXT;
333 FILE_GENERIC_NAME (&A68_JOB) = NO_TEXT;
334 open_with_extensions ();
335 if (FILE_SOURCE_NAME (&A68_JOB) == NO_TEXT) {
336 errno = ENOENT;
337 SCAN_ERROR (A68_TRUE, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
338 } else {
339 struct stat path_stat;
340 errno = 0;
341 SCAN_ERROR (stat (FILE_SOURCE_NAME (&A68_JOB), &path_stat) != 0, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
342 SCAN_ERROR (S_ISDIR (path_stat.st_mode), NO_LINE, NO_TEXT, ERROR_IS_DIRECTORY);
343 SCAN_ERROR (!S_ISREG (path_stat.st_mode), NO_LINE, NO_TEXT, ERROR_NO_REGULAR_FILE);
344 }
345 if (FILE_SOURCE_FD (&A68_JOB) == -1) {
346 scan_error (NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
347 }
348 ABEND (FILE_SOURCE_NAME (&A68_JOB) == NO_TEXT, ERROR_INTERNAL_CONSISTENCY, __func__);
349 ABEND (FILE_GENERIC_NAME (&A68_JOB) == NO_TEXT, ERROR_INTERNAL_CONSISTENCY, __func__);
350 // Object file.
351 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (OBJECT_EXTENSION);
352 FILE_OBJECT_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
353 bufcpy (FILE_OBJECT_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
354 bufcat (FILE_OBJECT_NAME (&A68_JOB), OBJECT_EXTENSION, len);
355 // Binary.
356 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (PLUGIN_EXTENSION);
357 FILE_BINARY_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
358 bufcpy (FILE_BINARY_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
359 bufcat (FILE_BINARY_NAME (&A68_JOB), BINARY_EXTENSION, len);
360 // Library file.
361 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (PLUGIN_EXTENSION);
362 FILE_PLUGIN_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
363 bufcpy (FILE_PLUGIN_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
364 bufcat (FILE_PLUGIN_NAME (&A68_JOB), PLUGIN_EXTENSION, len);
365 // Listing file.
366 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (LISTING_EXTENSION);
367 FILE_LISTING_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
368 bufcpy (FILE_LISTING_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
369 bufcat (FILE_LISTING_NAME (&A68_JOB), LISTING_EXTENSION, len);
370 // Pretty file.
371 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (PRETTY_EXTENSION);
372 FILE_PRETTY_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
373 bufcpy (FILE_PRETTY_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
374 bufcat (FILE_PRETTY_NAME (&A68_JOB), PRETTY_EXTENSION, len);
375 // Script file.
376 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (SCRIPT_EXTENSION);
377 FILE_SCRIPT_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
378 bufcpy (FILE_SCRIPT_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
379 bufcat (FILE_SCRIPT_NAME (&A68_JOB), SCRIPT_EXTENSION, len);
380 // Parser.
381 a68_parser ();
382 if (TOP_NODE (&A68_JOB) == NO_NODE) {
383 errno = ECANCELED;
384 ABEND (A68_TRUE, ERROR_SOURCE_FILE_EMPTY, NO_TEXT);
385 }
386 // Portability checker.
387 if (ERROR_COUNT (&A68_JOB) == 0) {
388 announce_phase ("portability checker");
389 portcheck (TOP_NODE (&A68_JOB));
390 verbosity ();
391 }
392 // Finalise syntax tree.
393 if (ERROR_COUNT (&A68_JOB) == 0) {
394 num = 0;
395 renumber_nodes (TOP_NODE (&A68_JOB), &num);
396 NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3;
397 reset_symbol_table_nest_count (TOP_NODE (&A68_JOB));
398 verbosity ();
399 }
400 //
401 if (A68_MP (varying_mp_digits) > width_to_mp_digits (MP_MAX_DECIMALS)) {
402 diagnostic (A68_WARNING, NO_NODE, WARNING_PRECISION, NO_LINE, 0, A68_MP (varying_mp_digits) * LOG_MP_RADIX);
403 }
404 // Compiler.
405 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_OPT_LEVEL (&A68_JOB) > NO_OPTIMISE) {
406 announce_phase ("optimiser (code generator)");
407 num = 0;
408 renumber_nodes (TOP_NODE (&A68_JOB), &num);
409 A68 (node_register) = (NODE_T **) get_heap_space ((size_t) num * sizeof (NODE_T));
410 ABEND (A68 (node_register) == NO_VAR, ERROR_ACTION, __func__);
411 register_nodes (TOP_NODE (&A68_JOB));
412 FILE_OBJECT_FD (&A68_JOB) = open (FILE_OBJECT_NAME (&A68_JOB), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION);
413 ABEND (FILE_OBJECT_FD (&A68_JOB) == -1, ERROR_ACTION, FILE_OBJECT_NAME (&A68_JOB));
414 FILE_OBJECT_OPENED (&A68_JOB) = A68_TRUE;
415 compiler (FILE_OBJECT_FD (&A68_JOB));
416 ASSERT (close (FILE_OBJECT_FD (&A68_JOB)) == 0);
417 FILE_OBJECT_OPENED (&A68_JOB) = A68_FALSE;
418 #if defined (BUILD_A68_COMPILER)
419 emitted = A68_TRUE;
420 #endif
421 }
422 #if defined (BUILD_A68_COMPILER)
423 // Only compile C if the A68 compiler found no errors (constant folder for instance).
424 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_OPT_LEVEL (&A68_JOB) > 0 && !OPTION_RUN_SCRIPT (&A68_JOB)) {
425 char cmd[BUFFER_SIZE], options[BUFFER_SIZE];
426 if (OPTION_RERUN (&A68_JOB) == A68_FALSE) {
427 announce_phase ("optimiser (code compiler)");
428 errno = 0;
429 //
430 // Compilation on Linux, BSD.
431 // Build shared library using gcc or clang.
432 // TODO: One day this should be all portable between platforms.
433 //
434 // -fno-stack-protector is needed for OS's that enforce -fstack-protector-strong which may give
435 // undefined reference to `__stack_chk_fail_local'
436 // by ld. Ubuntu is one such.
437 //
438 ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s", optimisation_option (), A68_GCC_OPTIONS) >= 0);
439 #if defined (HAVE_PIC)
440 bufcat (options, " ", BUFFER_SIZE);
441 bufcat (options, HAVE_PIC, BUFFER_SIZE);
442 #endif
443 ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s -I%s %s -c -o \"%s\" \"%s\"", C_COMPILER, INCLUDEDIR, options, FILE_BINARY_NAME (&A68_JOB), FILE_OBJECT_NAME (&A68_JOB)) >= 0);
444 ABEND (system (cmd) != 0, ERROR_ACTION, cmd);
445 ASSERT (snprintf (cmd, SNPRINTF_SIZE, "ld -export-dynamic -shared -o \"%s\" \"%s\"", FILE_PLUGIN_NAME (&A68_JOB), FILE_BINARY_NAME (&A68_JOB)) >= 0);
446 ABEND (system (cmd) != 0, ERROR_ACTION, cmd);
447 a68_rm (FILE_BINARY_NAME (&A68_JOB));
448 }
449 verbosity ();
450 }
451 #else
452 if (OPTION_OPT_LEVEL (&A68_JOB) > 0) {
453 diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, TOP_NODE (&A68_JOB), WARNING_OPTIMISATION);
454 }
455 #endif
456 // Indenter.
457 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_PRETTY (&A68_JOB)) {
458 announce_phase ("indenter");
459 indenter (&A68_JOB);
460 verbosity ();
461 }
462 // Interpreter.
463 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
464 // Restore seed for rng.
465 GetRNGstate ();
466 A68 (f_entry) = TOP_NODE (&A68_JOB);
467 //
468 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_COMPILE (&A68_JOB) == A68_FALSE && (OPTION_CHECK_ONLY (&A68_JOB) ? OPTION_RUN (&A68_JOB) : A68_TRUE)) {
469 #if defined (BUILD_A68_COMPILER)
470 void *compile_plugin;
471 #endif
472 A68 (close_tty_on_exit) = A68_FALSE; // Assuming no runtime errors a priori
473 #if defined (BUILD_A68_COMPILER)
474 if (OPTION_RUN_SCRIPT (&A68_JOB)) {
475 rewrite_script_source ();
476 }
477 #endif
478 if (OPTION_DEBUG (&A68_JOB)) {
479 state_license (STDOUT_FILENO);
480 }
481 #if defined (BUILD_A68_COMPILER)
482 if (OPTION_OPT_LEVEL (&A68_JOB) > 0) {
483 char plugin_name[BUFFER_SIZE];
484 void *a68_plugin;
485 struct stat srcstat, objstat;
486 int ret;
487 announce_phase ("dynamic linker");
488 ASSERT (snprintf (plugin_name, SNPRINTF_SIZE, "%s", FILE_PLUGIN_NAME (&A68_JOB)) >= 0);
489 // Correction when pwd is outside LD_PLUGIN_PATH.
490 // The DL cannot be loaded if it is.
491 if (strcmp (plugin_name, a68_basename (plugin_name)) == 0) {
492 ASSERT (snprintf (plugin_name, SNPRINTF_SIZE, "./%s", FILE_PLUGIN_NAME (&A68_JOB)) >= 0);
493 }
494 // Check whether we are doing something rash.
495 ret = stat (FILE_SOURCE_NAME (&A68_JOB), &srcstat);
496 ABEND (ret != 0, ERROR_ACTION, FILE_SOURCE_NAME (&A68_JOB));
497 ret = stat (plugin_name, &objstat);
498 ABEND (ret != 0, ERROR_ACTION, plugin_name);
499 if (OPTION_RERUN (&A68_JOB)) {
500 ABEND (ST_MTIME (&srcstat) > ST_MTIME (&objstat), "plugin outdates source", "cannot RERUN");
501 }
502 // First load a68g itself so compiler code can resolve a68g symbols.
503 a68_plugin = dlopen (NULL, RTLD_NOW | RTLD_GLOBAL);
504 ABEND (a68_plugin == NULL, ERROR_CANNOT_OPEN_PLUGIN, dlerror ());
505 // Then load compiler code.
506 compile_plugin = dlopen (plugin_name, RTLD_NOW | RTLD_GLOBAL);
507 ABEND (compile_plugin == NULL, ERROR_CANNOT_OPEN_PLUGIN, dlerror ());
508 } else {
509 compile_plugin = NULL;
510 }
511 announce_phase ("genie");
512 genie (compile_plugin);
513 // Unload compiler plugin.
514 if (OPTION_OPT_LEVEL (&A68_JOB) > 0) {
515 int ret = dlclose (compile_plugin);
516 ABEND (ret != 0, ERROR_ACTION, dlerror ());
517 }
518 #else
519 announce_phase ("genie");
520 genie (NO_NODE);
521 #endif
522 // Free heap allocated by genie.
523 genie_free (TOP_NODE (&A68_JOB));
524 // Store seed for rng.
525 announce_phase ("store rng state");
526 PutRNGstate ();
527 // Normal end of program.
528 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR);
529 if (OPTION_DEBUG (&A68_JOB) || OPTION_TRACE (&A68_JOB) || OPTION_CLOCK (&A68_JOB)) {
530 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nGenie finished in %.2f seconds\n", seconds () - A68 (cputime_0)) >= 0);
531 WRITE (STDOUT_FILENO, A68 (output_line));
532 }
533 verbosity ();
534 }
535 // Setting up listing file.
536 announce_phase ("write listing");
537 if (OPTION_MOID_LISTING (&A68_JOB) || OPTION_TREE_LISTING (&A68_JOB) || OPTION_SOURCE_LISTING (&A68_JOB) || OPTION_OBJECT_LISTING (&A68_JOB) || OPTION_STATISTICS_LISTING (&A68_JOB)) {
538 FILE_LISTING_FD (&A68_JOB) = open (FILE_LISTING_NAME (&A68_JOB), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION);
539 ABEND (FILE_LISTING_FD (&A68_JOB) == -1, ERROR_ACTION, __func__);
540 FILE_LISTING_OPENED (&A68_JOB) = A68_TRUE;
541 } else {
542 FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE;
543 }
544 // Write listing.
545 if (FILE_LISTING_OPENED (&A68_JOB)) {
546 A68 (heap_is_fluid) = A68_TRUE;
547 write_listing_header ();
548 write_source_listing ();
549 write_tree_listing ();
550 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_OPT_LEVEL (&A68_JOB) > 0) {
551 write_object_listing ();
552 }
553 write_listing ();
554 ASSERT (close (FILE_LISTING_FD (&A68_JOB)) == 0);
555 FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE;
556 verbosity ();
557 }
558 // Cleaning up the intermediate files.
559 #if defined (BUILD_A68_COMPILER)
560 announce_phase ("clean up intermediate files");
561 if (OPTION_OPT_LEVEL (&A68_JOB) >= OPTIMISE_0 && OPTION_REGRESSION_TEST (&A68_JOB) && !OPTION_KEEP (&A68_JOB)) {
562 if (emitted) {
563 a68_rm (FILE_OBJECT_NAME (&A68_JOB));
564 }
565 a68_rm (FILE_PLUGIN_NAME (&A68_JOB));
566 }
567 if (OPTION_RUN_SCRIPT (&A68_JOB) && !OPTION_KEEP (&A68_JOB)) {
568 if (emitted) {
569 a68_rm (FILE_OBJECT_NAME (&A68_JOB));
570 }
571 a68_rm (FILE_SOURCE_NAME (&A68_JOB));
572 a68_rm (FILE_PLUGIN_NAME (&A68_JOB));
573 } else if (OPTION_COMPILE (&A68_JOB)) {
574 build_script ();
575 if (!OPTION_KEEP (&A68_JOB)) {
576 if (emitted) {
577 a68_rm (FILE_OBJECT_NAME (&A68_JOB));
578 }
579 a68_rm (FILE_PLUGIN_NAME (&A68_JOB));
580 }
581 } else if (OPTION_OPT_LEVEL (&A68_JOB) == OPTIMISE_0 && !OPTION_KEEP (&A68_JOB)) {
582 if (emitted) {
583 a68_rm (FILE_OBJECT_NAME (&A68_JOB));
584 }
585 a68_rm (FILE_PLUGIN_NAME (&A68_JOB));
586 } else if (OPTION_OPT_LEVEL (&A68_JOB) > OPTIMISE_0 && !OPTION_KEEP (&A68_JOB)) {
587 if (emitted) {
588 a68_rm (FILE_OBJECT_NAME (&A68_JOB));
589 }
590 } else if (OPTION_RERUN (&A68_JOB) && !OPTION_KEEP (&A68_JOB)) {
591 if (emitted) {
592 a68_rm (FILE_OBJECT_NAME (&A68_JOB));
593 }
594 }
595 #endif
596 }
597
598 //! @brief Exit a68g in an orderly manner.
599
600 void a68_exit (int code)
601 {
602 announce_phase ("exit");
603 #if defined (HAVE_GNU_MPFR)
604 mpfr_free_cache ();
605 #endif
606 // Close unclosed files, remove temp files.
607 free_file_entries ();
608 // Close the terminal.
609 if (A68 (close_tty_on_exit) || OPTION_REGRESSION_TEST (&A68_JOB)) {
610 io_close_tty_line ();
611 } else if (OPTION_VERBOSE (&A68_JOB)) {
612 io_close_tty_line ();
613 }
614 #if defined (HAVE_CURSES)
615 // "curses" might still be open if it was not closed from A68, or the program
616 // was interrupted, or a runtime error occured. That wreaks havoc on your
617 // terminal.
618 genie_curses_end (NO_NODE);
619 #endif
620 // Clean up stale things.
621 free_syntax_tree (TOP_NODE (&A68_JOB));
622 free_option_list (OPTION_LIST (&A68_JOB));
623 a68_free (A68 (node_register));
624 a68_free (A68 (options));
625 //
626 discard_heap ();
627 //
628 a68_free (FILE_PATH (&A68_JOB));
629 a68_free (FILE_INITIAL_NAME (&A68_JOB));
630 a68_free (FILE_GENERIC_NAME (&A68_JOB));
631 a68_free (FILE_SOURCE_NAME (&A68_JOB));
632 a68_free (FILE_LISTING_NAME (&A68_JOB));
633 a68_free (FILE_OBJECT_NAME (&A68_JOB));
634 a68_free (FILE_PLUGIN_NAME (&A68_JOB));
635 a68_free (FILE_BINARY_NAME (&A68_JOB));
636 a68_free (FILE_PRETTY_NAME (&A68_JOB));
637 a68_free (FILE_SCRIPT_NAME (&A68_JOB));
638 a68_free (FILE_DIAGS_NAME (&A68_JOB));
639 //
640 a68_free (A68_MP (mp_one));
641 a68_free (A68_MP (mp_pi));
642 a68_free (A68_MP (mp_half_pi));
643 a68_free (A68_MP (mp_two_pi));
644 a68_free (A68_MP (mp_sqrt_two_pi));
645 a68_free (A68_MP (mp_sqrt_pi));
646 a68_free (A68_MP (mp_ln_pi));
647 a68_free (A68_MP (mp_180_over_pi));
648 a68_free (A68_MP (mp_pi_over_180));
649 //
650 exit (code);
651 }
652
653 //! @brief Main entry point.
654
655 int main (int argc, char *argv[])
656 {
657 BYTE_T stack_offset; // Leave this here!
658 A68 (argc) = argc;
659 A68 (argv) = argv;
660 A68 (close_tty_on_exit) = A68_TRUE;
661 FILE_DIAGS_FD (&A68_JOB) = -1;
662 // Get command name and discard path.
663 bufcpy (A68 (a68_cmd_name), argv[0], BUFFER_SIZE);
664 int k;
665 for (k = (int) strlen (A68 (a68_cmd_name)) - 1; k >= 0; k--) {
666 #if defined (BUILD_WIN32)
667 char delim = '\\';
668 #else
669 char delim = '/';
670 #endif
671 if (A68 (a68_cmd_name)[k] == delim) {
672 MOVE (&A68 (a68_cmd_name)[0], &A68 (a68_cmd_name)[k + 1], (int) strlen (A68 (a68_cmd_name)) - k + 1);
673 k = -1;
674 }
675 }
676 // Try to read maximum line width on the terminal,
677 // used to pretty print diagnostics to same.
678 a68_getty (&A68 (term_heigth), &A68 (term_width));
679 // Determine clock resolution.
680 {
681 clock_t t0 = clock (), t1;
682 do {
683 t1 = clock ();
684 } while (t1 == t0);
685 A68 (clock_res) = (t1 - t0) / (clock_t) CLOCKS_PER_SEC;
686 }
687 // Set the main thread id.
688 #if defined (BUILD_PARALLEL_CLAUSE)
689 A68_PAR (main_thread_id) = pthread_self ();
690 #endif
691 A68 (heap_is_fluid) = A68_TRUE;
692 A68 (system_stack_offset) = &stack_offset;
693 init_file_entries ();
694 if (!setjmp (RENDEZ_VOUS (&A68_JOB))) {
695 init_tty ();
696 // Initialise option handling.
697 init_options ();
698 SOURCE_SCAN (&A68_JOB) = 1;
699 default_options (&A68_JOB);
700 default_mem_sizes (1);
701 // Initialise core.
702 A68_STACK = NO_BYTE;
703 A68_HEAP = NO_BYTE;
704 A68_HANDLES = NO_BYTE;
705 get_stack_size ();
706 // Well, let's start.
707 TOP_REFINEMENT (&A68_JOB) = NO_REFINEMENT;
708 FILE_INITIAL_NAME (&A68_JOB) = NO_TEXT;
709 FILE_GENERIC_NAME (&A68_JOB) = NO_TEXT;
710 FILE_SOURCE_NAME (&A68_JOB) = NO_TEXT;
711 FILE_LISTING_NAME (&A68_JOB) = NO_TEXT;
712 FILE_OBJECT_NAME (&A68_JOB) = NO_TEXT;
713 FILE_PLUGIN_NAME (&A68_JOB) = NO_TEXT;
714 FILE_BINARY_NAME (&A68_JOB) = NO_TEXT;
715 FILE_PRETTY_NAME (&A68_JOB) = NO_TEXT;
716 FILE_SCRIPT_NAME (&A68_JOB) = NO_TEXT;
717 FILE_DIAGS_NAME (&A68_JOB) = NO_TEXT;
718 // Options are processed here.
719 read_rc_options ();
720 read_env_options ();
721 // Posix copies arguments from the command line.
722 if (argc <= 1) {
723 online_help (STDOUT_FILENO);
724 a68_exit (EXIT_FAILURE);
725 }
726 int argcc;
727 for (argcc = 1; argcc < argc; argcc++) {
728 add_option_list (&(OPTION_LIST (&A68_JOB)), argv[argcc], NO_LINE);
729 }
730 if (!set_options (OPTION_LIST (&A68_JOB), A68_TRUE)) {
731 a68_exit (EXIT_FAILURE);
732 }
733 // State license.
734 if (OPTION_LICENSE (&A68_JOB)) {
735 state_license (STDOUT_FILENO);
736 }
737 // State version.
738 if (OPTION_VERSION (&A68_JOB)) {
739 state_version (STDOUT_FILENO);
740 }
741 // Start the UI.
742 init_before_tokeniser ();
743 // Running a script.
744 #if defined (BUILD_A68_COMPILER)
745 if (OPTION_RUN_SCRIPT (&A68_JOB)) {
746 load_script ();
747 }
748 #endif
749 // We translate the program.
750 if (FILE_INITIAL_NAME (&A68_JOB) == NO_TEXT || strlen (FILE_INITIAL_NAME (&A68_JOB)) == 0) {
751 SCAN_ERROR (!(OPTION_LICENSE (&A68_JOB) || OPTION_VERSION (&A68_JOB)), NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE);
752 } else {
753 compiler_interpreter ();
754 }
755 a68_exit (ERROR_COUNT (&A68_JOB) == 0 ? EXIT_SUCCESS : EXIT_FAILURE);
756 return EXIT_SUCCESS;
757 } else {
758 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
759 a68_exit (EXIT_FAILURE);
760 return EXIT_FAILURE;
761 }
762 }
jmvdveer@xs4all.nl