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-2024 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 // --assertions, --noassertions, switch elaboration of assertions on or off.
27 // --backtrace, --nobacktrace, switch stack backtracing in case of a runtime error.
28 // --boldstropping, set stropping mode to bold stropping.
29 // --brackets, consider [ .. ] and { .. } as equivalent to ( .. ).
30 // --check, --norun, check syntax only, interpreter does not start.
31 // --clock, report execution time excluding compilation time.
32 // --compile, compile source file.
33 // --debug, --monitor, start execution in the debugger and debug in case of runtime error.
34 // --echo string, echo 'string' to standard output.
35 // --execute unit, execute algol 68 unit 'unit'.
36 // --exit, --, ignore next options.
37 // --extensive, make extensive listing.
38 // --file string, accept string as generic filename.
39 // --frame 'number', set frame stack size to 'number'.
40 // --handles 'number', set handle space size to 'number'.
41 // --heap 'number', set heap size to 'number'.
42 // --keep, --nokeep, switch object file deletion off or on.
43 // --listing, make concise listing.
44 // --moids, make overview of moids in listing file.
45 // -O0, -O1, -O2, -O3, switch compilation on and pass option to back-end C compiler.
46 // --optimise, --nooptimise, switch compilation on or off.
47 // --pedantic, equivalent to --warnings --portcheck.
48 // --portcheck, --noportcheck, switch portability warnings on or off.
49 // --pragmats, --nopragmats, switch elaboration of pragmat items on or off.
50 // --precision 'number', set precision for long long modes to 'number' significant digits.
51 // --preludelisting, make a listing of preludes.
52 // --pretty-print, pretty-print the source file.
53 // --print unit, print value yielded by algol 68 unit 'unit'.
54 // --quiet, suppresses all warning diagnostics.
55 // --quotestropping, set stropping mode to quote stropping.
56 // --reductions, print parser reductions.
57 // --run, override --check/--norun options.
58 // --rerun, run using already compiled code.
59 // --script, set next option as source file name; pass further options to algol 68 program.
60 // --source, --nosource, switch listing of source lines in listing file on or off.
61 // --stack 'number', set expression stack size to 'number'.
62 // --statistics, print statistics in listing file.
63 // --strict, disable most extensions to Algol 68 syntax.
64 // --timelimit 'number', interrupt the interpreter after 'number' seconds.
65 // --trace, --notrace, switch tracing of a running program on or off.
66 // --tree, --notree, switch syntax tree listing in listing file on or off.
67 // --unused, make an overview of unused tags in the listing file.
68 // --verbose, inform on program actions.
69 // --version, state version of the running copy.
70 // --warnings, --nowarnings, switch warning diagnostics on or off.
71 // --xref, --noxref, switch cross reference in the listing file on or off.
72
73 #include "a68g.h"
74 #include "a68g-listing.h"
75 #include "a68g-mp.h"
76 #include "a68g-optimiser.h"
77 #include "a68g-options.h"
78 #include "a68g-parser.h"
79 #include "a68g-postulates.h"
80 #include "a68g-genie.h"
81 #include "a68g-prelude.h"
82 #include "a68g-prelude-mathlib.h"
83
84 #if defined (HAVE_MATHLIB)
85 #include <Rmath.h>
86 #endif
87
88 #if defined (HAVE_CURL)
89 #include <curl/curl.h>
90 #endif
91
92 GLOBALS_T common;
93
94 #define EXTENSIONS 11
95 static char *extensions[EXTENSIONS] = {
96 NO_TEXT,
97 ".a68", ".A68",
98 ".a68g", ".A68G",
99 ".algol", ".ALGOL",
100 ".algol68", ".ALGOL68",
101 ".algol68g", ".ALGOL68G"
102 };
103
104 void compiler_interpreter (void);
105
106 //! @brief Verbose statistics, only useful when debugging a68g.
107
108 void verbosity (void)
109 {
110 #if defined (A68_DEBUG)
111 ;
112 #else
113 ;
114 #endif
115 }
116
117 //! @brief State license of running a68g image.
118
119 void state_license (FILE_T f)
120 {
121 #define PR(s)\
122 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "%s\n", (s)) >= 0);\
123 WRITE (f, A68 (output_line));
124 if (f == A68_STDOUT) {
125 io_close_tty_line ();
126 }
127 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Algol 68 Genie %s\n", PACKAGE_VERSION) >= 0);
128 WRITE (f, A68 (output_line));
129 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Copyright 2001-2024 %s.\n", PACKAGE_BUGREPORT) >= 0);
130 WRITE (f, A68 (output_line));
131 PR ("");
132 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "This is free software covered by the GNU General Public License.\n") >= 0);
133 WRITE (f, A68 (output_line));
134 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "There is ABSOLUTELY NO WARRANTY for Algol 68 Genie;\n") >= 0);
135 WRITE (f, A68 (output_line));
136 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n") >= 0);
137 WRITE (f, A68 (output_line));
138 PR ("See the GNU General Public License for more details.");
139 PR ("");
140 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Please report bugs to %s.\n", PACKAGE_BUGREPORT) >= 0);
141 WRITE (f, A68 (output_line));
142 #undef PR
143 }
144
145 //! @brief State version of running a68g image.
146
147 void state_version (FILE_T f)
148 {
149 #define PR(s)\
150 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "%s\n", (s)) >= 0);\
151 WRITE (f, A68 (output_line));
152 if (f == A68_STDOUT) {
153 io_close_tty_line ();
154 }
155 state_license (f);
156 PR ("");
157 #if defined (BUILD_WIN32)
158 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "WIN32 executable\n") >= 0);
159 WRITE (f, A68 (output_line));
160 WRITELN (f, "");
161 #endif
162 #if (A68_LEVEL >= 3)
163 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With hardware support for long modes\n") >= 0);
164 WRITE (f, A68 (output_line));
165 #endif
166 #if defined (BUILD_A68_COMPILER)
167 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With plugin-compilation support\n") >= 0);
168 WRITE (f, A68 (output_line));
169 #endif
170 #if defined (BUILD_PARALLEL_CLAUSE)
171 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With parallel-clause support\n") >= 0);
172 WRITE (f, A68 (output_line));
173 #endif
174 #if defined (HAVE_POSTGRESQL)
175 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With PostgreSQL support\n") >= 0);
176 WRITE (f, A68 (output_line));
177 #endif
178 #if defined (HAVE_CURL)
179 curl_version_info_data *data = curl_version_info(CURLVERSION_NOW);
180 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With curl %s\n", data->version) >= 0);
181 WRITE (f, A68 (output_line));
182 #endif
183 #if defined (HAVE_GNU_MPFR)
184 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With GNU MP %s\n", gmp_version) >= 0);
185 WRITE (f, A68 (output_line));
186 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With GNU MPFR %s\n", mpfr_get_version ()) >= 0);
187 WRITE (f, A68 (output_line));
188 #endif
189 #if defined (HAVE_MATHLIB)
190 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With mathlib from R %s\n", R_VERSION_STRING) >= 0);
191 WRITE (f, A68 (output_line));
192 #endif
193 #if defined (HAVE_GSL)
194 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With GNU Scientific Library %s\n", GSL_VERSION) >= 0);
195 WRITE (f, A68 (output_line));
196 #endif
197 #if defined (HAVE_GNU_PLOTUTILS)
198 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With GNU plotutils %s\n", PL_LIBPLOT_VER_STRING) >= 0);
199 WRITE (f, A68 (output_line));
200 #endif
201 #if defined (HAVE_CURSES)
202 #if defined (NCURSES_VERSION)
203 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With ncurses %s\n", NCURSES_VERSION) >= 0);
204 #else
205 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "With curses support\n") >= 0);
206 #endif
207 WRITE (f, A68 (output_line));
208 #endif
209 #if defined (_CS_GNU_LIBC_VERSION) && defined (BUILD_UNIX)
210 if (confstr (_CS_GNU_LIBC_VERSION, A68 (input_line), BUFFER_SIZE) > (size_t) 0) {
211 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "GNU libc version %s\n", A68 (input_line)) >= 0);
212 WRITE (f, A68 (output_line));
213 }
214 #if (defined (BUILD_PARALLEL_CLAUSE) && defined (_CS_GNU_LIBPTHREAD_VERSION))
215 if (confstr (_CS_GNU_LIBPTHREAD_VERSION, A68 (input_line), BUFFER_SIZE) > (size_t) 0) {
216 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "GNU libpthread version %s\n", A68 (input_line)) >= 0);
217 WRITE (f, A68 (output_line));
218 }
219 #endif
220 #endif
221 #define RSIZE(n) (unt) (sizeof (n) / sizeof (int))
222 #if defined (BUILD_A68_COMPILER) && defined (C_COMPILER)
223 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Build level %d.%x%x%x%x %s %s\n", A68_LEVEL, RSIZE (INT_T), RSIZE (REAL_T), RSIZE (MP_INT_T), RSIZE (MP_REAL_T), C_COMPILER, __DATE__) >= 0);
224 #else
225 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Build level %d.%x%x%x%x %s\n", A68_LEVEL, RSIZE (INT_T), RSIZE (REAL_T), RSIZE (MP_INT_T), RSIZE (MP_REAL_T), __DATE__) >= 0);
226 #endif
227 #undef RSIZE
228 WRITE (f, A68 (output_line));
229 #undef PR
230 }
231
232 //! @brief Give brief help if someone types 'a68g --help'.
233
234 void online_help (FILE_T f)
235 {
236 if (f == A68_STDOUT) {
237 io_close_tty_line ();
238 }
239 state_license (f);
240 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "Usage: %s [options | filename]", A68 (a68_cmd_name)) >= 0);
241 WRITELN (f, A68 (output_line));
242 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "For help: %s --apropos [keyword]", A68 (a68_cmd_name)) >= 0);
243 WRITELN (f, A68 (output_line));
244 }
245
246 //! @brief Start book keeping for a phase.
247
248 void announce_phase (char *t)
249 {
250 if (OPTION_VERBOSE (&A68_JOB)) {
251 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "%s: %s", A68 (a68_cmd_name), t) >= 0);
252 io_close_tty_line ();
253 WRITE (A68_STDOUT, A68 (output_line));
254 }
255 }
256
257 //! @brief Test extension and strip.
258
259 BOOL_T strip_extension (char *ext)
260 {
261 if (ext == NO_TEXT) {
262 return A68_FALSE;
263 }
264 int nlen = (int) strlen (FILE_SOURCE_NAME (&A68_JOB)), xlen = (int) strlen (ext);
265 if (nlen > xlen && strcmp (&(FILE_SOURCE_NAME (&A68_JOB)[nlen - xlen]), ext) == 0) {
266 char *fn = (char *) get_heap_space ((size_t) (nlen + 1));
267 a68_bufcpy (fn, FILE_SOURCE_NAME (&A68_JOB), nlen);
268 fn[nlen - xlen] = NULL_CHAR;
269 a68_free (FILE_GENERIC_NAME (&A68_JOB));
270 FILE_GENERIC_NAME (&A68_JOB) = new_string (fn, NO_TEXT);
271 a68_free (fn);
272 return A68_TRUE;
273 } else {
274 return A68_FALSE;
275 }
276 }
277
278 //! @brief Try opening with an extension.
279
280 void open_with_extensions (void)
281 {
282 FILE_SOURCE_FD (&A68_JOB) = -1;
283 for (int k = 0; k < EXTENSIONS && FILE_SOURCE_FD (&A68_JOB) == -1; k++) {
284 int len;
285 char *fn = NULL;
286 if (extensions[k] == NO_TEXT) {
287 len = (int) strlen (FILE_INITIAL_NAME (&A68_JOB)) + 1;
288 fn = (char *) get_heap_space ((size_t) len);
289 a68_bufcpy (fn, FILE_INITIAL_NAME (&A68_JOB), len);
290 } else {
291 len = (int) strlen (FILE_INITIAL_NAME (&A68_JOB)) + (int) strlen (extensions[k]) + 1;
292 fn = (char *) get_heap_space ((size_t) len);
293 a68_bufcpy (fn, FILE_INITIAL_NAME (&A68_JOB), len);
294 a68_bufcat (fn, extensions[k], len);
295 }
296 FILE_SOURCE_FD (&A68_JOB) = open (fn, O_RDONLY | O_BINARY);
297 if (FILE_SOURCE_FD (&A68_JOB) != -1) {
298 BOOL_T cont = A68_TRUE;
299 a68_free (FILE_SOURCE_NAME (&A68_JOB));
300 a68_free (FILE_GENERIC_NAME (&A68_JOB));
301 FILE_SOURCE_NAME (&A68_JOB) = new_string (fn, NO_TEXT);
302 FILE_GENERIC_NAME (&A68_JOB) = new_string (a68_basename (fn), NO_TEXT);
303 FILE_PATH (&A68_JOB) = new_string (a68_dirname (fn), NO_TEXT);
304 for (int l = 0; l < EXTENSIONS && cont; l++) {
305 if (strip_extension (extensions[l])) {
306 cont = A68_FALSE;
307 }
308 }
309 }
310 a68_free (fn);
311 }
312 }
313
314 //! @brief Remove a regular file.
315
316 void a68_rm (char *fn)
317 {
318 struct stat path_stat;
319 if (stat (fn, &path_stat) == 0) {
320 if (S_ISREG (path_stat.st_mode)) {
321 ABEND (remove (fn) != 0, ERROR_ACTION, FILE_OBJECT_NAME (&A68_JOB));
322 }
323 }
324 }
325
326 //! @brief Drives compilation and interpretation.
327
328 void compiler_interpreter (void)
329 {
330 BOOL_T emitted = A68_FALSE;
331 TREE_LISTING_SAFE (&A68_JOB) = A68_FALSE;
332 CROSS_REFERENCE_SAFE (&A68_JOB) = A68_FALSE;
333 A68 (in_execution) = A68_FALSE;
334 A68 (new_nodes) = 0;
335 A68 (new_modes) = 0;
336 A68 (new_postulates) = 0;
337 A68 (new_node_infos) = 0;
338 A68 (new_genie_infos) = 0;
339 A68 (symbol_table_count) = 0;
340 A68 (mode_count) = 0;
341 A68 (node_register) = NO_VAR;
342 init_postulates ();
343 A68 (do_confirm_exit) = A68_TRUE;
344 A68 (f_entry) = NO_NODE;
345 A68 (global_level) = 0;
346 A68 (max_lex_lvl) = 0;
347 A68_PARSER (stop_scanner) = A68_FALSE;
348 A68_PARSER (read_error) = A68_FALSE;
349 A68_PARSER (no_preprocessing) = A68_FALSE;
350 A68_PARSER (reductions) = 0;
351 A68_PARSER (tag_number) = 0;
352 A68 (curses_mode) = A68_FALSE;
353 A68 (top_soid_list) = NO_SOID;
354 A68 (max_simplout_size) = 0;
355 A68_MON (in_monitor) = A68_FALSE;
356 A68_MP (mp_ln_scale_size) = -1;
357 A68_MP (mp_ln_10_size) = -1;
358 A68_MP (mp_gamma_size) = -1;
359 A68_MP (mp_one_size) = -1;
360 A68_MP (mp_pi_size) = -1;
361 // File set-up.
362 SCAN_ERROR (FILE_INITIAL_NAME (&A68_JOB) == NO_TEXT, NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE);
363 FILE_BINARY_OPENED (&A68_JOB) = A68_FALSE;
364 FILE_BINARY_WRITEMOOD (&A68_JOB) = A68_TRUE;
365 FILE_PLUGIN_OPENED (&A68_JOB) = A68_FALSE;
366 FILE_PLUGIN_WRITEMOOD (&A68_JOB) = A68_TRUE;
367 FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE;
368 FILE_LISTING_WRITEMOOD (&A68_JOB) = A68_TRUE;
369 FILE_OBJECT_OPENED (&A68_JOB) = A68_FALSE;
370 FILE_OBJECT_WRITEMOOD (&A68_JOB) = A68_TRUE;
371 FILE_PRETTY_OPENED (&A68_JOB) = A68_FALSE;
372 FILE_SCRIPT_OPENED (&A68_JOB) = A68_FALSE;
373 FILE_SCRIPT_WRITEMOOD (&A68_JOB) = A68_FALSE;
374 FILE_SOURCE_OPENED (&A68_JOB) = A68_FALSE;
375 FILE_SOURCE_WRITEMOOD (&A68_JOB) = A68_FALSE;
376 FILE_DIAGS_OPENED (&A68_JOB) = A68_FALSE;
377 FILE_DIAGS_WRITEMOOD (&A68_JOB) = A68_TRUE;
378 // Open the source file.
379 // Open it for binary reading for systems that require so (Win32).
380 // Accept various silent extensions.
381 errno = 0;
382 FILE_SOURCE_NAME (&A68_JOB) = NO_TEXT;
383 FILE_GENERIC_NAME (&A68_JOB) = NO_TEXT;
384 open_with_extensions ();
385 if (FILE_SOURCE_NAME (&A68_JOB) == NO_TEXT) {
386 errno = ENOENT;
387 SCAN_ERROR (A68_TRUE, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
388 } else {
389 struct stat path_stat;
390 errno = 0;
391 SCAN_ERROR (stat (FILE_SOURCE_NAME (&A68_JOB), &path_stat) != 0, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
392 SCAN_ERROR (S_ISDIR (path_stat.st_mode), NO_LINE, NO_TEXT, ERROR_IS_DIRECTORY);
393 SCAN_ERROR (!S_ISREG (path_stat.st_mode), NO_LINE, NO_TEXT, ERROR_NO_REGULAR_FILE);
394 }
395 if (FILE_SOURCE_FD (&A68_JOB) == -1) {
396 scan_error (NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
397 }
398 ABEND (FILE_SOURCE_NAME (&A68_JOB) == NO_TEXT, ERROR_INTERNAL_CONSISTENCY, __func__);
399 ABEND (FILE_GENERIC_NAME (&A68_JOB) == NO_TEXT, ERROR_INTERNAL_CONSISTENCY, __func__);
400 // Object file.
401 int len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (OBJECT_EXTENSION);
402 FILE_OBJECT_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
403 a68_bufcpy (FILE_OBJECT_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
404 a68_bufcat (FILE_OBJECT_NAME (&A68_JOB), OBJECT_EXTENSION, len);
405 // Binary.
406 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (PLUGIN_EXTENSION);
407 FILE_BINARY_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
408 a68_bufcpy (FILE_BINARY_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
409 a68_bufcat (FILE_BINARY_NAME (&A68_JOB), BINARY_EXTENSION, len);
410 // Library file.
411 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (PLUGIN_EXTENSION);
412 FILE_PLUGIN_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
413 a68_bufcpy (FILE_PLUGIN_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
414 a68_bufcat (FILE_PLUGIN_NAME (&A68_JOB), PLUGIN_EXTENSION, len);
415 // Listing file.
416 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (LISTING_EXTENSION);
417 FILE_LISTING_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
418 a68_bufcpy (FILE_LISTING_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
419 a68_bufcat (FILE_LISTING_NAME (&A68_JOB), LISTING_EXTENSION, len);
420 // Pretty file.
421 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (PRETTY_EXTENSION);
422 FILE_PRETTY_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
423 a68_bufcpy (FILE_PRETTY_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
424 a68_bufcat (FILE_PRETTY_NAME (&A68_JOB), PRETTY_EXTENSION, len);
425 // Script file.
426 len = 1 + (int) strlen (FILE_GENERIC_NAME (&A68_JOB)) + (int) strlen (SCRIPT_EXTENSION);
427 FILE_SCRIPT_NAME (&A68_JOB) = (char *) get_heap_space ((size_t) len);
428 a68_bufcpy (FILE_SCRIPT_NAME (&A68_JOB), FILE_GENERIC_NAME (&A68_JOB), len);
429 a68_bufcat (FILE_SCRIPT_NAME (&A68_JOB), SCRIPT_EXTENSION, len);
430 // Parser.
431 a68_parser ();
432 if (TOP_NODE (&A68_JOB) == NO_NODE) {
433 errno = ECANCELED;
434 ABEND (A68_TRUE, ERROR_SOURCE_FILE_EMPTY, NO_TEXT);
435 }
436 // Portability checker.
437 if (ERROR_COUNT (&A68_JOB) == 0) {
438 announce_phase ("portability checker");
439 portcheck (TOP_NODE (&A68_JOB));
440 verbosity ();
441 }
442 // Finalise syntax tree.
443 if (ERROR_COUNT (&A68_JOB) == 0) {
444 int num = 0;
445 renumber_nodes (TOP_NODE (&A68_JOB), &num);
446 NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3;
447 reset_symbol_table_nest_count (TOP_NODE (&A68_JOB));
448 verbosity ();
449 }
450 if (A68_MP (varying_mp_digits) > width_to_mp_digits (MP_MAX_DECIMALS)) {
451 diagnostic (A68_WARNING, NO_NODE, WARNING_PRECISION, NO_LINE, 0, A68_MP (varying_mp_digits) * LOG_MP_RADIX);
452 }
453 // Plugin code generation and compilation.
454 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_OPT_LEVEL (&A68_JOB) > NO_OPTIMISE) {
455 announce_phase ("plugin-compiler");
456 plugin_driver_code ();
457 #if defined (BUILD_A68_COMPILER)
458 emitted = A68_TRUE;
459 if (ERROR_COUNT (&A68_JOB) == 0 && !OPTION_RUN_SCRIPT (&A68_JOB)) {
460 plugin_driver_compile ();
461 }
462 verbosity ();
463 #else
464 emitted = A68_FALSE;
465 diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, TOP_NODE (&A68_JOB), WARNING_OPTIMISATION);
466 #endif
467 }
468 // Indenter.
469 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_PRETTY (&A68_JOB)) {
470 announce_phase ("indenter");
471 indenter (&A68_JOB);
472 verbosity ();
473 }
474 // Interpreter initialisation.
475 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
476 if (OPTION_DEBUG (&A68_JOB)) {
477 state_license (A68_STDOUT);
478 }
479 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_COMPILE (&A68_JOB) == A68_FALSE &&
480 (OPTION_CHECK_ONLY (&A68_JOB) ? OPTION_RUN (&A68_JOB) : A68_TRUE)) {
481 announce_phase ("genie");
482 GetRNGstate ();
483 A68 (f_entry) = TOP_NODE (&A68_JOB);
484 A68 (close_tty_on_exit) = A68_FALSE;
485 #if defined (BUILD_A68_COMPILER)
486 plugin_driver_genie ();
487 #else
488 genie ((void *) NULL);
489 #endif
490 // Free heap allocated by genie.
491 genie_free (TOP_NODE (&A68_JOB));
492 // Store seed for rng.
493 announce_phase ("store rng state");
494 PutRNGstate ();
495 // Normal end of program.
496 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR);
497 if (OPTION_DEBUG (&A68_JOB) || OPTION_TRACE (&A68_JOB) || OPTION_CLOCK (&A68_JOB)) {
498 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "\nGenie finished in %.2f seconds\n", seconds () - A68 (cputime_0)) >= 0);
499 WRITE (A68_STDOUT, A68 (output_line));
500 }
501 verbosity ();
502 }
503 // Setting up listing file.
504 announce_phase ("write listing");
505 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)) {
506 FILE_LISTING_FD (&A68_JOB) = open (FILE_LISTING_NAME (&A68_JOB), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION);
507 ABEND (FILE_LISTING_FD (&A68_JOB) == -1, ERROR_ACTION, __func__);
508 FILE_LISTING_OPENED (&A68_JOB) = A68_TRUE;
509 } else {
510 FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE;
511 }
512 // Write listing.
513 if (FILE_LISTING_OPENED (&A68_JOB)) {
514 A68 (heap_is_fluid) = A68_TRUE;
515 write_listing_header ();
516 write_source_listing ();
517 write_tree_listing ();
518 if (ERROR_COUNT (&A68_JOB) == 0 && OPTION_OPT_LEVEL (&A68_JOB) > 0) {
519 write_object_listing ();
520 }
521 write_listing ();
522 ASSERT (close (FILE_LISTING_FD (&A68_JOB)) == 0);
523 FILE_LISTING_OPENED (&A68_JOB) = A68_FALSE;
524 verbosity ();
525 }
526 // Cleaning up the intermediate files.
527 #if defined (BUILD_A68_COMPILER)
528 announce_phase ("clean up intermediate files");
529 plugin_driver_clean (emitted);
530 #else
531 (void) emitted;
532 #endif
533 }
534
535 //! @brief Exit a68g in an orderly manner.
536
537 void a68_exit (int code)
538 {
539 announce_phase ("exit");
540 #if defined (HAVE_GNU_MPFR)
541 mpfr_free_cache ();
542 #endif
543 // Close unclosed files, remove temp files.
544 free_file_entries ();
545 // Close the terminal.
546 if (A68 (close_tty_on_exit) || OPTION_REGRESSION_TEST (&A68_JOB)) {
547 io_close_tty_line ();
548 } else if (OPTION_VERBOSE (&A68_JOB)) {
549 io_close_tty_line ();
550 }
551 #if defined (HAVE_CURSES)
552 // "curses" might still be open if it was not closed from A68, or the program
553 // was interrupted, or a runtime error occured. That wreaks havoc on your
554 // terminal.
555 genie_curses_end (NO_NODE);
556 #endif
557 // Clean up stale things.
558 free_syntax_tree (TOP_NODE (&A68_JOB));
559 free_option_list (OPTION_LIST (&A68_JOB));
560 a68_free (A68 (node_register));
561 a68_free (A68 (options));
562 discard_heap ();
563 a68_free (FILE_PATH (&A68_JOB));
564 a68_free (FILE_INITIAL_NAME (&A68_JOB));
565 a68_free (FILE_GENERIC_NAME (&A68_JOB));
566 a68_free (FILE_SOURCE_NAME (&A68_JOB));
567 a68_free (FILE_LISTING_NAME (&A68_JOB));
568 a68_free (FILE_OBJECT_NAME (&A68_JOB));
569 a68_free (FILE_PLUGIN_NAME (&A68_JOB));
570 a68_free (FILE_BINARY_NAME (&A68_JOB));
571 a68_free (FILE_PRETTY_NAME (&A68_JOB));
572 a68_free (FILE_SCRIPT_NAME (&A68_JOB));
573 a68_free (FILE_DIAGS_NAME (&A68_JOB));
574 a68_free (A68_MP (mp_one));
575 a68_free (A68_MP (mp_pi));
576 a68_free (A68_MP (mp_half_pi));
577 a68_free (A68_MP (mp_two_pi));
578 a68_free (A68_MP (mp_sqrt_two_pi));
579 a68_free (A68_MP (mp_sqrt_pi));
580 a68_free (A68_MP (mp_ln_pi));
581 a68_free (A68_MP (mp_180_over_pi));
582 a68_free (A68_MP (mp_pi_over_180));
583 exit (code);
584 }
585
586 //! @brief Main entry point.
587
588 int main (int argc, char *argv[])
589 {
590 BYTE_T stack_offset; // Leave this here!
591 A68 (argc) = argc;
592 A68 (argv) = argv;
593 A68 (close_tty_on_exit) = A68_TRUE;
594 FILE_DIAGS_FD (&A68_JOB) = -1;
595 // Get command name and discard path.
596 a68_bufcpy (A68 (a68_cmd_name), argv[0], BUFFER_SIZE);
597 for (int k = (int) strlen (A68 (a68_cmd_name)) - 1; k >= 0; k--) {
598 #if defined (BUILD_WIN32)
599 char delim = '\\';
600 #else
601 char delim = '/';
602 #endif
603 if (A68 (a68_cmd_name)[k] == delim) {
604 MOVE (&A68 (a68_cmd_name)[0], &A68 (a68_cmd_name)[k + 1], (int) strlen (A68 (a68_cmd_name)) - k + 1);
605 k = -1;
606 }
607 }
608 // Try to read maximum line width on the terminal,
609 // used to pretty print diagnostics to same.
610 a68_getty (&A68 (term_heigth), &A68 (term_width));
611 // Determine clock resolution.
612 {
613 clock_t t0 = clock (), t1;
614 do {
615 t1 = clock ();
616 } while (t1 == t0);
617 A68 (clock_res) = (t1 - t0) / (clock_t) CLOCKS_PER_SEC;
618 }
619 // Set the main thread id.
620 #if defined (BUILD_PARALLEL_CLAUSE)
621 A68_PAR (main_thread_id) = pthread_self ();
622 #endif
623 A68 (heap_is_fluid) = A68_TRUE;
624 A68 (system_stack_offset) = &stack_offset;
625 init_file_entries ();
626 if (!setjmp (RENDEZ_VOUS (&A68_JOB))) {
627 init_tty ();
628 // Initialise option handling.
629 init_options ();
630 SOURCE_SCAN (&A68_JOB) = 1;
631 default_options (&A68_JOB);
632 default_mem_sizes (1);
633 // Initialise core.
634 A68_STACK = NO_BYTE;
635 A68_HEAP = NO_BYTE;
636 A68_HANDLES = NO_BYTE;
637 get_stack_size ();
638 // Well, let's start.
639 TOP_REFINEMENT (&A68_JOB) = NO_REFINEMENT;
640 FILE_INITIAL_NAME (&A68_JOB) = NO_TEXT;
641 FILE_GENERIC_NAME (&A68_JOB) = NO_TEXT;
642 FILE_SOURCE_NAME (&A68_JOB) = NO_TEXT;
643 FILE_LISTING_NAME (&A68_JOB) = NO_TEXT;
644 FILE_OBJECT_NAME (&A68_JOB) = NO_TEXT;
645 FILE_PLUGIN_NAME (&A68_JOB) = NO_TEXT;
646 FILE_BINARY_NAME (&A68_JOB) = NO_TEXT;
647 FILE_PRETTY_NAME (&A68_JOB) = NO_TEXT;
648 FILE_SCRIPT_NAME (&A68_JOB) = NO_TEXT;
649 FILE_DIAGS_NAME (&A68_JOB) = NO_TEXT;
650 // Options are processed here.
651 read_rc_options ();
652 read_env_options ();
653 // Posix copies arguments from the command line.
654 if (argc <= 1) {
655 online_help (A68_STDOUT);
656 a68_exit (EXIT_FAILURE);
657 }
658 for (int k = 1; k < argc; k++) {
659 add_option_list (&(OPTION_LIST (&A68_JOB)), argv[k], NO_LINE);
660 }
661 if (!set_options (OPTION_LIST (&A68_JOB), A68_TRUE)) {
662 a68_exit (EXIT_FAILURE);
663 }
664 // State license.
665 if (OPTION_LICENSE (&A68_JOB)) {
666 state_license (A68_STDOUT);
667 }
668 // State version.
669 if (OPTION_VERSION (&A68_JOB)) {
670 state_version (A68_STDOUT);
671 }
672 // Start the UI.
673 init_before_tokeniser ();
674 // Running a script.
675 #if defined (BUILD_A68_COMPILER)
676 if (OPTION_RUN_SCRIPT (&A68_JOB)) {
677 load_script ();
678 }
679 #endif
680 // We translate the program.
681 if (FILE_INITIAL_NAME (&A68_JOB) == NO_TEXT || strlen (FILE_INITIAL_NAME (&A68_JOB)) == 0) {
682 SCAN_ERROR (!(OPTION_LICENSE (&A68_JOB) || OPTION_VERSION (&A68_JOB)), NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE);
683 } else {
684 compiler_interpreter ();
685 }
686 a68_exit (ERROR_COUNT (&A68_JOB) == 0 ? EXIT_SUCCESS : EXIT_FAILURE);
687 return EXIT_SUCCESS;
688 } else {
689 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
690 a68_exit (EXIT_FAILURE);
691 return EXIT_FAILURE;
692 }
693 }
