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