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-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  //! 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 13
  95  static char *extensions[EXTENSIONS] = {
  96    NO_TEXT,
  97    ".a68", ".A68",
  98    ".a68g", ".A68G",
  99    ".alg", ".ALG",
 100    ".algol", ".ALGOL",
 101    ".algol68", ".ALGOL68",
 102    ".algol68g", ".ALGOL68G"
 103  };
 104  
 105  void compiler_interpreter (void);
 106  
 107  //! @brief Verbose statistics, only useful when debugging a68g.
 108  
 109  void verbosity (void)
 110  {
 111  #if defined (A68G_DEBUG)
 112    ;
 113  #else
 114    ;
 115  #endif
 116  }
 117  
 118  //! @brief State license of running a68g image.
 119  
 120  void state_license (FILE_T f)
 121  {
 122  #define PR(s)\
 123    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "%s\n", (s)) >= 0);\
 124    WRITE (f, A68G (output_line));
 125    if (f == A68G_STDOUT) {
 126      io_close_tty_line ();
 127    }
 128    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Algol 68 Genie %s\n", PACKAGE_VERSION) >= 0);
 129    WRITE (f, A68G (output_line));
 130    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Copyright 2001-2025 %s.\n", PACKAGE_BUGREPORT) >= 0);
 131    WRITE (f, A68G (output_line));
 132    PR ("");
 133    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "This is free software covered by the GNU General Public License.\n") >= 0);
 134    WRITE (f, A68G (output_line));
 135    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "There is ABSOLUTELY NO WARRANTY for Algol 68 Genie;\n") >= 0);
 136    WRITE (f, A68G (output_line));
 137    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n") >= 0);
 138    WRITE (f, A68G (output_line));
 139    PR ("See the GNU General Public License for more details.");
 140    PR ("");
 141    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Please report bugs to %s.\n", PACKAGE_BUGREPORT) >= 0);
 142    WRITE (f, A68G (output_line));
 143  #undef PR
 144  }
 145  
 146  //! @brief State version of running a68g image.
 147  
 148  void state_version (FILE_T f)
 149  {
 150  #define PR(s)\
 151    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "%s\n", (s)) >= 0);\
 152    WRITE (f, A68G (output_line));
 153    if (f == A68G_STDOUT) {
 154      io_close_tty_line ();
 155    }
 156    state_license (f);
 157    PR ("");
 158  #if defined (BUILD_WIN32)
 159    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "WIN32 executable\n") >= 0);
 160    WRITE (f, A68G (output_line));
 161    WRITELN (f, "");
 162  #endif
 163  #if (A68G_LEVEL >= 3)
 164    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With hardware support for long modes\n") >= 0);
 165    WRITE (f, A68G (output_line));
 166  #endif
 167  #if defined (BUILD_A68G_COMPILER)
 168    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With plugin-compilation support\n") >= 0);
 169    WRITE (f, A68G (output_line));
 170  #endif
 171  #if defined (BUILD_PARALLEL_CLAUSE)
 172    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With parallel-clause support\n") >= 0);
 173    WRITE (f, A68G (output_line));
 174  #endif
 175  #if defined (HAVE_POSTGRESQL)
 176    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With PostgreSQL support\n") >= 0);
 177    WRITE (f, A68G (output_line));
 178  #endif
 179  #if defined (HAVE_CURL)
 180    curl_version_info_data *data = curl_version_info(CURLVERSION_NOW);
 181    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With curl %s\n", data->version) >= 0);
 182    WRITE (f, A68G (output_line));
 183  #endif
 184  #if defined (HAVE_GNU_MPFR)
 185    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With GNU MP %s\n", gmp_version) >= 0);
 186    WRITE (f, A68G (output_line));
 187    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With GNU MPFR %s\n", mpfr_get_version ()) >= 0);
 188    WRITE (f, A68G (output_line));
 189  #endif
 190  #if defined (HAVE_MATHLIB)
 191    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With mathlib from R %s\n", R_VERSION_STRING) >= 0);
 192    WRITE (f, A68G (output_line));
 193  #endif
 194  #if defined (HAVE_GSL)
 195    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With GNU Scientific Library %s\n", GSL_VERSION) >= 0);
 196    WRITE (f, A68G (output_line));
 197  #endif
 198  #if defined (HAVE_GNU_PLOTUTILS)
 199    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With GNU plotutils %s\n", PL_LIBPLOT_VER_STRING) >= 0);
 200    WRITE (f, A68G (output_line));
 201  #endif
 202  #if defined (HAVE_CURSES)
 203    #if defined (NCURSES_VERSION)
 204      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With ncurses %s\n", NCURSES_VERSION) >= 0);
 205    #else
 206      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "With curses support\n") >= 0);
 207    #endif
 208    WRITE (f, A68G (output_line));
 209  #endif
 210  #if defined (_CS_GNU_LIBC_VERSION) && defined (BUILD_UNIX)
 211    if (confstr (_CS_GNU_LIBC_VERSION, A68G (input_line), BUFFER_SIZE) > (size_t) 0) {
 212      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "GNU libc version %s\n", A68G (input_line)) >= 0);
 213      WRITE (f, A68G (output_line));
 214    }
 215  #if (defined (BUILD_PARALLEL_CLAUSE) && defined (_CS_GNU_LIBPTHREAD_VERSION))
 216    if (confstr (_CS_GNU_LIBPTHREAD_VERSION, A68G (input_line), BUFFER_SIZE) > (size_t) 0) {
 217      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "GNU libpthread version %s\n", A68G (input_line)) >= 0);
 218      WRITE (f, A68G (output_line));
 219    }
 220  #endif
 221  #endif
 222  #define RSIZE(n) (unt) (sizeof (n) / sizeof (int))
 223  #if defined (BUILD_A68G_COMPILER) && defined (C_COMPILER)
 224    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Build level %d.%x%x%x%x %s %s\n", A68G_LEVEL, RSIZE (INT_T), RSIZE (REAL_T), RSIZE (MP_INT_T), RSIZE (MP_REAL_T), C_COMPILER, __DATE__) >= 0);
 225  #else
 226    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Build level %d.%x%x%x%x %s\n", A68G_LEVEL, RSIZE (INT_T), RSIZE (REAL_T), RSIZE (MP_INT_T), RSIZE (MP_REAL_T), __DATE__) >= 0);
 227  #endif
 228  #undef RSIZE
 229  WRITE (f, A68G (output_line));
 230  #undef PR
 231  }
 232  
 233  //! @brief Give brief help if someone types 'a68g --help'.
 234  
 235  void online_help (FILE_T f)
 236  {
 237    if (f == A68G_STDOUT) {
 238      io_close_tty_line ();
 239    }
 240    state_license (f);
 241    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Usage: %s [options | filename]", A68G (a68g_cmd_name)) >= 0);
 242    WRITELN (f, A68G (output_line));
 243    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "For help: %s --apropos [keyword]", A68G (a68g_cmd_name)) >= 0);
 244    WRITELN (f, A68G (output_line));
 245  }
 246  
 247  //! @brief Start book keeping for a phase.
 248  
 249  void announce_phase (char *t)
 250  {
 251    if (OPTION_VERBOSE (&A68G_JOB)) {
 252      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "%s: %s", A68G (a68g_cmd_name), t) >= 0);
 253      io_close_tty_line ();
 254      WRITE (A68G_STDOUT, A68G (output_line));
 255    }
 256  }
 257  
 258  //! @brief Test extension and strip.
 259  
 260  BOOL_T strip_extension (char *ext)
 261  {
 262    if (ext == NO_TEXT) {
 263      return A68G_FALSE;
 264    }
 265    size_t nlen = strlen (FILE_SOURCE_NAME (&A68G_JOB)), xlen = strlen (ext);
 266    if (nlen > xlen && strcmp (&(FILE_SOURCE_NAME (&A68G_JOB)[nlen - xlen]), ext) == 0) {
 267      char *fn = (char *) get_heap_space ((size_t) (nlen + 1));
 268      a68g_bufcpy (fn, FILE_SOURCE_NAME (&A68G_JOB), nlen);
 269      fn[nlen - xlen] = NULL_CHAR;
 270      a68g_free (FILE_GENERIC_NAME (&A68G_JOB));
 271      FILE_GENERIC_NAME (&A68G_JOB) = new_string (fn, NO_TEXT);
 272      a68g_free (fn);
 273      return A68G_TRUE;
 274    } else {
 275      return A68G_FALSE;
 276    }
 277  }
 278  
 279  //! @brief Try opening with an extension.
 280  
 281  void open_with_extensions (void)
 282  {
 283    FILE_SOURCE_FD (&A68G_JOB) = -1;
 284    for (int k = 0; k < EXTENSIONS && FILE_SOURCE_FD (&A68G_JOB) == -1; k++) {
 285      size_t len;
 286      char *fn = NULL;
 287      if (extensions[k] == NO_TEXT) {
 288        len = strlen (FILE_INITIAL_NAME (&A68G_JOB)) + 1;
 289        fn = (char *) get_heap_space (len);
 290        a68g_bufcpy (fn, FILE_INITIAL_NAME (&A68G_JOB), len);
 291      } else {
 292        len = strlen (FILE_INITIAL_NAME (&A68G_JOB)) + strlen (extensions[k]) + 1;
 293        fn = (char *) get_heap_space (len);
 294        a68g_bufcpy (fn, FILE_INITIAL_NAME (&A68G_JOB), len);
 295        a68g_bufcat (fn, extensions[k], len);
 296      }
 297      FILE_SOURCE_FD (&A68G_JOB) = open (fn, O_RDONLY | O_BINARY);
 298      if (FILE_SOURCE_FD (&A68G_JOB) != -1) {
 299        BOOL_T cont = A68G_TRUE;
 300        a68g_free (FILE_SOURCE_NAME (&A68G_JOB));
 301        a68g_free (FILE_GENERIC_NAME (&A68G_JOB));
 302        FILE_SOURCE_NAME (&A68G_JOB) = new_string (fn, NO_TEXT);
 303        FILE_GENERIC_NAME (&A68G_JOB) = new_string (a68g_basename (fn), NO_TEXT);
 304        FILE_PATH (&A68G_JOB) = new_string (a68g_dirname (fn), NO_TEXT);
 305        for (int l = 0; l < EXTENSIONS && cont; l++) {
 306          if (strip_extension (extensions[l])) {
 307            cont = A68G_FALSE;
 308          }
 309        }
 310      }
 311      a68g_free (fn);
 312    }
 313  }
 314  
 315  //! @brief Remove a regular file.
 316  
 317  void a68g_rm (char *fn)
 318  {
 319    struct stat path_stat;
 320    if (stat (fn, &path_stat) == 0) {
 321      if (S_ISREG (path_stat.st_mode)) {
 322        ABEND (remove (fn) != 0, ERROR_ACTION, FILE_OBJECT_NAME (&A68G_JOB));
 323      }
 324    }
 325  }
 326  
 327  //! @brief Drives compilation and interpretation.
 328  
 329  void compiler_interpreter (void)
 330  {
 331    BOOL_T emitted = A68G_FALSE;
 332    TREE_LISTING_SAFE (&A68G_JOB) = A68G_FALSE;
 333    CROSS_REFERENCE_SAFE (&A68G_JOB) = A68G_FALSE;
 334    A68G (in_execution) = A68G_FALSE;
 335    A68G (new_nodes) = 0;
 336    A68G (new_modes) = 0;
 337    A68G (new_postulates) = 0;
 338    A68G (new_node_infos) = 0;
 339    A68G (new_genie_infos) = 0;
 340    A68G (symbol_table_count) = 0;
 341    A68G (mode_count) = 0;
 342    A68G (node_register) = NO_REF;
 343    init_postulates ();
 344    A68G (do_confirm_exit) = A68G_TRUE;
 345    A68G (f_entry) = NO_NODE;
 346    A68G (global_level) = 0;
 347    A68G (max_lex_lvl) = 0;
 348    A68G_PARSER (stop_scanner) = A68G_FALSE;
 349    A68G_PARSER (read_error) = A68G_FALSE;
 350    A68G_PARSER (no_preprocessing) = A68G_FALSE;
 351    A68G_PARSER (reductions) = 0;
 352    A68G_PARSER (tag_number) = 0;
 353    A68G (curses_mode) = A68G_FALSE;
 354    A68G (top_soid_list) = NO_SOID;
 355    A68G (max_simplout_size) = 0;
 356    A68G_MON (in_monitor) = A68G_FALSE;
 357    A68G_MP (mp_ln_scale_size) = -1;
 358    A68G_MP (mp_ln_10_size) = -1;
 359    A68G_MP (mp_gamma_size) = -1;
 360    A68G_MP (mp_one_size) = -1;
 361    A68G_MP (mp_pi_size) = -1;
 362  // File set-up.
 363    SCAN_ERROR (FILE_INITIAL_NAME (&A68G_JOB) == NO_TEXT, NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE);
 364    FILE_BINARY_OPENED (&A68G_JOB) = A68G_FALSE;
 365    FILE_BINARY_WRITEMOOD (&A68G_JOB) = A68G_TRUE;
 366    FILE_PLUGIN_OPENED (&A68G_JOB) = A68G_FALSE;
 367    FILE_PLUGIN_WRITEMOOD (&A68G_JOB) = A68G_TRUE;
 368    FILE_LISTING_OPENED (&A68G_JOB) = A68G_FALSE;
 369    FILE_LISTING_WRITEMOOD (&A68G_JOB) = A68G_TRUE;
 370    FILE_OBJECT_OPENED (&A68G_JOB) = A68G_FALSE;
 371    FILE_OBJECT_WRITEMOOD (&A68G_JOB) = A68G_TRUE;
 372    FILE_PRETTY_OPENED (&A68G_JOB) = A68G_FALSE;
 373    FILE_SCRIPT_OPENED (&A68G_JOB) = A68G_FALSE;
 374    FILE_SCRIPT_WRITEMOOD (&A68G_JOB) = A68G_FALSE;
 375    FILE_SOURCE_OPENED (&A68G_JOB) = A68G_FALSE;
 376    FILE_SOURCE_WRITEMOOD (&A68G_JOB) = A68G_FALSE;
 377    FILE_DIAGS_OPENED (&A68G_JOB) = A68G_FALSE;
 378    FILE_DIAGS_WRITEMOOD (&A68G_JOB) = A68G_TRUE;
 379  // Open the source file. 
 380  // Open it for binary reading for systems that require so (Win32).
 381  // Accept various silent extensions.
 382    errno = 0;
 383    FILE_SOURCE_NAME (&A68G_JOB) = NO_TEXT;
 384    FILE_GENERIC_NAME (&A68G_JOB) = NO_TEXT;
 385    open_with_extensions ();
 386    if (FILE_SOURCE_NAME (&A68G_JOB) == NO_TEXT) {
 387      errno = ENOENT;
 388      SCAN_ERROR (A68G_TRUE, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
 389    } else {
 390      struct stat path_stat;
 391      errno = 0;
 392      SCAN_ERROR (stat (FILE_SOURCE_NAME (&A68G_JOB), &path_stat) != 0, NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
 393      SCAN_ERROR (S_ISDIR (path_stat.st_mode), NO_LINE, NO_TEXT, ERROR_IS_DIRECTORY);
 394      SCAN_ERROR (!S_ISREG (path_stat.st_mode), NO_LINE, NO_TEXT, ERROR_NO_REGULAR_FILE);
 395    }
 396    if (FILE_SOURCE_FD (&A68G_JOB) == -1) {
 397      scan_error (NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN);
 398    }
 399    ABEND (FILE_SOURCE_NAME (&A68G_JOB) == NO_TEXT, ERROR_INTERNAL_CONSISTENCY, __func__);
 400    ABEND (FILE_GENERIC_NAME (&A68G_JOB) == NO_TEXT, ERROR_INTERNAL_CONSISTENCY, __func__);
 401  // Object file.
 402    size_t len = 1 + strlen (FILE_GENERIC_NAME (&A68G_JOB)) + strlen (OBJECT_EXTENSION);
 403    FILE_OBJECT_NAME (&A68G_JOB) = (char *) get_heap_space (len);
 404    a68g_bufcpy (FILE_OBJECT_NAME (&A68G_JOB), FILE_GENERIC_NAME (&A68G_JOB), len);
 405    a68g_bufcat (FILE_OBJECT_NAME (&A68G_JOB), OBJECT_EXTENSION, len);
 406  // Binary.
 407    len = 1 + strlen (FILE_GENERIC_NAME (&A68G_JOB)) + strlen (PLUGIN_EXTENSION);
 408    FILE_BINARY_NAME (&A68G_JOB) = (char *) get_heap_space (len);
 409    a68g_bufcpy (FILE_BINARY_NAME (&A68G_JOB), FILE_GENERIC_NAME (&A68G_JOB), len);
 410    a68g_bufcat (FILE_BINARY_NAME (&A68G_JOB), BINARY_EXTENSION, len);
 411  // Library file.
 412    len = 1 + strlen (FILE_GENERIC_NAME (&A68G_JOB)) + strlen (PLUGIN_EXTENSION);
 413    FILE_PLUGIN_NAME (&A68G_JOB) = (char *) get_heap_space (len);
 414    a68g_bufcpy (FILE_PLUGIN_NAME (&A68G_JOB), FILE_GENERIC_NAME (&A68G_JOB), len);
 415    a68g_bufcat (FILE_PLUGIN_NAME (&A68G_JOB), PLUGIN_EXTENSION, len);
 416  // Listing file.
 417    len = 1 + strlen (FILE_GENERIC_NAME (&A68G_JOB)) + strlen (LISTING_EXTENSION);
 418    FILE_LISTING_NAME (&A68G_JOB) = (char *) get_heap_space (len);
 419    a68g_bufcpy (FILE_LISTING_NAME (&A68G_JOB), FILE_GENERIC_NAME (&A68G_JOB), len);
 420    a68g_bufcat (FILE_LISTING_NAME (&A68G_JOB), LISTING_EXTENSION, len);
 421  // Pretty file.
 422    len = 1 + strlen (FILE_GENERIC_NAME (&A68G_JOB)) + strlen (PRETTY_EXTENSION);
 423    FILE_PRETTY_NAME (&A68G_JOB) = (char *) get_heap_space (len);
 424    a68g_bufcpy (FILE_PRETTY_NAME (&A68G_JOB), FILE_GENERIC_NAME (&A68G_JOB), len);
 425    a68g_bufcat (FILE_PRETTY_NAME (&A68G_JOB), PRETTY_EXTENSION, len);
 426  // Script file.
 427    len = 1 + strlen (FILE_GENERIC_NAME (&A68G_JOB)) + strlen (SCRIPT_EXTENSION);
 428    FILE_SCRIPT_NAME (&A68G_JOB) = (char *) get_heap_space (len);
 429    a68g_bufcpy (FILE_SCRIPT_NAME (&A68G_JOB), FILE_GENERIC_NAME (&A68G_JOB), len);
 430    a68g_bufcat (FILE_SCRIPT_NAME (&A68G_JOB), SCRIPT_EXTENSION, len);
 431  // Parser.
 432    a68g_parser ();
 433    if (TOP_NODE (&A68G_JOB) == NO_NODE) {
 434      errno = ECANCELED;
 435      ABEND (A68G_TRUE, ERROR_SOURCE_FILE_EMPTY, NO_TEXT);
 436    }
 437  // Portability checker.
 438    if (ERROR_COUNT (&A68G_JOB) == 0) {
 439      announce_phase ("portability checker");
 440      portcheck (TOP_NODE (&A68G_JOB));
 441      verbosity ();
 442    }
 443  // Finalise syntax tree.
 444    if (ERROR_COUNT (&A68G_JOB) == 0) {
 445      int num = 0;
 446      renumber_nodes (TOP_NODE (&A68G_JOB), &num);
 447      NEST (TABLE (TOP_NODE (&A68G_JOB))) = A68G (symbol_table_count) = 3;
 448      reset_symbol_table_nest_count (TOP_NODE (&A68G_JOB));
 449      verbosity ();
 450    }
 451    if (A68G_MP (varying_mp_digits) > width_to_mp_digits (MP_MAX_DECIMALS)) {
 452      diagnostic (A68G_WARNING, NO_NODE, WARNING_PRECISION, NO_LINE, 0, A68G_MP (varying_mp_digits) * LOG_MP_RADIX);
 453    }
 454  // Plugin code generation and compilation.
 455    if (ERROR_COUNT (&A68G_JOB) == 0 && OPTION_OPT_LEVEL (&A68G_JOB) > NO_OPTIMISE) {
 456      announce_phase ("plugin-compiler");
 457      plugin_driver_code ();
 458  #if defined (BUILD_A68G_COMPILER)
 459      emitted = A68G_TRUE;
 460      if (ERROR_COUNT (&A68G_JOB) == 0 && !OPTION_RUN_SCRIPT (&A68G_JOB)) {
 461        plugin_driver_compile ();
 462      }
 463      verbosity ();
 464  #else
 465      emitted = A68G_FALSE;
 466      diagnostic (A68G_WARNING, TOP_NODE (&A68G_JOB), WARNING_OPTIMISATION);
 467  #endif
 468    }
 469  // Indenter.
 470    if (ERROR_COUNT (&A68G_JOB) == 0 && OPTION_PRETTY (&A68G_JOB)) {
 471      announce_phase ("indenter");
 472      indenter (&A68G_JOB);
 473      verbosity ();
 474    }
 475  // Interpreter initialisation.
 476    diagnostics_to_terminal (TOP_LINE (&A68G_JOB), A68G_ALL_DIAGNOSTICS);
 477    if (OPTION_DEBUG (&A68G_JOB)) {
 478      state_license (A68G_STDOUT);
 479    }
 480    if (ERROR_COUNT (&A68G_JOB) == 0 && OPTION_COMPILE (&A68G_JOB) == A68G_FALSE && 
 481       (OPTION_CHECK_ONLY (&A68G_JOB) ? OPTION_RUN (&A68G_JOB) : A68G_TRUE)) {
 482      announce_phase ("genie");
 483      GetRNGstate ();
 484      A68G (f_entry) = TOP_NODE (&A68G_JOB);
 485      A68G (close_tty_on_exit) = A68G_FALSE;
 486  #if defined (BUILD_A68G_COMPILER)
 487      plugin_driver_genie ();
 488  #else
 489      genie ((void *) NULL);
 490  #endif
 491  // Free heap allocated by genie.
 492      if (A68G_GC (total) > 10 * MEGABYTE) {
 493        ASSERT (a68g_bufprt (A68G (edit_line), SNPRINTF_SIZE, 
 494          "sweeps=" A68G_LU ", refused=" A68G_LU ", freed=" A68G_LU "MB",  
 495          A68G_GC (sweeps), A68G_GC (refused), A68G_GC (total) / MEGABYTE)
 496        );
 497      } else if (A68G_GC (total) > 10 * KILOBYTE) {
 498        ASSERT (a68g_bufprt (A68G (edit_line), SNPRINTF_SIZE, 
 499          "sweeps=" A68G_LU ", refused=" A68G_LU ", freed=" A68G_LU "kB",  
 500          A68G_GC (sweeps), A68G_GC (refused), A68G_GC (total) / KILOBYTE)
 501        );
 502      } else {
 503        ASSERT (a68g_bufprt (A68G (edit_line), SNPRINTF_SIZE, 
 504          "sweeps=" A68G_LU ", refused=" A68G_LU ", freed=" A68G_LU,  
 505          A68G_GC (sweeps), A68G_GC (refused), A68G_GC (total))
 506        );
 507      }
 508      announce_phase (A68G (edit_line));
 509      genie_free (TOP_NODE (&A68G_JOB));
 510  // Store seed for rng.
 511      announce_phase ("store rng state");
 512      PutRNGstate ();
 513  // Normal end of program.
 514      diagnostics_to_terminal (TOP_LINE (&A68G_JOB), A68G_RUNTIME_ERROR);
 515      if (OPTION_DEBUG (&A68G_JOB) || OPTION_TRACE (&A68G_JOB) || OPTION_CLOCK (&A68G_JOB)) {
 516        ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "\nGenie finished in %.2f seconds\n", seconds () - A68G (cputime_0)) >= 0);
 517        WRITE (A68G_STDOUT, A68G (output_line));
 518      }
 519      verbosity ();
 520    }
 521  // Setting up listing file.
 522    announce_phase ("write listing");
 523    if (OPTION_MOID_LISTING (&A68G_JOB) || OPTION_TREE_LISTING (&A68G_JOB) || OPTION_SOURCE_LISTING (&A68G_JOB) || OPTION_OBJECT_LISTING (&A68G_JOB) || OPTION_STATISTICS_LISTING (&A68G_JOB)) {
 524      FILE_LISTING_FD (&A68G_JOB) = open (FILE_LISTING_NAME (&A68G_JOB), O_WRONLY | O_CREAT | O_TRUNC, A68G_PROTECTION);
 525      ABEND (FILE_LISTING_FD (&A68G_JOB) == -1, ERROR_ACTION, __func__);
 526      FILE_LISTING_OPENED (&A68G_JOB) = A68G_TRUE;
 527    } else {
 528      FILE_LISTING_OPENED (&A68G_JOB) = A68G_FALSE;
 529    }
 530  // Write listing.
 531    if (FILE_LISTING_OPENED (&A68G_JOB)) {
 532      A68G (heap_is_fluid) = A68G_TRUE;
 533      write_listing_header ();
 534      write_source_listing ();
 535      write_tree_listing ();
 536      if (ERROR_COUNT (&A68G_JOB) == 0 && OPTION_OPT_LEVEL (&A68G_JOB) > 0) {
 537        write_object_listing ();
 538      }
 539      write_listing ();
 540      ASSERT (close (FILE_LISTING_FD (&A68G_JOB)) == 0);
 541      FILE_LISTING_OPENED (&A68G_JOB) = A68G_FALSE;
 542      verbosity ();
 543    }
 544  // Cleaning up the intermediate files.
 545  #if defined (BUILD_A68G_COMPILER)
 546    announce_phase ("clean up intermediate files");
 547    plugin_driver_clean (emitted);
 548  #else
 549    (void) emitted;
 550  #endif
 551  }
 552  
 553  //! @brief Exit a68g in an orderly manner.
 554  
 555  void a68g_exit (int code)
 556  {
 557    announce_phase ("exit");
 558  #if defined (HAVE_GNU_MPFR)
 559    mpfr_free_cache ();
 560  #endif
 561  // Close unclosed files, remove temp files.
 562    free_file_entries ();
 563  // Close the terminal.
 564    if (A68G (close_tty_on_exit) || OPTION_REGRESSION_TEST (&A68G_JOB)) {
 565      io_close_tty_line ();
 566    } else if (OPTION_VERBOSE (&A68G_JOB)) {
 567      io_close_tty_line ();
 568    }
 569  #if defined (HAVE_CURSES)
 570  // "curses" might still be open if it was not closed from A68, or the program
 571  // was interrupted, or a runtime error occured. That wreaks havoc on your
 572  // terminal. 
 573    genie_curses_end (NO_NODE);
 574  #endif
 575  // Clean up stale things.
 576    free_syntax_tree (TOP_NODE (&A68G_JOB));
 577    free_option_list (OPTION_LIST (&A68G_JOB));
 578    a68g_free (A68G (node_register));
 579    a68g_free (A68G (options));
 580    discard_heap ();
 581    a68g_free (FILE_PATH (&A68G_JOB));
 582    a68g_free (FILE_INITIAL_NAME (&A68G_JOB));
 583    a68g_free (FILE_GENERIC_NAME (&A68G_JOB));
 584    a68g_free (FILE_SOURCE_NAME (&A68G_JOB));
 585    a68g_free (FILE_LISTING_NAME (&A68G_JOB));
 586    a68g_free (FILE_OBJECT_NAME (&A68G_JOB));
 587    a68g_free (FILE_PLUGIN_NAME (&A68G_JOB));
 588    a68g_free (FILE_BINARY_NAME (&A68G_JOB));
 589    a68g_free (FILE_PRETTY_NAME (&A68G_JOB));
 590    a68g_free (FILE_SCRIPT_NAME (&A68G_JOB));
 591    a68g_free (FILE_DIAGS_NAME (&A68G_JOB));
 592    a68g_free (A68G_MP (mp_one));
 593    a68g_free (A68G_MP (mp_pi));
 594    a68g_free (A68G_MP (mp_half_pi));
 595    a68g_free (A68G_MP (mp_two_pi));
 596    a68g_free (A68G_MP (mp_sqrt_two_pi));
 597    a68g_free (A68G_MP (mp_sqrt_pi));
 598    a68g_free (A68G_MP (mp_ln_pi));
 599    a68g_free (A68G_MP (mp_180_over_pi));
 600    a68g_free (A68G_MP (mp_pi_over_180));
 601    exit (code);
 602  }
 603  
 604  //! @brief Main entry point.
 605  
 606  int main (int argc, char *argv[])
 607  {
 608    BYTE_T stack_offset;          // Leave this here!
 609    A68G (argc) = argc;
 610    A68G (argv) = argv;
 611    A68G (close_tty_on_exit) = A68G_TRUE;
 612    FILE_DIAGS_FD (&A68G_JOB) = -1;
 613  // Get command name and discard path.
 614    a68g_bufcpy (A68G (a68g_cmd_name), argv[0], BUFFER_SIZE);
 615    for (int k = strlen (A68G (a68g_cmd_name)) - 1; k >= 0; k--) {
 616  #if defined (BUILD_WIN32)
 617      char delim = '\\';
 618  #else
 619      char delim = '/';
 620  #endif
 621      if (A68G (a68g_cmd_name)[k] == delim) {
 622        MOVE (&A68G (a68g_cmd_name)[0], &A68G (a68g_cmd_name)[k + 1], strlen (A68G (a68g_cmd_name)) - k + 1);
 623        k = -1;
 624      }
 625    }
 626  // Try to read maximum line width on the terminal,
 627  // used to pretty print diagnostics to same.
 628    a68g_getty (&A68G (term_heigth), &A68G (term_width));
 629  // Determine clock resolution.
 630    {
 631      clock_t t0 = clock (), t1;
 632      do {
 633        t1 = clock ();
 634      } while (t1 == t0);
 635      A68G (clock_res) = (t1 - t0) / (clock_t) CLOCKS_PER_SEC;
 636    }
 637  // Set the main thread id.
 638  #if defined (BUILD_PARALLEL_CLAUSE)
 639    A68G_PAR (main_thread_id) = pthread_self ();
 640  #endif
 641    A68G (heap_is_fluid) = A68G_TRUE;
 642    A68G (system_stack_offset) = &stack_offset;
 643    init_file_entries ();
 644    if (!setjmp (RENDEZ_VOUS (&A68G_JOB))) {
 645      init_tty ();
 646  // Initialise option handling.
 647      init_options ();
 648      SOURCE_SCAN (&A68G_JOB) = 1;
 649      default_options (&A68G_JOB);
 650      default_mem_sizes (1);
 651  // Initialise core.
 652      A68G_STACK = NO_BYTE;
 653      A68G_HEAP = NO_BYTE;
 654      A68G_HANDLES = NO_BYTE;
 655      get_stack_size ();
 656  // Well, let's start.
 657      TOP_REFINEMENT (&A68G_JOB) = NO_REFINEMENT;
 658      FILE_INITIAL_NAME (&A68G_JOB) = NO_TEXT;
 659      FILE_GENERIC_NAME (&A68G_JOB) = NO_TEXT;
 660      FILE_SOURCE_NAME (&A68G_JOB) = NO_TEXT;
 661      FILE_LISTING_NAME (&A68G_JOB) = NO_TEXT;
 662      FILE_OBJECT_NAME (&A68G_JOB) = NO_TEXT;
 663      FILE_PLUGIN_NAME (&A68G_JOB) = NO_TEXT;
 664      FILE_BINARY_NAME (&A68G_JOB) = NO_TEXT;
 665      FILE_PRETTY_NAME (&A68G_JOB) = NO_TEXT;
 666      FILE_SCRIPT_NAME (&A68G_JOB) = NO_TEXT;
 667      FILE_DIAGS_NAME (&A68G_JOB) = NO_TEXT;
 668  // Options are processed here.
 669      read_rc_options ();
 670      read_env_options ();
 671  // Posix copies arguments from the command line.
 672      if (argc <= 1) {
 673        online_help (A68G_STDOUT);
 674        a68g_exit (EXIT_FAILURE);
 675      }
 676      for (int k = 1; k < argc; k++) {
 677        add_option_list (&(OPTION_LIST (&A68G_JOB)), argv[k], NO_LINE);
 678      }
 679      if (!set_options (OPTION_LIST (&A68G_JOB), A68G_TRUE)) {
 680        a68g_exit (EXIT_FAILURE);
 681      }
 682  // State license.
 683      if (OPTION_LICENSE (&A68G_JOB)) {
 684        state_license (A68G_STDOUT);
 685      }
 686  // State version.
 687      if (OPTION_VERSION (&A68G_JOB)) {
 688        state_version (A68G_STDOUT);
 689      }
 690  // Start the UI.
 691      init_before_tokeniser ();
 692  // Running a script.
 693  #if defined (BUILD_A68G_COMPILER)
 694      if (OPTION_RUN_SCRIPT (&A68G_JOB)) {
 695        load_script ();
 696      }
 697  #endif
 698  // We translate the program.
 699      if (FILE_INITIAL_NAME (&A68G_JOB) == NO_TEXT || strlen (FILE_INITIAL_NAME (&A68G_JOB)) == 0) {
 700        SCAN_ERROR (!(OPTION_LICENSE (&A68G_JOB) || OPTION_VERSION (&A68G_JOB)), NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE);
 701      } else {
 702        compiler_interpreter ();
 703      }
 704      a68g_exit (ERROR_COUNT (&A68G_JOB) == 0 ? EXIT_SUCCESS : EXIT_FAILURE);
 705      return EXIT_SUCCESS;
 706    } else {
 707      diagnostics_to_terminal (TOP_LINE (&A68G_JOB), A68G_ALL_DIAGNOSTICS);
 708      a68g_exit (EXIT_FAILURE);
 709      return EXIT_FAILURE;
 710    }
 711  }
     


© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)