plugin.c

     
   1  //! @file plugin.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  //! Plugin compiler driver.
  25  
  26  // The plugin compiler generates optimised C routines for many units in an Algol 68 source
  27  // program. A68G 1.x contained some general optimised routines. These are
  28  // decommissioned in A68G 2.x that dynamically generates routines depending
  29  // on the source code. The generated routines are compiled on the fly into a 
  30  // dynamic library that is linked by the running interpreter, like a plugin.
  31  
  32  // To invoke this code generator specify option --optimise.
  33  // Currently the optimiser only considers units that operate on basic modes that are
  34  // contained in a single C struct, for instance primitive modes
  35  // 
  36  //   INT, REAL, BOOL, CHAR and BITS
  37  // 
  38  // and simple structures of these basic modes, such as
  39  // 
  40  //   COMPLEX
  41  // 
  42  // and also (single) references, rows and procedures
  43  // 
  44  //   REF MODE, [] MODE, PROC PARAMSETY MODE
  45  // 
  46  // The code generator employs a few simple optimisations like constant folding
  47  // and common subexpression elimination when DEREFERENCING or SLICING is
  48  // performed; for instance
  49  // 
  50  //   x[i + 1] := x[i + 1] + 1
  51  // 
  52  // translates into
  53  // 
  54  //   tmp = x[i + 1]; tmp := tmp + 1
  55  // 
  56  // We don't do stuff that is easily recognised by a back end compiler,
  57  // for instance symbolic simplification.
  58  
  59  #include "a68g.h"
  60  #include "a68g-prelude.h"
  61  #include "a68g-genie.h"
  62  #include "a68g-listing.h"
  63  #include "a68g-mp.h"
  64  #include "a68g-optimiser.h"
  65  #include "a68g-plugin.h"
  66  #include "a68g-parser.h"
  67  #include "a68g-transput.h"
  68  
  69  //! @brief Compiler optimisation option string
  70  
  71  char *optimisation_option (void)
  72  {
  73    switch (OPTION_OPT_LEVEL (&A68_JOB)) {
  74    case OPTIMISE_0:{
  75        return "-Og";
  76      }
  77    case OPTIMISE_1:{
  78        return "-O1";
  79      }
  80    case OPTIMISE_2:{
  81        return "-O2";
  82      }
  83    case OPTIMISE_3:{
  84        return "-O3";
  85      }
  86    case OPTIMISE_FAST:{
  87        return "-Ofast";
  88      }
  89    default:{
  90        return "-Og";
  91      }
  92    }
  93  }
  94  
  95  
  96  //! @brief Compiler driver.
  97  
  98  void compiler (FILE_T out)
  99  {
 100    ADDR_T pop_temp_heap_pointer = A68 (temp_heap_pointer);
 101    if (OPTION_OPT_LEVEL (&A68_JOB) == NO_OPTIMISE) {
 102      return;
 103    }
 104    A68_OPT (indentation) = 0;
 105    A68_OPT (code_errors) = 0;
 106    A68_OPT (procedures) = 0;
 107    A68_OPT (cse_pointer) = 0;
 108    A68_OPT (unic_pointer) = 0;
 109    A68_OPT (root_idf) = NO_DEC;
 110    A68 (global_level) = INT_MAX;
 111    A68_GLOBALS = 0;
 112    get_global_level (SUB (TOP_NODE (&A68_JOB)));
 113    A68 (max_lex_lvl) = 0;
 114    genie_preprocess (TOP_NODE (&A68_JOB), &A68 (max_lex_lvl), NULL);
 115    get_global_level (TOP_NODE (&A68_JOB));
 116    A68_SP = A68 (stack_start);
 117    A68 (expr_stack_limit) = A68 (stack_end) - A68 (storage_overhead);
 118    if (OPTION_COMPILE_CHECK (&A68_JOB)) {
 119      monadics = monadics_check;
 120      dyadics = dyadics_check;
 121      functions = functions_check;
 122    } else {
 123      monadics = monadics_nocheck;
 124      dyadics = dyadics_nocheck;
 125      functions = functions_nocheck;
 126    }
 127    if (OPTION_OPT_LEVEL (&A68_JOB) == OPTIMISE_0) {
 128  // Allow basic optimisation only.
 129      A68_OPT (OPTION_CODE_LEVEL) = 1;
 130      write_prelude (out);
 131      gen_basics (TOP_NODE (&A68_JOB), out);
 132    } else {
 133  // Allow all optimisations.
 134      A68_OPT (OPTION_CODE_LEVEL) = 9;
 135      write_prelude (out);
 136      gen_units (TOP_NODE (&A68_JOB), out);
 137    }
 138    ABEND (A68_OPT (indentation) != 0, ERROR_INTERNAL_CONSISTENCY, __func__);
 139  // At the end we discard temporary declarations.
 140    A68 (temp_heap_pointer) = pop_temp_heap_pointer;
 141    if (OPTION_VERBOSE (&A68_JOB)) {
 142      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: A68_OPT (procedures)=%d unique-names=%d", A68 (a68_cmd_name), A68_OPT (procedures), A68_OPT (unic_pointer)) >= 0);
 143      io_close_tty_line ();
 144      WRITE (STDOUT_FILENO, A68 (output_line));
 145    }
 146  //
 147    int k;
 148    for (k = 0; k < A68_OPT (unic_pointer); k++) {
 149      a68_free (UNIC_NAME (k));
 150    }
 151  }
 152  
 153  // Pretty printing stuff.
 154  
 155  //! @brief Name formatting
 156  
 157  char *moid_with_name (char *pre, MOID_T * m, char *post)
 158  {
 159    static char buf[NAME_SIZE];
 160    char *mode = "MODE", *ref = NO_TEXT;
 161    if (m != NO_MOID && IS (m, REF_SYMBOL)) {
 162      ref = "REF";
 163      m = SUB (m);
 164    }
 165    if (m == M_INT) {
 166      mode = "INT";
 167    } else if (m == M_REAL) {
 168      mode = "REAL";
 169    } else if (m == M_BOOL) {
 170      mode = "BOOL";
 171    } else if (m == M_CHAR) {
 172      mode = "CHAR";
 173    } else if (m == M_BITS) {
 174      mode = "BITS";
 175    } else if (m == M_VOID) {
 176      mode = "VOID";
 177    }
 178    if (ref == NO_TEXT) {
 179      snprintf (buf, NAME_SIZE, "%s%s%s", pre, mode, post);
 180    } else {
 181      snprintf (buf, NAME_SIZE, "%sREF_%s%s", pre, mode, post);
 182    }
 183    return buf;
 184  }
 185  
 186  //! @brief Write indented text.
 187  
 188  void indent (FILE_T out, char *str)
 189  {
 190    int j = A68_OPT (indentation);
 191    if (out == 0) {
 192      return;
 193    }
 194    while (j-- > 0) {
 195      WRITE (out, "  ");
 196    }
 197    WRITE (out, str);
 198  }
 199  
 200  //! @brief Write unindented text.
 201  
 202  void undent (FILE_T out, char *str)
 203  {
 204    if (out == 0) {
 205      return;
 206    }
 207    WRITE (out, str);
 208  }
 209  
 210  //! @brief Write indent text.
 211  
 212  void indentf (FILE_T out, int ret)
 213  {
 214    if (out == 0) {
 215      return;
 216    }
 217    if (ret >= 0) {
 218      indent (out, A68 (edit_line));
 219    } else {
 220      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, error_specification ());
 221    }
 222  }
 223  
 224  //! @brief Write unindent text.
 225  
 226  void undentf (FILE_T out, int ret)
 227  {
 228    if (out == 0) {
 229      return;
 230    }
 231    if (ret >= 0) {
 232      WRITE (out, A68 (edit_line));
 233    } else {
 234      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, error_specification ());
 235    }
 236  }
 237  
 238  // Administration of C declarations .
 239  // Pretty printing of C declarations.
 240  
 241  //! @brief Add declaration to a tree.
 242  
 243  DEC_T *add_identifier (DEC_T ** p, int level, char *idf)
 244  {
 245    char *z = new_temp_string (idf);
 246    while (*p != NO_DEC) {
 247      int k = strcmp (z, TEXT (*p));
 248      if (k < 0) {
 249        p = &LESS (*p);
 250      } else if (k > 0) {
 251        p = &MORE (*p);
 252      } else {
 253        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, z);
 254        return *p;
 255      }
 256    }
 257    *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (DEC_T));
 258    TEXT (*p) = z;
 259    LEVEL (*p) = level;
 260    SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC;
 261    return *p;
 262  }
 263  
 264  //! @brief Add declaration to a tree.
 265  
 266  DEC_T *add_declaration (DEC_T ** p, char *mode, int level, char *idf)
 267  {
 268    char *z = new_temp_string (mode);
 269    while (*p != NO_DEC) {
 270      int k = strcmp (z, TEXT (*p));
 271      if (k < 0) {
 272        p = &LESS (*p);
 273      } else if (k > 0) {
 274        p = &MORE (*p);
 275      } else {
 276        (void) add_identifier (&SUB (*p), level, idf);
 277        return *p;
 278      }
 279    }
 280    *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (DEC_T));
 281    TEXT (*p) = z;
 282    LEVEL (*p) = -1;
 283    SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC;
 284    (void) add_identifier (&SUB (*p), level, idf);
 285    return *p;
 286  }
 287  
 288  //! @brief Print identifiers (following mode).
 289  
 290  void print_identifiers (FILE_T out, DEC_T * p)
 291  {
 292    if (p != NO_DEC) {
 293      print_identifiers (out, LESS (p));
 294      if (A68_OPT (put_idf_comma)) {
 295        WRITE (out, ", ");
 296      } else {
 297        A68_OPT (put_idf_comma) = A68_TRUE;
 298      }
 299      if (LEVEL (p) > 0) {
 300        int k = LEVEL (p);
 301        while (k--) {
 302          WRITE (out, "*");
 303        }
 304        WRITE (out, " ");
 305      }
 306      WRITE (out, TEXT (p));
 307      print_identifiers (out, MORE (p));
 308    }
 309  }
 310  
 311  //! @brief Print declarations.
 312  
 313  void print_declarations (FILE_T out, DEC_T * p)
 314  {
 315    if (p != NO_DEC) {
 316      print_declarations (out, LESS (p));
 317      indent (out, TEXT (p));
 318      WRITE (out, " ");
 319      A68_OPT (put_idf_comma) = A68_FALSE;
 320      print_identifiers (out, SUB (p));
 321      WRITE (out, ";\n");
 322      print_declarations (out, MORE (p));
 323    }
 324  }
 325  
 326  // Administration for common functions.
 327  // Otherwise we generate many routines that push 0 or 1 or TRUE etc.
 328  
 329  //! @brief Make name.
 330  
 331  char *make_unic_name (char *buf, char *name, char *tag, char *ext)
 332  {
 333    if (strlen (tag) > 0) {
 334      ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s_%s", name, tag, ext) >= 0);
 335    } else {
 336      ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s", name, ext) >= 0);
 337    }
 338    ABEND (strlen (buf) >= NAME_SIZE, ERROR_ACTION, __func__);
 339    return buf;
 340  }
 341  
 342  //! @brief Look up a name in the list.
 343  
 344  char *signed_in_name (char *name)
 345  {
 346    int k;
 347    for (k = 0; k < A68_OPT (unic_pointer); k++) {
 348      if (strcmp (UNIC_NAME (k), name) == 0) {
 349        return UNIC_NAME (k);
 350      }
 351    }
 352    return NO_TEXT;
 353  }
 354  
 355  //! @brief Enter new name in list, if there is space.
 356  
 357  void sign_in_name (char *name, int *action)
 358  {
 359    if (signed_in_name (name)) {
 360      *action = UNIC_EXISTS;
 361    } else if (A68_OPT (unic_pointer) < MAX_UNIC) {
 362      UNIC_NAME (A68_OPT (unic_pointer)) = new_string (name, NO_TEXT);
 363      A68_OPT (unic_pointer)++;
 364      *action = UNIC_MAKE_NEW;
 365    } else {
 366      *action = UNIC_MAKE_ALT;
 367    }
 368  }
 369  
 370  //! @brief Book identifier to keep track of it for CSE.
 371  
 372  void sign_in (int action, int phase, char *idf, void *info, int number)
 373  {
 374    if (A68_OPT (cse_pointer) < MAX_BOOK) {
 375      ACTION (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = action;
 376      PHASE (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = phase;
 377      IDF (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = idf;
 378      INFO (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = info;
 379      NUMBER (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = number;
 380      A68_OPT (cse_pointer)++;
 381    }
 382  }
 383  
 384  //! @brief Whether identifier is signed_in.
 385  
 386  BOOK_T *signed_in (int action, int phase, char *idf)
 387  {
 388    int k;
 389    for (k = 0; k < A68_OPT (cse_pointer); k++) {
 390      if (IDF (&A68_OPT (cse_book)[k]) == idf && ACTION (&A68_OPT (cse_book)[k]) == action && PHASE (&A68_OPT (cse_book)[k]) >= phase) {
 391        return &(A68_OPT (cse_book)[k]);
 392      }
 393    }
 394    return NO_BOOK;
 395  }
 396  
 397  //! @brief Make name.
 398  
 399  char *make_name (char *buf, char *name, char *tag, int n)
 400  {
 401    if (strlen (tag) > 0) {
 402      ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s_%d", name, tag, n) >= 0);
 403    } else {
 404      ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%d", name, n) >= 0);
 405    }
 406    ABEND (strlen (buf) >= NAME_SIZE, ERROR_ACTION, __func__);
 407    return buf;
 408  }
 409  
 410  //! @brief Whether two sub-trees are the same Algol 68 construct.
 411  
 412  BOOL_T same_tree (NODE_T * l, NODE_T * r)
 413  {
 414    if (l == NO_NODE) {
 415      return (BOOL_T) (r == NO_NODE);
 416    } else if (r == NO_NODE) {
 417      return (BOOL_T) (l == NO_NODE);
 418    } else if (ATTRIBUTE (l) == ATTRIBUTE (r) && NSYMBOL (l) == NSYMBOL (r)) {
 419      return (BOOL_T) (same_tree (SUB (l), SUB (r)) && same_tree (NEXT (l), NEXT (r)));
 420    } else {
 421      return A68_FALSE;
 422    }
 423  }
 424  
 425  // Basic mode check.
 426  
 427  //! @brief Whether stems from certain attribute.
 428  
 429  NODE_T *stems_from (NODE_T * p, int att)
 430  {
 431    if (IS (p, VOIDING)) {
 432      return stems_from (SUB (p), att);
 433    } else if (IS (p, UNIT)) {
 434      return stems_from (SUB (p), att);
 435    } else if (IS (p, TERTIARY)) {
 436      return stems_from (SUB (p), att);
 437    } else if (IS (p, SECONDARY)) {
 438      return stems_from (SUB (p), att);
 439    } else if (IS (p, PRIMARY)) {
 440      return stems_from (SUB (p), att);
 441    } else if (IS (p, att)) {
 442      return p;
 443    } else {
 444      return NO_NODE;
 445    }
 446  }
 447  
 448  // Auxilliary routines for emitting C code.
 449  
 450  //! @brief Whether frame needs initialisation.
 451  
 452  BOOL_T need_initialise_frame (NODE_T * p)
 453  {
 454    TAG_T *tag;
 455    int count;
 456    for (tag = ANONYMOUS (TABLE (p)); tag != NO_TAG; FORWARD (tag)) {
 457      if (PRIO (tag) == ROUTINE_TEXT) {
 458        return A68_TRUE;
 459      } else if (PRIO (tag) == FORMAT_TEXT) {
 460        return A68_TRUE;
 461      }
 462    }
 463    count = 0;
 464    genie_find_proc_op (p, &count);
 465    if (count > 0) {
 466      return A68_TRUE;
 467    } else {
 468      return A68_FALSE;
 469    }
 470  }
 471  
 472  //! @brief Comment source line.
 473  
 474  void comment_tree (NODE_T * p, FILE_T out, int *want_space, int *max_print)
 475  {
 476  // Take care not to generate nested comments.
 477  #define UNDENT(out, p) {\
 478    char * q;\
 479    for (q = p; q[0] != NULL_CHAR; q ++) {\
 480      if (q[0] == '*' && q[1] == '/') {\
 481        undent (out, "\\*\\/");\
 482        q ++;\
 483      } else if (q[0] == '/' && q[1] == '*') {\
 484        undent (out, "\\/\\*");\
 485        q ++;\
 486      } else {\
 487        char w[2];\
 488        w[0] = q[0];\
 489        w[1] = NULL_CHAR;\
 490        undent (out, w);\
 491      }\
 492    }}
 493  
 494    for (; p != NO_NODE && (*max_print) >= 0; FORWARD (p)) {
 495      if (IS (p, ROW_CHAR_DENOTATION)) {
 496        if (*want_space != 0) {
 497          UNDENT (out, " ");
 498        }
 499        UNDENT (out, "\"");
 500        UNDENT (out, NSYMBOL (p));
 501        UNDENT (out, "\"");
 502        *want_space = 2;
 503      } else if (SUB (p) != NO_NODE) {
 504        comment_tree (SUB (p), out, want_space, max_print);
 505      } else if (NSYMBOL (p)[0] == '(' || NSYMBOL (p)[0] == '[' || NSYMBOL (p)[0] == '{') {
 506        if (*want_space == 2) {
 507          UNDENT (out, " ");
 508        }
 509        UNDENT (out, NSYMBOL (p));
 510        *want_space = 0;
 511      } else if (NSYMBOL (p)[0] == ')' || NSYMBOL (p)[0] == ']' || NSYMBOL (p)[0] == '}') {
 512        UNDENT (out, NSYMBOL (p));
 513        *want_space = 1;
 514      } else if (NSYMBOL (p)[0] == ';' || NSYMBOL (p)[0] == ',') {
 515        UNDENT (out, NSYMBOL (p));
 516        *want_space = 2;
 517      } else if (strlen (NSYMBOL (p)) == 1 && (NSYMBOL (p)[0] == '.' || NSYMBOL (p)[0] == ':')) {
 518        UNDENT (out, NSYMBOL (p));
 519        *want_space = 2;
 520      } else {
 521        if (*want_space != 0) {
 522          UNDENT (out, " ");
 523        }
 524        if ((*max_print) > 0) {
 525          UNDENT (out, NSYMBOL (p));
 526        } else if ((*max_print) == 0) {
 527          if (*want_space == 0) {
 528            UNDENT (out, " ");
 529          }
 530          UNDENT (out, "...");
 531        }
 532        (*max_print)--;
 533        if (IS_UPPER (NSYMBOL (p)[0])) {
 534          *want_space = 2;
 535        } else if (!IS_ALNUM (NSYMBOL (p)[0])) {
 536          *want_space = 2;
 537        } else {
 538          *want_space = 1;
 539        }
 540      }
 541    }
 542  #undef UNDENT
 543  }
 544  
 545  //! @brief Comment source line.
 546  
 547  void comment_source (NODE_T * p, FILE_T out)
 548  {
 549    int want_space = 0, max_print = 16, ld = -1;
 550    undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\n// %s: %d: ", FILENAME (LINE (INFO (p))), LINE_NUMBER (p)));
 551    comment_tree (p, out, &want_space, &max_print);
 552    tree_listing (out, p, 1, LINE (INFO (p)), &ld, A68_TRUE);
 553    undent (out, "\n");
 554  }
 555  
 556  //! @brief Inline comment source line.
 557  
 558  void inline_comment_source (NODE_T * p, FILE_T out)
 559  {
 560    int want_space = 0, max_print = 8;
 561    undent (out, " // ");
 562    comment_tree (p, out, &want_space, &max_print);
 563  //  undent (out, " */");
 564  }
 565  
 566  //! @brief Write prelude.
 567  
 568  void write_prelude (FILE_T out)
 569  {
 570    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// \"%s\" %s\n", FILE_OBJECT_NAME (&A68_JOB), PACKAGE_STRING));
 571    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// optimiser_level=%d code_level=%d\n", OPTION_OPT_LEVEL (&A68_JOB), A68_OPT (OPTION_CODE_LEVEL)));
 572    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// %s %s\n", __DATE__, __TIME__));
 573    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\n#include <%s/a68g-config.h>\n", PACKAGE));
 574    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g.h>\n", PACKAGE));
 575    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-genie.h>\n", PACKAGE));
 576    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-prelude.h>\n", PACKAGE));
 577    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-environ.h>\n", PACKAGE));
 578    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-lib.h>\n", PACKAGE));
 579    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-optimiser.h>\n", PACKAGE));
 580    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-frames.h>\n", PACKAGE));
 581    indent (out, "\n#define _NODE_(n) (A68 (node_register)[n])\n");
 582    indent (out, "#define _STATUS_(z) (STATUS (z))\n");
 583    indent (out, "#define _VALUE_(z) (VALUE (z))\n");
 584  }
 585  
 586  //! @brief Write initialisation of frame.
 587  
 588  void init_static_frame (FILE_T out, NODE_T * p)
 589  {
 590    if (AP_INCREMENT (TABLE (p)) > 0) {
 591      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (" A68_LU ");\n", AP_INCREMENT (TABLE (p))));
 592    }
 593    if (LEX_LEVEL (p) == A68 (global_level)) {
 594      indent (out, "A68_GLOBALS = A68_FP;\n");
 595    }
 596    if (need_initialise_frame (p)) {
 597      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "initialise_frame (_NODE_ (%d));\n", NUMBER (p)));
 598    }
 599  }
 600  
 601  // COMPILATION OF PARTIAL UNITS.
 602  
 603  void gen_check_init (NODE_T * p, FILE_T out, char *idf)
 604  {
 605    if (OPTION_COMPILE_CHECK (&A68_JOB) && folder_mode (MOID (p))) {
 606      if (MOID (p) == M_COMPLEX) {
 607        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "if (!(INITIALISED (&(*%s)[0]) && INITIALISED (&(*%s)[1]))) {\n", idf, idf));
 608        A68_OPT (indentation)++;
 609        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE_FROM, M_COMPLEX);\n"));
 610        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "exit_genie ((p), A68_RUNTIME_ERROR);\n"));
 611        A68_OPT (indentation)--;
 612        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "}\n"));
 613      } else {
 614        char *M = "M_ERROR";
 615        if (MOID (p) == M_INT) {
 616          M = "M_INT";
 617        } else if (MOID (p) == M_REAL) {
 618          M = "M_REAL";
 619        } else if (MOID (p) == M_BOOL) {
 620          M = "M_BOOL";
 621        } else if (MOID (p) == M_CHAR) {
 622          M = "M_CHAR";
 623        }
 624        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "if (!INITIALISED(%s)) {\n", idf));
 625        A68_OPT (indentation)++;
 626        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE_FROM, %s);\n", M));
 627        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "exit_genie ((p), A68_RUNTIME_ERROR);\n"));
 628        A68_OPT (indentation)--;
 629        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "}\n"));
 630      }
 631    }
 632  }
 633  
 634  //! @brief Code getting objects from the stack.
 635  
 636  void get_stack (NODE_T * p, FILE_T out, char *dst, char *cast)
 637  {
 638    if (A68_OPT (OPTION_CODE_LEVEL) >= 4) {
 639      if (LEVEL (GINFO (p)) == A68 (global_level)) {
 640        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_GLOBAL (%s, %s, " A68_LU ");\n", dst, cast, OFFSET (TAX (p))));
 641      } else {
 642        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, " A68_LU ");\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p))));
 643      }
 644    } else {
 645      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, " A68_LU ");\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p))));
 646    }
 647  }
 648  
 649  //! @brief Code function prelude.
 650  
 651  void write_fun_prelude (NODE_T * p, FILE_T out, char *fn)
 652  {
 653    (void) p;
 654    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\nPROP_T %s (NODE_T *p) {\n", fn));
 655    A68_OPT (indentation)++;
 656    indent (out, "PROP_T self;\n");
 657    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "UNIT (&self) = %s;\n", fn));
 658    indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "SOURCE (&self) = _NODE_ (%d);\n", NUMBER (p)));
 659    indent (out, "A68 (f_entry) = p;\n");
 660    A68_OPT (cse_pointer) = 0;
 661  }
 662  
 663  //! @brief Code function postlude.
 664  
 665  void write_fun_postlude (NODE_T * p, FILE_T out, char *fn)
 666  {
 667    (void) fn;
 668    (void) p;
 669    indent (out, "return (self);\n");
 670    A68_OPT (indentation)--;
 671    A68_OPT (procedures)++;
 672    indent (out, "}\n");
 673    A68_OPT (cse_pointer) = 0;
 674  }
 675  
 676  //! @brief Code internal a68g mode.
 677  
 678  char *internal_mode (MOID_T * m)
 679  {
 680    if (m == M_INT) {
 681      return "M_INT";
 682    } else if (m == M_REAL) {
 683      return "M_REAL";
 684    } else if (m == M_BOOL) {
 685      return "M_BOOL";
 686    } else if (m == M_CHAR) {
 687      return "M_CHAR";
 688    } else if (m == M_BITS) {
 689      return "M_BITS";
 690    } else {
 691      return "M_ERROR";
 692    }
 693  }
 694  
 695  //! @brief Compile denotation.
 696  
 697  char *compile_denotation (NODE_T * p, FILE_T out)
 698  {
 699    if (primitive_mode (MOID (p))) {
 700      static char fn[NAME_SIZE], N[NAME_SIZE];
 701      int action = UNIC_MAKE_ALT;
 702      comment_source (p, out);
 703      fn[0] = '\0';
 704      if (MOID (p) == M_INT) {
 705        char *end;
 706        UNSIGNED_T z = (UNSIGNED_T) a68_strtoi (NSYMBOL (p), &end, 10);
 707        ASSERT (snprintf (N, NAME_SIZE, A68_LX "_", z) >= 0);
 708        (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", N);
 709      } else if (MOID (p) == M_REAL) {
 710        char *V;
 711        char W[NAME_SIZE];
 712        int k;
 713        A68_SP = 0;
 714        PUSH_UNION (p, M_REAL);
 715        push_unit (p);
 716        INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
 717        PUSH_VALUE (p, REAL_WIDTH + EXP_WIDTH + 5, A68_INT);
 718        PUSH_VALUE (p, REAL_WIDTH, A68_INT);
 719        PUSH_VALUE (p, EXP_WIDTH + 1, A68_INT);
 720        PUSH_VALUE (p, 3, A68_INT);
 721        V = real (p);
 722        for (k = 0; V[0] != '\0'; V++) {
 723          if (IS_ALNUM (V[0])) {
 724            W[k++] = TO_LOWER (V[0]);
 725            W[k] = '\0';
 726          }
 727          if (V[0] == '.' || V[0] == '-') {
 728            W[k++] = '_';
 729            W[k] = '\0';
 730          }
 731        }
 732        (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", W);
 733      } else if (MOID (p) == M_BOOL) {
 734        (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", NSYMBOL (SUB (p)));
 735      } else if (MOID (p) == M_CHAR) {
 736        ASSERT (snprintf (N, NAME_SIZE, "%02x_", NSYMBOL (SUB (p))[0]) >= 0);
 737        (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", N);
 738      }
 739      if (fn[0] != '\0') {
 740        sign_in_name (fn, &action);
 741        if (action == UNIC_EXISTS) {
 742          return fn;
 743        }
 744      }
 745      if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) {
 746        if (action == UNIC_MAKE_ALT) {
 747          (void) make_name (fn, moid_with_name ("", MOID (p), "_denotation_alt"), "", NUMBER (p));
 748        }
 749        write_fun_prelude (p, out, fn);
 750        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
 751        inline_unit (p, out, L_YIELD);
 752        undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
 753        write_fun_postlude (p, out, fn);
 754      }
 755      return fn;
 756    } else {
 757      return NO_TEXT;
 758    }
 759  }
 760  
 761  char *compile_cast (NODE_T * p, FILE_T out)
 762  {
 763    if (folder_mode (MOID (p)) && basic_unit (p)) {
 764      static char fn[NAME_SIZE];
 765      comment_source (p, out);
 766      (void) make_name (fn, moid_with_name ("", MOID (p), "_cast"), "", NUMBER (p));
 767      A68_OPT (root_idf) = NO_DEC;
 768      inline_unit (NEXT_SUB (p), out, L_DECLARE);
 769      print_declarations (out, A68_OPT (root_idf));
 770      inline_unit (NEXT_SUB (p), out, L_EXECUTE);
 771      gen_push (NEXT_SUB (p), out);
 772      return fn;
 773    } else {
 774      return NO_TEXT;
 775    }
 776  }
 777  
 778  //! @brief Compile identifier.
 779  
 780  char *compile_identifier (NODE_T * p, FILE_T out)
 781  {
 782    if (folder_mode (MOID (p))) {
 783      static char fn[NAME_SIZE];
 784      int action = UNIC_MAKE_ALT;
 785      char N[NAME_SIZE];
 786  // Some identifiers in standenv cannot be pushed.
 787  // Examples are cputime, or clock that are procedures in disguise.
 788      if (A68_STANDENV_PROC (TAX (p))) {
 789        int k;
 790        BOOL_T ok = A68_FALSE;
 791        for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
 792          if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
 793            ok = A68_TRUE;
 794          }
 795        }
 796        if (!ok) {
 797          return NO_TEXT;
 798        }
 799      }
 800  // Push the identifier.
 801      ASSERT (snprintf (N, NAME_SIZE, "%d_%d_" A68_LU, NUM (TABLE (TAX (p))), LEVEL (GINFO (p)), OFFSET (TAX (p))) >= 0);
 802      comment_source (p, out);
 803      fn[0] = '\0';
 804      (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_identifier"), "", N);
 805      sign_in_name (fn, &action);
 806      if (action == UNIC_EXISTS) {
 807        return fn;
 808      }
 809      if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) {
 810        if (action == UNIC_MAKE_ALT) {
 811          (void) make_name (fn, moid_with_name ("", MOID (p), "_identifier_alt"), "", NUMBER (p));
 812        }
 813        write_fun_prelude (p, out, fn);
 814        A68_OPT (root_idf) = NO_DEC;
 815        inline_unit (p, out, L_DECLARE);
 816        print_declarations (out, A68_OPT (root_idf));
 817        inline_unit (p, out, L_EXECUTE);
 818        gen_push (p, out);
 819        write_fun_postlude (p, out, fn);
 820      }
 821      return fn;
 822    } else {
 823      return NO_TEXT;
 824    }
 825  }
 826  
 827  //! @brief Compile dereference identifier.
 828  
 829  char *compile_dereference_identifier (NODE_T * p, FILE_T out)
 830  {
 831    if (folder_mode (MOID (p))) {
 832      static char fn[NAME_SIZE];
 833      int action = UNIC_MAKE_ALT;
 834      char N[NAME_SIZE];
 835      NODE_T *q = SUB (p);
 836      ASSERT (snprintf (N, NAME_SIZE, "%d_%d_" A68_LU, NUM (TABLE (TAX (q))), LEVEL (GINFO (q)), OFFSET (TAX (q))) >= 0);
 837      comment_source (p, out);
 838      fn[0] = '\0';
 839      (void) make_unic_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", N);
 840      sign_in_name (fn, &action);
 841      if (action == UNIC_EXISTS) {
 842        return fn;
 843      }
 844      if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) {
 845        if (action == UNIC_MAKE_ALT) {
 846          (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier_alt"), "", NUMBER (p));
 847        }
 848        write_fun_prelude (p, out, fn);
 849        A68_OPT (root_idf) = NO_DEC;
 850        inline_unit (p, out, L_DECLARE);
 851        print_declarations (out, A68_OPT (root_idf));
 852        inline_unit (p, out, L_EXECUTE);
 853        gen_push (p, out);
 854        write_fun_postlude (p, out, fn);
 855      }
 856      return fn;
 857    } else {
 858      return NO_TEXT;
 859    }
 860  }
 861  
 862  //! @brief Compile formula.
 863  
 864  char *compile_formula (NODE_T * p, FILE_T out)
 865  {
 866    if (folder_mode (MOID (p)) && basic_unit (p)) {
 867      static char fn[NAME_SIZE];
 868      comment_source (p, out);
 869      (void) make_name (fn, moid_with_name ("", MOID (p), "_formula"), "", NUMBER (p));
 870      write_fun_prelude (p, out, fn);
 871      if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
 872        if (MOID (p) == M_REAL || MOID (p) == M_COMPLEX) {
 873          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_REAL * _st_ = (A68_REAL *) STACK_TOP;\n"));
 874        }
 875      }
 876      A68_OPT (root_idf) = NO_DEC;
 877      inline_unit (p, out, L_DECLARE);
 878      print_declarations (out, A68_OPT (root_idf));
 879      if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
 880        if (folder_mode (MOID (p))) {
 881          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "errno = 0;\n"));
 882        }
 883      }
 884      inline_unit (p, out, L_EXECUTE);
 885      gen_push (p, out);
 886      if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
 887        if (MOID (p) == M_INT) {
 888          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_INT, NO_TEXT);\n"));
 889        }
 890        if (MOID (p) == M_REAL) {
 891          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);\n"));
 892          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (_st_));\n"));
 893        }
 894        if (MOID (p) == M_BITS) {
 895          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_BITS, NO_TEXT);\n"));
 896        }
 897        if (MOID (p) == M_COMPLEX) {
 898          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT);\n"));
 899          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (&(_st_[0])));\n"));
 900          indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (&(_st_[1])));\n"));
 901        }
 902      }
 903      write_fun_postlude (p, out, fn);
 904      return fn;
 905    } else {
 906      return NO_TEXT;
 907    }
 908  }
 909  
 910  //! @brief Compile call.
 911  
 912  char *compile_call (NODE_T * p, FILE_T out)
 913  {
 914    NODE_T *proc = SUB (p);
 915    NODE_T *args = NEXT (proc);
 916    NODE_T *idf = stems_from (proc, IDENTIFIER);
 917    if (idf == NO_NODE) {
 918      return NO_TEXT;
 919    } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) {
 920      return NO_TEXT;
 921    } else if (DIM (MOID (proc)) == 0) {
 922      return NO_TEXT;
 923    } else if (A68_STANDENV_PROC (TAX (idf))) {
 924      if (basic_call (p)) {
 925        static char fun[NAME_SIZE];
 926        comment_source (p, out);
 927        (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p));
 928        write_fun_prelude (p, out, fun);
 929        A68_OPT (root_idf) = NO_DEC;
 930        inline_unit (p, out, L_DECLARE);
 931        print_declarations (out, A68_OPT (root_idf));
 932        inline_unit (p, out, L_EXECUTE);
 933        gen_push (p, out);
 934        write_fun_postlude (p, out, fun);
 935        return fun;
 936      } else {
 937        return NO_TEXT;
 938      }
 939    } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
 940      return NO_TEXT;
 941    } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) {
 942      return NO_TEXT;
 943    } else if (!basic_argument (args)) {
 944      return NO_TEXT;
 945    } else {
 946      static char fn[NAME_SIZE];
 947      char fun[NAME_SIZE], pop[NAME_SIZE];
 948      int size;
 949  // Declare.
 950      (void) make_name (fun, FUN, "", NUMBER (proc));
 951      (void) make_name (pop, PUP, "", NUMBER (p));
 952      comment_source (p, out);
 953      (void) make_name (fn, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p));
 954      write_fun_prelude (p, out, fn);
 955  // Compute arguments.
 956      size = 0;
 957      A68_OPT (root_idf) = NO_DEC;
 958      inline_arguments (args, out, L_DECLARE, &size);
 959      (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
 960      (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun);
 961      (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
 962      print_declarations (out, A68_OPT (root_idf));
 963  // Initialise.
 964      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
 965      inline_arguments (args, out, L_INITIALISE, &size);
 966      get_stack (idf, out, fun, "A68_PROCEDURE");
 967      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
 968      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
 969      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
 970      size = 0;
 971      inline_arguments (args, out, L_EXECUTE, &size);
 972      size = 0;
 973      inline_arguments (args, out, L_YIELD, &size);
 974  // Execute procedure.
 975      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
 976      indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n");
 977      indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
 978      A68_OPT (indentation)++;
 979      indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
 980      A68_OPT (indentation)--;
 981      indent (out, "}\n");
 982      indent (out, "CLOSE_FRAME;\n");
 983      write_fun_postlude (p, out, fn);
 984      return fn;
 985    }
 986  }
 987