plugin-inline.c

     
   1  //! @file plugin-inline.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 inlining routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-optimiser.h"
  28  #include "a68g-plugin.h"
  29  #include "a68g-transput.h"
  30  
  31  //! @brief Code an A68 mode.
  32  
  33  char *inline_mode (MOID_T * m)
  34  {
  35    if (m == M_INT) {
  36      return "A68_INT";
  37    } else if (m == M_REAL) {
  38      return "A68_REAL";
  39    } else if (m == M_BOOL) {
  40      return "A68_BOOL";
  41    } else if (m == M_CHAR) {
  42      return "A68_CHAR";
  43    } else if (m == M_BITS) {
  44      return "A68_BITS";
  45    } else if (m == M_COMPLEX) {
  46      return "A68_COMPLEX";
  47    } else if (IS (m, REF_SYMBOL)) {
  48      return "A68_REF";
  49    } else if (IS (m, ROW_SYMBOL)) {
  50      return "A68_ROW";
  51    } else if (IS (m, PROC_SYMBOL)) {
  52      return "A68_PROCEDURE";
  53    } else if (IS (m, STRUCT_SYMBOL)) {
  54      return "A68_STRUCT";
  55    } else {
  56      return "A68_ERROR";
  57    }
  58  }
  59  
  60  //! @brief Compile inline arguments.
  61  
  62  void inline_arguments (NODE_T * p, FILE_T out, int phase, int *size)
  63  {
  64    if (p == NO_NODE) {
  65      return;
  66    } else if (IS (p, UNIT) && phase == L_PUSH) {
  67      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "GENIE_UNIT_TRACE (_NODE_ (%d));\n", NUMBER (p)));
  68      inline_arguments (NEXT (p), out, L_PUSH, size);
  69    } else if (IS (p, UNIT)) {
  70      char arg[NAME_SIZE];
  71      (void) make_name (arg, ARG, "", NUMBER (p));
  72      if (phase == L_DECLARE) {
  73        (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 1, arg);
  74        inline_unit (p, out, L_DECLARE);
  75      } else if (phase == L_INITIALISE) {
  76        inline_unit (p, out, L_EXECUTE);
  77      } else if (phase == L_EXECUTE) {
  78        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) FRAME_OBJECT (%d);\n", arg, inline_mode (MOID (p)), *size));
  79        (*size) += SIZE (MOID (p));
  80      } else if (phase == L_YIELD && primitive_mode (MOID (p))) {
  81        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", arg));
  82        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = ", arg));
  83        inline_unit (p, out, L_YIELD);
  84        undent (out, ";\n");
  85      } else if (phase == L_YIELD && basic_mode (MOID (p))) {
  86        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", arg));
  87        inline_unit (p, out, L_YIELD);
  88        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
  89      }
  90    } else {
  91      inline_arguments (SUB (p), out, phase, size);
  92      inline_arguments (NEXT (p), out, phase, size);
  93    }
  94  }
  95  
  96  //! @brief Code denotation.
  97  
  98  void inline_denotation (NODE_T * p, FILE_T out, int phase)
  99  {
 100    if (phase == L_YIELD) {
 101      if (MOID (p) == M_INT) {
 102        NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
 103        char *den = NSYMBOL (s);
 104        A68_INT z;
 105        if (genie_string_to_value_internal (p, M_INT, den, (BYTE_T *) & z) == A68_FALSE) {
 106          diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_INT);
 107        }
 108        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, A68_LD, VALUE (&z)));
 109      } else if (MOID (p) == M_REAL) {
 110        NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
 111        char *den = NSYMBOL (s);
 112        A68_REAL z;
 113        if (genie_string_to_value_internal (p, M_REAL, den, (BYTE_T *) & z) == A68_FALSE) {
 114          diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_REAL);
 115        }
 116        if (strchr (den, '.') == NO_TEXT && strchr (den, 'e') == NO_TEXT && strchr (den, 'E') == NO_TEXT) {
 117          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(REAL_T) %s", den));
 118        } else {
 119          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", den));
 120        }
 121      } else if (MOID (p) == M_BOOL) {
 122        undent (out, "(BOOL_T) A68_");
 123        undent (out, NSYMBOL (p));
 124      } else if (MOID (p) == M_CHAR) {
 125        if (NSYMBOL (p)[0] == '\'') {
 126          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "'\\''"));
 127        } else if (NSYMBOL (p)[0] == NULL_CHAR) {
 128          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "NULL_CHAR"));
 129        } else if (NSYMBOL (p)[0] == '\\') {
 130          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "'\\\\'"));
 131        } else {
 132          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "'%c'", (NSYMBOL (p))[0]));
 133        }
 134      } else if (MOID (p) == M_BITS) {
 135        A68_BITS z;
 136        NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
 137        if (genie_string_to_value_internal (p, M_BITS, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
 138          diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_BITS);
 139        }
 140        ASSERT (a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(UNSIGNED_T) 0x" A68_LX, VALUE (&z)) >= 0);
 141        undent (out, A68 (edit_line));
 142      }
 143    }
 144  }
 145  
 146  //! @brief Code widening.
 147  
 148  void inline_widening (NODE_T * p, FILE_T out, int phase)
 149  {
 150    if (WIDEN_TO (p, INT, REAL)) {
 151      if (phase == L_DECLARE) {
 152        inline_unit (SUB (p), out, L_DECLARE);
 153      } else if (phase == L_EXECUTE) {
 154        inline_unit (SUB (p), out, L_EXECUTE);
 155      } else if (phase == L_YIELD) {
 156        undent (out, "(REAL_T) (");
 157        inline_unit (SUB (p), out, L_YIELD);
 158        undent (out, ")");
 159      }
 160    } else if (WIDEN_TO (p, REAL, COMPLEX)) {
 161      char acc[NAME_SIZE];
 162      (void) make_name (acc, TMP, "", NUMBER (p));
 163      if (phase == L_DECLARE) {
 164        (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_COMPLEX), 0, acc);
 165        inline_unit (SUB (p), out, L_DECLARE);
 166      } else if (phase == L_EXECUTE) {
 167        inline_unit (SUB (p), out, L_EXECUTE);
 168        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "STATUS_RE (%s) = INIT_MASK;\n", acc));
 169        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "STATUS_IM (%s) = INIT_MASK;\n", acc));
 170        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "RE (%s) = (REAL_T) (", acc));
 171        inline_unit (SUB (p), out, L_YIELD);
 172        undent (out, ");\n");
 173        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "IM (%s) = 0.0;\n", acc));
 174      } else if (phase == L_YIELD) {
 175        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) %s", acc));
 176      }
 177    }
 178  }
 179  
 180  //! @brief Code dereferencing of identifier.
 181  
 182  void inline_dereference_identifier (NODE_T * p, FILE_T out, int phase)
 183  {
 184    NODE_T *q = stems_from (SUB (p), IDENTIFIER);
 185    ABEND (q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
 186    if (phase == L_DECLARE) {
 187      if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) != NO_BOOK) {
 188        return;
 189      } else {
 190        char idf[NAME_SIZE];
 191        (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
 192        (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 1, idf);
 193        sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
 194        inline_unit (SUB (p), out, L_DECLARE);
 195      }
 196    } else if (phase == L_EXECUTE) {
 197      if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) {
 198        return;
 199      } else {
 200        char idf[NAME_SIZE];
 201        (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
 202        inline_unit (SUB (p), out, L_EXECUTE);
 203        if (BODY (TAX (q)) != NO_TAG) {
 204          indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (MOID (p))));
 205          sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
 206          inline_unit (SUB (p), out, L_YIELD);
 207          undent (out, ");\n");
 208        } else {
 209          indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (MOID (p))));
 210          sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
 211          inline_unit (SUB (p), out, L_YIELD);
 212          undent (out, ");\n");
 213        }
 214        gen_check_init (p, out, idf);
 215      }
 216    } else if (phase == L_YIELD) {
 217      char idf[NAME_SIZE];
 218      if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) {
 219        (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q))));
 220      } else {
 221        (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
 222      }
 223      if (primitive_mode (MOID (p))) {
 224        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", idf));
 225      } else if (MOID (p) == M_COMPLEX) {
 226        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf));
 227      } else if (basic_mode (MOID (p))) {
 228        undent (out, idf);
 229      }
 230    }
 231  }
 232  
 233  //! @brief Code identifier.
 234  
 235  void inline_identifier (NODE_T * p, FILE_T out, int phase)
 236  {
 237  // Possible constant folding.
 238    NODE_T *def = NODE (TAX (p));
 239    if (primitive_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) {
 240      NODE_T *src = stems_from (NEXT_NEXT (def), DENOTATION);
 241      if (src != NO_NODE) {
 242        inline_denotation (src, out, phase);
 243        return;
 244      }
 245    }
 246  // No folding - consider identifier.
 247    if (phase == L_DECLARE) {
 248      if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) {
 249        return;
 250      } else if (A68_STANDENV_PROC (TAX (p))) {
 251        return;
 252      } else {
 253        char idf[NAME_SIZE];
 254        (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
 255        (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 1, idf);
 256        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
 257      }
 258    } else if (phase == L_EXECUTE) {
 259      if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) {
 260        return;
 261      } else if (A68_STANDENV_PROC (TAX (p))) {
 262        return;
 263      } else {
 264        char idf[NAME_SIZE];
 265        (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
 266        get_stack (p, out, idf, inline_mode (MOID (p)));
 267        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
 268        gen_check_init (p, out, idf);
 269      }
 270    } else if (phase == L_YIELD) {
 271      if (A68_STANDENV_PROC (TAX (p))) {
 272        for (int k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
 273          if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
 274            undent (out, CODE (&constants[k]));
 275            return;
 276          }
 277        }
 278      } else {
 279        char idf[NAME_SIZE];
 280        BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p));
 281        if (entry != NO_BOOK) {
 282          (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry));
 283        } else {
 284          (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
 285        }
 286        if (primitive_mode (MOID (p))) {
 287          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", idf));
 288        } else if (MOID (p) == M_COMPLEX) {
 289          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf));
 290        } else if (basic_mode (MOID (p))) {
 291          undent (out, idf);
 292        }
 293      }
 294    }
 295  }
 296  
 297  //! @brief Code indexer.
 298  
 299  void inline_indexer (NODE_T * p, FILE_T out, int phase, INT_T * k, char *tup)
 300  {
 301    if (p == NO_NODE) {
 302      return;
 303    } else if (IS (p, UNIT)) {
 304      if (phase != L_YIELD) {
 305        inline_unit (p, out, phase);
 306      } else {
 307        if ((*k) == 0) {
 308          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(SPAN (&%s[" A68_LD "]) * (", tup, (*k)));
 309        } else {
 310          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, " + (SPAN (&%s[" A68_LD "]) * (", tup, (*k)));
 311        }
 312        inline_unit (p, out, L_YIELD);
 313        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ") - SHIFT (&%s[" A68_LD "]))", tup, (*k)));
 314      }
 315      (*k)++;
 316    } else {
 317      inline_indexer (SUB (p), out, phase, k, tup);
 318      inline_indexer (NEXT (p), out, phase, k, tup);
 319    }
 320  }
 321  
 322  //! @brief Code dereferencing of slice.
 323  
 324  void inline_dereference_slice (NODE_T * p, FILE_T out, int phase)
 325  {
 326    NODE_T *prim = SUB (p);
 327    NODE_T *indx = NEXT (prim);
 328    MOID_T *row_mode = DEFLEX (MOID (prim));
 329    MOID_T *mode = SUB_SUB (row_mode);
 330    char *symbol = NSYMBOL (SUB (prim));
 331    char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE];
 332    if (phase == L_DECLARE) {
 333      BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
 334      if (entry == NO_BOOK) {
 335        (void) make_name (idf, symbol, "", NUMBER (prim));
 336        (void) make_name (arr, ARR, "", NUMBER (prim));
 337        (void) make_name (tup, TUP, "", NUMBER (prim));
 338        (void) make_name (elm, ELM, "", NUMBER (prim));
 339        (void) make_name (drf, DRF, "", NUMBER (prim));
 340        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, idf);
 341        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
 342        (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr);
 343        (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup);
 344        (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
 345        sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
 346      } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
 347        (void) make_name (elm, ELM, "", NUMBER (prim));
 348        (void) make_name (drf, DRF, "", NUMBER (prim));
 349        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
 350        (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
 351      }
 352      INT_T k = 0;
 353      inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
 354    } else if (phase == L_EXECUTE) {
 355      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
 356      NODE_T *pidf = stems_from (prim, IDENTIFIER);
 357      if (entry == NO_BOOK) {
 358        (void) make_name (idf, symbol, "", NUMBER (prim));
 359        (void) make_name (arr, ARR, "", NUMBER (prim));
 360        (void) make_name (tup, TUP, "", NUMBER (prim));
 361        (void) make_name (elm, ELM, "", NUMBER (prim));
 362        (void) make_name (drf, DRF, "", NUMBER (prim));
 363        get_stack (pidf, out, idf, "A68_REF");
 364        if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) {
 365          indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
 366        } else {
 367          ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 368        }
 369        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
 370      } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
 371        (void) make_name (arr, ARR, "", NUMBER (entry));
 372        (void) make_name (tup, TUP, "", NUMBER (entry));
 373        (void) make_name (elm, ELM, "", NUMBER (prim));
 374        (void) make_name (drf, DRF, "", NUMBER (prim));
 375      } else {
 376        return;
 377      }
 378      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
 379      INT_T k = 0;
 380      inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
 381      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
 382      k = 0;
 383      inline_indexer (indx, out, L_YIELD, &k, tup);
 384      undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
 385      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
 386    } else if (phase == L_YIELD) {
 387      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
 388      if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
 389        (void) make_name (drf, DRF, "", NUMBER (entry));
 390      } else {
 391        (void) make_name (drf, DRF, "", NUMBER (prim));
 392      }
 393      if (primitive_mode (mode)) {
 394        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", drf));
 395      } else if (mode == M_COMPLEX) {
 396        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf));
 397      } else if (basic_mode (mode)) {
 398        undent (out, drf);
 399      } else {
 400        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 401      }
 402    }
 403  }
 404  
 405  //! @brief Code slice REF [] MODE -> REF MODE.
 406  
 407  void inline_slice_ref_to_ref (NODE_T * p, FILE_T out, int phase)
 408  {
 409    NODE_T *prim = SUB (p);
 410    NODE_T *indx = NEXT (prim);
 411    MOID_T *mode = SUB_MOID (p);
 412    MOID_T *row_mode = DEFLEX (MOID (prim));
 413    char *symbol = NSYMBOL (SUB (prim));
 414    char idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], drf[NAME_SIZE];
 415    if (phase == L_DECLARE) {
 416      BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
 417      if (entry == NO_BOOK) {
 418        (void) make_name (idf, symbol, "", NUMBER (prim));
 419        (void) make_name (arr, ARR, "", NUMBER (prim));
 420        (void) make_name (tup, TUP, "", NUMBER (prim));
 421        (void) make_name (elm, ELM, "", NUMBER (prim));
 422        (void) make_name (drf, DRF, "", NUMBER (prim));
 423        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, idf);
 424        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
 425        (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr);
 426        (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup);
 427        (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
 428        sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
 429      } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
 430        (void) make_name (elm, ELM, "", NUMBER (prim));
 431        (void) make_name (drf, DRF, "", NUMBER (prim));
 432        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
 433        (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
 434      }
 435      INT_T k = 0;
 436      inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
 437    } else if (phase == L_EXECUTE) {
 438      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
 439      if (entry == NO_BOOK) {
 440        NODE_T *pidf = stems_from (prim, IDENTIFIER);
 441        (void) make_name (idf, symbol, "", NUMBER (prim));
 442        (void) make_name (arr, ARR, "", NUMBER (prim));
 443        (void) make_name (tup, TUP, "", NUMBER (prim));
 444        (void) make_name (elm, ELM, "", NUMBER (prim));
 445        (void) make_name (drf, DRF, "", NUMBER (prim));
 446        get_stack (pidf, out, idf, "A68_REF");
 447        if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) {
 448          indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
 449        } else {
 450          ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 451        }
 452        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
 453      } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
 454        (void) make_name (arr, ARR, "", NUMBER (entry));
 455        (void) make_name (tup, TUP, "", NUMBER (entry));
 456        (void) make_name (elm, ELM, "", NUMBER (prim));
 457        (void) make_name (drf, DRF, "", NUMBER (prim));
 458      } else {
 459        return;
 460      }
 461      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
 462      INT_T k = 0;
 463      inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
 464      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
 465      k = 0;
 466      inline_indexer (indx, out, L_YIELD, &k, tup);
 467      undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
 468      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
 469    } else if (phase == L_YIELD) {
 470      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
 471      if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
 472        (void) make_name (elm, ELM, "", NUMBER (entry));
 473      } else {
 474        (void) make_name (elm, ELM, "", NUMBER (prim));
 475      }
 476      undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(&%s)", elm));
 477    }
 478  }
 479  
 480  //! @brief Code slice [] MODE -> MODE.
 481  
 482  void inline_slice (NODE_T * p, FILE_T out, int phase)
 483  {
 484    NODE_T *prim = SUB (p);
 485    NODE_T *indx = NEXT (prim);
 486    MOID_T *mode = MOID (p);
 487    MOID_T *row_mode = DEFLEX (MOID (prim));
 488    char *symbol = NSYMBOL (SUB (prim));
 489    char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE];
 490    if (phase == L_DECLARE) {
 491      BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
 492      if (entry == NO_BOOK) {
 493        (void) make_name (idf, symbol, "", NUMBER (prim));
 494        (void) make_name (arr, ARR, "", NUMBER (prim));
 495        (void) make_name (tup, TUP, "", NUMBER (prim));
 496        (void) make_name (elm, ELM, "", NUMBER (prim));
 497        (void) make_name (drf, DRF, "", NUMBER (prim));
 498        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "A68_REF * %s, %s; %s * %s; A68_ARRAY * %s; A68_TUPLE * %s;\n", idf, elm, inline_mode (mode), drf, arr, tup));
 499        sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
 500      } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
 501        (void) make_name (elm, ELM, "", NUMBER (prim));
 502        (void) make_name (drf, DRF, "", NUMBER (prim));
 503        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "A68_REF %s; %s * %s;\n", elm, inline_mode (mode), drf));
 504      }
 505      INT_T k = 0;
 506      inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
 507    } else if (phase == L_EXECUTE) {
 508      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
 509      if (entry == NO_BOOK) {
 510        NODE_T *pidf = stems_from (prim, IDENTIFIER);
 511        (void) make_name (idf, symbol, "", NUMBER (prim));
 512        (void) make_name (arr, ARR, "", NUMBER (prim));
 513        (void) make_name (tup, TUP, "", NUMBER (prim));
 514        (void) make_name (elm, ELM, "", NUMBER (prim));
 515        (void) make_name (drf, DRF, "", NUMBER (prim));
 516        get_stack (pidf, out, idf, "A68_REF");
 517        if (IS (row_mode, REF_SYMBOL)) {
 518          indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
 519        } else {
 520          indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, (A68_ROW *) %s);\n", arr, tup, idf));
 521        }
 522        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
 523      } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
 524        (void) make_name (arr, ARR, "", NUMBER (entry));
 525        (void) make_name (tup, TUP, "", NUMBER (entry));
 526        (void) make_name (elm, ELM, "", NUMBER (prim));
 527        (void) make_name (drf, DRF, "", NUMBER (prim));
 528      } else {
 529        return;
 530      }
 531      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
 532      INT_T k = 0;
 533      inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
 534      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
 535      k = 0;
 536      inline_indexer (indx, out, L_YIELD, &k, tup);
 537      undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
 538      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
 539    } else if (phase == L_YIELD) {
 540      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
 541      if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
 542        (void) make_name (drf, DRF, "", NUMBER (entry));
 543      } else {
 544        (void) make_name (drf, DRF, "", NUMBER (prim));
 545      }
 546      if (primitive_mode (mode)) {
 547        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", drf));
 548      } else if (mode == M_COMPLEX) {
 549        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf));
 550      } else if (basic_mode (mode)) {
 551        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", drf));
 552      } else {
 553        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 554      }
 555    }
 556  }
 557  
 558  //! @brief Code monadic formula.
 559  
 560  void inline_monadic_formula (NODE_T * p, FILE_T out, int phase)
 561  {
 562    NODE_T *op = SUB (p), *rhs = NEXT (op);
 563    if (IS (p, MONADIC_FORMULA) && MOID (p) == M_COMPLEX) {
 564      char acc[NAME_SIZE];
 565      (void) make_name (acc, TMP, "", NUMBER (p));
 566      if (phase == L_DECLARE) {
 567        (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_COMPLEX), 0, acc);
 568        inline_unit (rhs, out, L_DECLARE);
 569      } else if (phase == L_EXECUTE) {
 570        inline_unit (rhs, out, L_EXECUTE);
 571        for (int k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
 572          if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
 573            indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&monadics[k]), acc));
 574            inline_unit (rhs, out, L_YIELD);
 575            undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
 576          }
 577        }
 578      } else if (phase == L_YIELD) {
 579        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", acc));
 580      }
 581    } else if (IS (p, MONADIC_FORMULA) && basic_mode (MOID (p))) {
 582      if (phase != L_YIELD) {
 583        inline_unit (rhs, out, phase);
 584      } else {
 585        for (int k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
 586          if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
 587            if (IS_ALNUM ((CODE (&monadics[k]))[0])) {
 588              undent (out, CODE (&monadics[k]));
 589              undent (out, "(");
 590              inline_unit (rhs, out, L_YIELD);
 591              undent (out, ")");
 592            } else {
 593              undent (out, CODE (&monadics[k]));
 594              undent (out, "(");
 595              inline_unit (rhs, out, L_YIELD);
 596              undent (out, ")");
 597            }
 598          }
 599        }
 600      }
 601    }
 602  }
 603  
 604  //! @brief Code dyadic formula.
 605  
 606  void inline_formula (NODE_T * p, FILE_T out, int phase)
 607  {
 608    NODE_T *lhs = SUB (p), *rhs;
 609    NODE_T *op = NEXT (lhs);
 610    if (IS (p, FORMULA) && op == NO_NODE) {
 611      inline_monadic_formula (lhs, out, phase);
 612      return;
 613    }
 614    rhs = NEXT (op);
 615    if (IS (p, FORMULA) && MOID (p) == M_COMPLEX) {
 616      if (op == NO_NODE) {
 617        inline_monadic_formula (lhs, out, phase);
 618      } else if (phase == L_DECLARE) {
 619        char acc[NAME_SIZE];
 620        (void) make_name (acc, TMP, "", NUMBER (p));
 621        (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 0, acc);
 622        inline_unit (lhs, out, L_DECLARE);
 623        inline_unit (rhs, out, L_DECLARE);
 624      } else if (phase == L_EXECUTE) {
 625        char acc[NAME_SIZE];
 626        (void) make_name (acc, TMP, "", NUMBER (p));
 627        inline_unit (lhs, out, L_EXECUTE);
 628        inline_unit (rhs, out, L_EXECUTE);
 629        for (int k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
 630          if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
 631            if (MOID (p) == M_COMPLEX) {
 632              indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&dyadics[k]), acc));
 633            } else {
 634              indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s (& %s, ", CODE (&dyadics[k]), acc));
 635            }
 636            inline_unit (lhs, out, L_YIELD);
 637            undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ", "));
 638            inline_unit (rhs, out, L_YIELD);
 639            undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
 640          }
 641        }
 642      } else if (phase == L_YIELD) {
 643        char acc[NAME_SIZE];
 644        (void) make_name (acc, TMP, "", NUMBER (p));
 645        if (MOID (p) == M_COMPLEX) {
 646          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", acc));
 647        } else {
 648          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (& %s)", acc));
 649        }
 650      }
 651    } else if (IS (p, FORMULA) && basic_mode (MOID (p))) {
 652      if (phase != L_YIELD) {
 653        inline_unit (lhs, out, phase);
 654        inline_unit (rhs, out, phase);
 655      } else {
 656        for (int k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
 657          if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
 658            if (IS_ALNUM ((CODE (&dyadics[k]))[0])) {
 659              undent (out, CODE (&dyadics[k]));
 660              undent (out, "(");
 661              inline_unit (lhs, out, L_YIELD);
 662              undent (out, ", ");
 663              inline_unit (rhs, out, L_YIELD);
 664              undent (out, ")");
 665            } else {
 666              undent (out, "(");
 667              inline_unit (lhs, out, L_YIELD);
 668              undent (out, " ");
 669              undent (out, CODE (&dyadics[k]));
 670              undent (out, " ");
 671              inline_unit (rhs, out, L_YIELD);
 672              undent (out, ")");
 673            }
 674          }
 675        }
 676      }
 677    }
 678  }
 679  
 680  //! @brief Code argument.
 681  
 682  void inline_single_argument (NODE_T * p, FILE_T out, int phase)
 683  {
 684    for (; p != NO_NODE; FORWARD (p)) {
 685      if (IS (p, ARGUMENT_LIST) || IS (p, ARGUMENT)) {
 686        inline_single_argument (SUB (p), out, phase);
 687      } else if (IS (p, GENERIC_ARGUMENT_LIST) || IS (p, GENERIC_ARGUMENT)) {
 688        inline_single_argument (SUB (p), out, phase);
 689      } else if (IS (p, UNIT)) {
 690        inline_unit (p, out, phase);
 691      }
 692    }
 693  }
 694  
 695  //! @brief Code call.
 696  
 697  void inline_call (NODE_T * p, FILE_T out, int phase)
 698  {
 699    NODE_T *prim = SUB (p);
 700    NODE_T *args = NEXT (prim);
 701    NODE_T *idf = stems_from (prim, IDENTIFIER);
 702    if (MOID (p) == M_COMPLEX) {
 703      char acc[NAME_SIZE];
 704      (void) make_name (acc, TMP, "", NUMBER (p));
 705      if (phase == L_DECLARE) {
 706        (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_COMPLEX), 0, acc);
 707        inline_single_argument (args, out, L_DECLARE);
 708      } else if (phase == L_EXECUTE) {
 709        inline_single_argument (args, out, L_EXECUTE);
 710        for (int k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
 711          if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
 712            indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&functions[k]), acc));
 713            inline_single_argument (args, out, L_YIELD);
 714            undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
 715          }
 716        }
 717      } else if (phase == L_YIELD) {
 718        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", acc));
 719      }
 720    } else if (basic_mode (MOID (p))) {
 721      if (phase != L_YIELD) {
 722        inline_single_argument (args, out, phase);
 723      } else {
 724        for (int k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
 725          if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
 726            undent (out, CODE (&functions[k]));
 727            undent (out, " (");
 728            inline_single_argument (args, out, L_YIELD);
 729            undent (out, ")");
 730          }
 731        }
 732      }
 733    }
 734  }
 735  
 736  //! @brief Code collateral units.
 737  
 738  void inline_collateral_units (NODE_T * p, FILE_T out, int phase)
 739  {
 740    if (p == NO_NODE) {
 741      return;
 742    } else if (IS (p, UNIT)) {
 743      if (phase == L_DECLARE) {
 744        inline_unit (SUB (p), out, L_DECLARE);
 745      } else if (phase == L_EXECUTE) {
 746        inline_unit (SUB (p), out, L_EXECUTE);
 747      } else if (phase == L_YIELD) {
 748        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
 749        inline_unit (SUB (p), out, L_YIELD);
 750        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
 751      }
 752    } else {
 753      inline_collateral_units (SUB (p), out, phase);
 754      inline_collateral_units (NEXT (p), out, phase);
 755    }
 756  }
 757  
 758  //! @brief Code collateral units.
 759  
 760  void inline_collateral (NODE_T * p, FILE_T out, int phase)
 761  {
 762    char dsp[NAME_SIZE];
 763    (void) make_name (dsp, DSP, "", NUMBER (p));
 764    if (p == NO_NODE) {
 765      return;
 766    } else if (phase == L_DECLARE) {
 767      if (MOID (p) == M_COMPLEX) {
 768        (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_REAL), 1, dsp);
 769      } else {
 770        (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 1, dsp);
 771      }
 772      inline_collateral_units (NEXT_SUB (p), out, L_DECLARE);
 773    } else if (phase == L_EXECUTE) {
 774      if (MOID (p) == M_COMPLEX) {
 775        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (M_REAL)));
 776      } else {
 777        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (MOID (p))));
 778      }
 779      inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE);
 780      inline_collateral_units (NEXT_SUB (p), out, L_YIELD);
 781    } else if (phase == L_YIELD) {
 782      undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", dsp));
 783    }
 784  }
 785  
 786  //! @brief Code basic closed clause.
 787  
 788  void inline_closed (NODE_T * p, FILE_T out, int phase)
 789  {
 790    if (p == NO_NODE) {
 791      return;
 792    } else if (phase != L_YIELD) {
 793      inline_unit (SUB (NEXT_SUB (p)), out, phase);
 794    } else {
 795      undent (out, "(");
 796      inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD);
 797      undent (out, ")");
 798    }
 799  }
 800  
 801  //! @brief Code basic closed clause.
 802  
 803  void inline_conditional (NODE_T * p, FILE_T out, int phase)
 804  {
 805    NODE_T *if_part = NO_NODE, *then_part = NO_NODE, *else_part = NO_NODE;
 806    p = SUB (p);
 807    if (IS (p, IF_PART) || IS (p, OPEN_PART)) {
 808      if_part = p;
 809    } else {
 810      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 811    }
 812    FORWARD (p);
 813    if (IS (p, THEN_PART) || IS (p, CHOICE)) {
 814      then_part = p;
 815    } else {
 816      ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 817    }
 818    FORWARD (p);
 819    if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
 820      else_part = p;
 821    } else {
 822      else_part = NO_NODE;
 823    }
 824    if (phase == L_DECLARE) {
 825      inline_unit (SUB (NEXT_SUB (if_part)), out, L_DECLARE);
 826      inline_unit (SUB (NEXT_SUB (then_part)), out, L_DECLARE);
 827      inline_unit (SUB (NEXT_SUB (else_part)), out, L_DECLARE);
 828    } else if (phase == L_EXECUTE) {
 829      inline_unit (SUB (NEXT_SUB (if_part)), out, L_EXECUTE);
 830      inline_unit (SUB (NEXT_SUB (then_part)), out, L_EXECUTE);
 831      inline_unit (SUB (NEXT_SUB (else_part)), out, L_EXECUTE);
 832    } else if (phase == L_YIELD) {
 833      undent (out, "(");
 834      inline_unit (SUB (NEXT_SUB (if_part)), out, L_YIELD);
 835      undent (out, " ? ");
 836      inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD);
 837      undent (out, " : ");
 838      if (else_part != NO_NODE) {
 839        inline_unit (SUB (NEXT_SUB (else_part)), out, L_YIELD);
 840      } else {
 841  // This is not an ideal solution although RR permits it;
 842  // an omitted else-part means SKIP: yield some value of the
 843  // mode required.
 844        inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD);
 845      }
 846      undent (out, ")");
 847    }
 848  }
 849  
 850  //! @brief Code dereferencing of selection.
 851  
 852  void inline_dereference_selection (NODE_T * p, FILE_T out, int phase)
 853  {
 854    NODE_T *field = SUB (p);
 855    NODE_T *sec = NEXT (field);
 856    NODE_T *idf = stems_from (sec, IDENTIFIER);
 857    char ref[NAME_SIZE], sel[NAME_SIZE];
 858    char *field_idf = NSYMBOL (SUB (field));
 859    if (phase == L_DECLARE) {
 860      BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
 861      if (entry == NO_BOOK) {
 862        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
 863        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, ref);
 864        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
 865      }
 866      if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
 867        (void) make_name (sel, SEL, "", NUMBER (field));
 868        (void) add_declaration (&A68_OPT (root_idf), inline_mode (SUB_MOID (field)), 1, sel);
 869        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 870      }
 871      inline_unit (sec, out, L_DECLARE);
 872    } else if (phase == L_EXECUTE) {
 873      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
 874      if (entry == NO_BOOK) {
 875        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
 876        get_stack (idf, out, ref, "A68_REF");
 877        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), NULL, NUMBER (field));
 878      }
 879      if (entry == NO_BOOK) {
 880        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
 881        (void) make_name (sel, SEL, "", NUMBER (field));
 882        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[" A68_LU "]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field)));
 883        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 884      } else if (field_idf != (char *) (INFO (entry))) {
 885        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
 886        (void) make_name (sel, SEL, "", NUMBER (field));
 887        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[" A68_LU "]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field)));
 888        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 889      }
 890      inline_unit (sec, out, L_EXECUTE);
 891    } else if (phase == L_YIELD) {
 892      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
 893      if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
 894        (void) make_name (sel, SEL, "", NUMBER (entry));
 895      } else {
 896        (void) make_name (sel, SEL, "", NUMBER (field));
 897      }
 898      if (primitive_mode (SUB_MOID (p))) {
 899        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", sel));
 900      } else if (SUB_MOID (p) == M_COMPLEX) {
 901        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", sel));
 902      } else if (basic_mode (SUB_MOID (p))) {
 903        undent (out, sel);
 904      } else {
 905        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 906      }
 907    }
 908  }
 909  
 910  //! @brief Code selection.
 911  
 912  void inline_selection (NODE_T * p, FILE_T out, int phase)
 913  {
 914    NODE_T *field = SUB (p);
 915    NODE_T *sec = NEXT (field);
 916    NODE_T *idf = stems_from (sec, IDENTIFIER);
 917    char ref[NAME_SIZE], sel[NAME_SIZE];
 918    char *field_idf = NSYMBOL (SUB (field));
 919    if (phase == L_DECLARE) {
 920      BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
 921      if (entry == NO_BOOK) {
 922        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
 923        (void) add_declaration (&A68_OPT (root_idf), "A68_STRUCT", 0, ref);
 924        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
 925      }
 926      if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
 927        (void) make_name (sel, SEL, "", NUMBER (field));
 928        (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (field)), 1, sel);
 929        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 930      }
 931      inline_unit (sec, out, L_DECLARE);
 932    } else if (phase == L_EXECUTE) {
 933      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
 934      if (entry == NO_BOOK) {
 935        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
 936        get_stack (idf, out, ref, "BYTE_T");
 937        (void) make_name (sel, SEL, "", NUMBER (field));
 938        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (%s[" A68_LU "]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field)));
 939        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 940      } else if (field_idf != (char *) (INFO (entry))) {
 941        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
 942        (void) make_name (sel, SEL, "", NUMBER (field));
 943        indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (%s[" A68_LU "]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field)));
 944        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 945      }
 946      inline_unit (sec, out, L_EXECUTE);
 947    } else if (phase == L_YIELD) {
 948      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
 949      if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
 950        (void) make_name (sel, SEL, "", NUMBER (entry));
 951      } else {
 952        (void) make_name (sel, SEL, "", NUMBER (field));
 953      }
 954      if (primitive_mode (MOID (p))) {
 955        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", sel));
 956      } else {
 957        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 958      }
 959    }
 960  }
 961  
 962  //! @brief Code selection.
 963  
 964  void inline_selection_ref_to_ref (NODE_T * p, FILE_T out, int phase)
 965  {
 966    NODE_T *field = SUB (p);
 967    NODE_T *sec = NEXT (field);
 968    NODE_T *idf = stems_from (sec, IDENTIFIER);
 969    char ref[NAME_SIZE], sel[NAME_SIZE];
 970    char *field_idf = NSYMBOL (SUB (field));
 971    if (phase == L_DECLARE) {
 972      BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
 973      if (entry == NO_BOOK) {
 974        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
 975        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, ref);
 976        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
 977      }
 978      if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
 979        (void) make_name (sel, SEL, "", NUMBER (field));
 980        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, sel);
 981        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 982      }
 983      inline_unit (sec, out, L_DECLARE);
 984    } else if (phase == L_EXECUTE) {
 985      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf));
 986      if (entry == NO_BOOK) {
 987        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
 988        get_stack (idf, out, ref, "A68_REF");
 989        (void) make_name (sel, SEL, "", NUMBER (field));
 990        sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 991      } else if (field_idf != (char *) (INFO (entry))) {
 992        (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
 993        (void) make_name (sel, SEL, "", NUMBER (field));
 994        sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
 995      }
 996      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s = *%s;\n", sel, ref));
 997      indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (&%s) += " A68_LU ";\n", sel, OFFSET_OFF (field)));
 998      inline_unit (sec, out, L_EXECUTE);
 999    } else if (phase == L_YIELD) {
1000      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
1001      if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
1002        (void) make_name (sel, SEL, "", NUMBER (entry));
1003      } else {
1004        (void) make_name (sel, SEL, "", NUMBER (field));
1005      }
1006      if (primitive_mode (SUB_MOID (p))) {
1007        undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(&%s)", sel));
1008      } else {
1009        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1010      }
1011    }
1012  }
1013  
1014  //! @brief Code identifier.
1015  
1016  void inline_ref_identifier (NODE_T * p, FILE_T out, int phase)
1017  {
1018  // No folding - consider identifier.
1019    if (phase == L_DECLARE) {
1020      if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) {
1021        return;
1022      } else {
1023        char idf[NAME_SIZE];
1024        (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
1025        (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, idf);
1026        sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
1027      }
1028    } else if (phase == L_EXECUTE) {
1029      if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) {
1030        return;
1031      } else {
1032        char idf[NAME_SIZE];
1033        (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
1034        get_stack (p, out, idf, "A68_REF");
1035        sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
1036      }
1037    } else if (phase == L_YIELD) {
1038      char idf[NAME_SIZE];
1039      BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p));
1040      if (entry != NO_BOOK) {
1041        (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry));
1042      } else {
1043        (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
1044      }
1045      undent (out, idf);
1046    }
1047  }
1048  
1049  //! @brief Code identity-relation.
1050  
1051  void inline_identity_relation (NODE_T * p, FILE_T out, int phase)
1052  {
1053  #define GOOD(p) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((p), IDENTIFIER)), REF_SYMBOL))
1054    NODE_T *lhs = SUB (p);
1055    NODE_T *op = NEXT (lhs);
1056    NODE_T *rhs = NEXT (op);
1057    if (GOOD (lhs) && GOOD (rhs)) {
1058      if (phase == L_DECLARE) {
1059        NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1060        NODE_T *ridf = stems_from (rhs, IDENTIFIER);
1061        inline_ref_identifier (lidf, out, L_DECLARE);
1062        inline_ref_identifier (ridf, out, L_DECLARE);
1063      } else if (phase == L_EXECUTE) {
1064        NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1065        NODE_T *ridf = stems_from (rhs, IDENTIFIER);
1066        inline_ref_identifier (lidf, out, L_EXECUTE);
1067        inline_ref_identifier (ridf, out, L_EXECUTE);
1068      } else if (phase == L_YIELD) {
1069        NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1070        NODE_T *ridf = stems_from (rhs, IDENTIFIER);
1071        if (IS (op, IS_SYMBOL)) {
1072          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "ADDRESS ("));
1073          inline_ref_identifier (lidf, out, L_YIELD);
1074          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ") == ADDRESS ("));
1075          inline_ref_identifier (ridf, out, L_YIELD);
1076          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ")"));
1077        } else {
1078          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "ADDRESS ("));
1079          inline_ref_identifier (lidf, out, L_YIELD);
1080          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ") != ADDRESS ("));
1081          inline_ref_identifier (ridf, out, L_YIELD);
1082          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ")"));
1083        }
1084      }
1085    } else if (GOOD (lhs) && stems_from (rhs, NIHIL) != NO_NODE) {
1086      if (phase == L_DECLARE) {
1087        NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1088        inline_ref_identifier (lidf, out, L_DECLARE);
1089      } else if (phase == L_EXECUTE) {
1090        NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1091        inline_ref_identifier (lidf, out, L_EXECUTE);
1092      } else if (phase == L_YIELD) {
1093        NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1094        if (IS (op, IS_SYMBOL)) {
1095          indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "IS_NIL (*"));
1096          inline_ref_identifier (lidf, out, L_YIELD);
1097          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ")"));
1098        } else {
1099          indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "!IS_NIL (*"));
1100          inline_ref_identifier (lidf, out, L_YIELD);
1101          undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ")"));
1102        }
1103      }
1104    }
1105  #undef GOOD
1106  }
1107  
1108  //! @brief Code unit.
1109  
1110  void inline_unit (NODE_T * p, FILE_T out, int phase)
1111  {
1112    if (p == NO_NODE) {
1113      return;
1114    } else if (constant_unit (p) && stems_from (p, DENOTATION) == NO_NODE) {
1115      constant_folder (p, out, phase);
1116    } else if (IS (p, UNIT)) {
1117      inline_unit (SUB (p), out, phase);
1118    } else if (IS (p, TERTIARY)) {
1119      inline_unit (SUB (p), out, phase);
1120    } else if (IS (p, SECONDARY)) {
1121      inline_unit (SUB (p), out, phase);
1122    } else if (IS (p, PRIMARY)) {
1123      inline_unit (SUB (p), out, phase);
1124    } else if (IS (p, ENCLOSED_CLAUSE)) {
1125      inline_unit (SUB (p), out, phase);
1126    } else if (IS (p, CLOSED_CLAUSE)) {
1127      inline_closed (p, out, phase);
1128    } else if (IS (p, COLLATERAL_CLAUSE)) {
1129      inline_collateral (p, out, phase);
1130    } else if (IS (p, CONDITIONAL_CLAUSE)) {
1131      inline_conditional (p, out, phase);
1132    } else if (IS (p, WIDENING)) {
1133      inline_widening (p, out, phase);
1134    } else if (IS (p, IDENTIFIER)) {
1135      inline_identifier (p, out, phase);
1136    } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER) != NO_NODE) {
1137      inline_dereference_identifier (p, out, phase);
1138    } else if (IS (p, SLICE)) {
1139      NODE_T *prim = SUB (p);
1140      MOID_T *mode = MOID (p);
1141      MOID_T *row_mode = DEFLEX (MOID (prim));
1142      if (mode == SUB (row_mode)) {
1143        inline_slice (p, out, phase);
1144      } else if (IS (mode, REF_SYMBOL) && IS (row_mode, REF_SYMBOL) && SUB (mode) == SUB_SUB (row_mode)) {
1145        inline_slice_ref_to_ref (p, out, phase);
1146      } else {
1147        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1148      }
1149    } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SLICE) != NO_NODE) {
1150      inline_dereference_slice (SUB (p), out, phase);
1151    } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SELECTION) != NO_NODE) {
1152      inline_dereference_selection (SUB (p), out, phase);
1153    } else if (IS (p, SELECTION)) {
1154      NODE_T *sec = NEXT_SUB (p);
1155      MOID_T *mode = MOID (p);
1156      MOID_T *struct_mode = MOID (sec);
1157      if (IS (struct_mode, REF_SYMBOL) && IS (mode, REF_SYMBOL)) {
1158        inline_selection_ref_to_ref (p, out, phase);
1159      } else if (IS (struct_mode, STRUCT_SYMBOL) && primitive_mode (mode)) {
1160        inline_selection (p, out, phase);
1161      } else {
1162        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1163      }
1164    } else if (IS (p, DENOTATION)) {
1165      inline_denotation (p, out, phase);
1166    } else if (IS (p, MONADIC_FORMULA)) {
1167      inline_monadic_formula (p, out, phase);
1168    } else if (IS (p, FORMULA)) {
1169      inline_formula (p, out, phase);
1170    } else if (IS (p, CALL)) {
1171      inline_call (p, out, phase);
1172    } else if (IS (p, CAST)) {
1173      inline_unit (NEXT_SUB (p), out, phase);
1174    } else if (IS (p, IDENTITY_RELATION)) {
1175      inline_identity_relation (p, out, phase);
1176    }
1177  }
1178