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