genie.c

     
   1  //! @file genie.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  //! Interpreter driver.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-frames.h"
  29  #include "a68g-prelude.h"
  30  #include "a68g-mp.h"
  31  #include "a68g-double.h"
  32  #include "a68g-parser.h"
  33  #include "a68g-transput.h"
  34  
  35  //! @brief Nop for the genie, for instance '+' for INT or REAL.
  36  
  37  void genie_idle (NODE_T * p)
  38  {
  39    (void) p;
  40  }
  41  
  42  //! @brief Unimplemented feature handler.
  43  
  44  void genie_unimplemented (NODE_T * p)
  45  {
  46    diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNIMPLEMENTED);
  47    exit_genie (p, A68_RUNTIME_ERROR);
  48  }
  49  
  50  //! @brief PROC sleep = (INT) INT
  51  
  52  void genie_sleep (NODE_T * p)
  53  {
  54    A68_INT secs;
  55    int wait;
  56    POP_OBJECT (p, &secs, A68_INT);
  57    wait = VALUE (&secs);
  58    PRELUDE_ERROR (wait < 0, p, ERROR_INVALID_ARGUMENT, M_INT);
  59    while (wait > 0) {
  60      wait = (int) sleep ((unt) wait);
  61    }
  62    PUSH_VALUE (p, (INT_T) 0, A68_INT);
  63  }
  64  
  65  //! @brief PROC system = (STRING) INT
  66  
  67  void genie_system (NODE_T * p)
  68  {
  69    int sys_ret_code, size;
  70    A68_REF cmd;
  71    A68_REF ref_z;
  72    POP_REF (p, &cmd);
  73    CHECK_INIT (p, INITIALISED (&cmd), M_STRING);
  74    size = 1 + a68_string_size (p, cmd);
  75    ref_z = heap_generator (p, M_C_STRING, 1 + size);
  76    sys_ret_code = system (a_to_c_string (p, DEREF (char, &ref_z), cmd));
  77    PUSH_VALUE (p, sys_ret_code, A68_INT);
  78  }
  79  
  80  //! @brief Set flags throughout tree.
  81  
  82  void change_masks (NODE_T * p, unt mask, BOOL_T set)
  83  {
  84    for (; p != NO_NODE; FORWARD (p)) {
  85      change_masks (SUB (p), mask, set);
  86      if (LINE_NUMBER (p) > 0) {
  87        if (set == A68_TRUE) {
  88          STATUS_SET (p, mask);
  89        } else {
  90          STATUS_CLEAR (p, mask);
  91        }
  92      }
  93    }
  94  }
  95  
  96  //! @brief Leave interpretation.
  97  
  98  void exit_genie (NODE_T * p, int ret)
  99  {
 100  #if defined (HAVE_CURSES)
 101    genie_curses_end (p);
 102  #endif
 103    A68 (close_tty_on_exit) = A68_TRUE;
 104    if (!A68 (in_execution)) {
 105      return;
 106    }
 107    if (ret == A68_RUNTIME_ERROR && A68 (in_monitor)) {
 108      return;
 109    } else if (ret == A68_RUNTIME_ERROR && OPTION_DEBUG (&A68_JOB)) {
 110      diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR);
 111      single_step (p, (unt) BREAKPOINT_ERROR_MASK);
 112      A68 (in_execution) = A68_FALSE;
 113      A68 (ret_line_number) = LINE_NUMBER (p);
 114      A68 (ret_code) = ret;
 115      longjmp (A68 (genie_exit_label), 1);
 116    } else {
 117      if ((ret & A68_FORCE_QUIT) != NULL_MASK) {
 118        ret &= ~A68_FORCE_QUIT;
 119      }
 120  #if defined (BUILD_PARALLEL_CLAUSE)
 121      if (!is_main_thread ()) {
 122        genie_set_exit_from_threads (ret);
 123      } else {
 124        A68 (in_execution) = A68_FALSE;
 125        A68 (ret_line_number) = LINE_NUMBER (p);
 126        A68 (ret_code) = ret;
 127        longjmp (A68 (genie_exit_label), 1);
 128      }
 129  #else
 130      A68 (in_execution) = A68_FALSE;
 131      A68 (ret_line_number) = LINE_NUMBER (p);
 132      A68 (ret_code) = ret;
 133      longjmp (A68 (genie_exit_label), 1);
 134  #endif
 135    }
 136  }
 137  
 138  //! @brief Genie init rng.
 139  
 140  void genie_init_rng (void)
 141  {
 142    time_t t;
 143    if (time (&t) != -1) {
 144      init_rng ((unt) t);
 145    }
 146  }
 147  
 148  //! @brief Tie label to the clause it is defined in.
 149  
 150  void tie_label_to_serial (NODE_T * p)
 151  {
 152    for (; p != NO_NODE; FORWARD (p)) {
 153      if (IS (p, SERIAL_CLAUSE)) {
 154        BOOL_T valid_follow;
 155        if (NEXT (p) == NO_NODE) {
 156          valid_follow = A68_TRUE;
 157        } else if (IS (NEXT (p), CLOSE_SYMBOL)) {
 158          valid_follow = A68_TRUE;
 159        } else if (IS (NEXT (p), END_SYMBOL)) {
 160          valid_follow = A68_TRUE;
 161        } else if (IS (NEXT (p), EDOC_SYMBOL)) {
 162          valid_follow = A68_TRUE;
 163        } else if (IS (NEXT (p), OD_SYMBOL)) {
 164          valid_follow = A68_TRUE;
 165        } else {
 166          valid_follow = A68_FALSE;
 167        }
 168        if (valid_follow) {
 169          JUMP_TO (TABLE (SUB (p))) = NO_NODE;
 170        }
 171      }
 172      tie_label_to_serial (SUB (p));
 173    }
 174  }
 175  
 176  //! @brief Tie label to the clause it is defined in.
 177  
 178  void tie_label (NODE_T * p, NODE_T * unit)
 179  {
 180    for (; p != NO_NODE; FORWARD (p)) {
 181      if (IS (p, DEFINING_IDENTIFIER)) {
 182        UNIT (TAX (p)) = unit;
 183      }
 184      tie_label (SUB (p), unit);
 185    }
 186  }
 187  
 188  //! @brief Tie label to the clause it is defined in.
 189  
 190  void tie_label_to_unit (NODE_T * p)
 191  {
 192    for (; p != NO_NODE; FORWARD (p)) {
 193      if (IS (p, LABELED_UNIT)) {
 194        tie_label (SUB_SUB (p), NEXT_SUB (p));
 195      }
 196      tie_label_to_unit (SUB (p));
 197    }
 198  }
 199  
 200  //! @brief Fast way to indicate a mode.
 201  
 202  int mode_attribute (MOID_T * p)
 203  {
 204    if (IS_REF (p)) {
 205      return REF_SYMBOL;
 206    } else if (IS (p, PROC_SYMBOL)) {
 207      return PROC_SYMBOL;
 208    } else if (IS_UNION (p)) {
 209      return UNION_SYMBOL;
 210    } else if (p == M_INT) {
 211      return MODE_INT;
 212    } else if (p == M_LONG_INT) {
 213      return MODE_LONG_INT;
 214    } else if (p == M_LONG_LONG_INT) {
 215      return MODE_LONG_LONG_INT;
 216    } else if (p == M_REAL) {
 217      return MODE_REAL;
 218    } else if (p == M_LONG_REAL) {
 219      return MODE_LONG_REAL;
 220    } else if (p == M_LONG_LONG_REAL) {
 221      return MODE_LONG_LONG_REAL;
 222    } else if (p == M_COMPLEX) {
 223      return MODE_COMPLEX;
 224    } else if (p == M_LONG_COMPLEX) {
 225      return MODE_LONG_COMPLEX;
 226    } else if (p == M_LONG_LONG_COMPLEX) {
 227      return MODE_LONG_LONG_COMPLEX;
 228    } else if (p == M_BOOL) {
 229      return MODE_BOOL;
 230    } else if (p == M_CHAR) {
 231      return MODE_CHAR;
 232    } else if (p == M_BITS) {
 233      return MODE_BITS;
 234    } else if (p == M_LONG_BITS) {
 235      return MODE_LONG_BITS;
 236    } else if (p == M_LONG_LONG_BITS) {
 237      return MODE_LONG_LONG_BITS;
 238    } else if (p == M_BYTES) {
 239      return MODE_BYTES;
 240    } else if (p == M_LONG_BYTES) {
 241      return MODE_LONG_BYTES;
 242    } else if (p == M_FILE) {
 243      return MODE_FILE;
 244    } else if (p == M_FORMAT) {
 245      return MODE_FORMAT;
 246    } else if (p == M_PIPE) {
 247      return MODE_PIPE;
 248    } else if (p == M_SOUND) {
 249      return MODE_SOUND;
 250    } else {
 251      return MODE_NO_CHECK;
 252    }
 253  }
 254  
 255  //! @brief Perform tasks before interpretation.
 256  
 257  void genie_preprocess (NODE_T * p, int *max_lev, void *compile_plugin)
 258  {
 259  #if defined (BUILD_A68_COMPILER)
 260    static char *last_compile_name = NO_TEXT;
 261    static PROP_PROC *last_compile_unit = NO_PPROC;
 262  #endif
 263    for (; p != NO_NODE; FORWARD (p)) {
 264      if (STATUS_TEST (p, BREAKPOINT_MASK)) {
 265        if (!(STATUS_TEST (p, INTERRUPTIBLE_MASK))) {
 266          STATUS_CLEAR (p, BREAKPOINT_MASK);
 267        }
 268      }
 269      if (GINFO (p) != NO_GINFO) {
 270        IS_COERCION (GINFO (p)) = is_coercion (p);
 271        IS_NEW_LEXICAL_LEVEL (GINFO (p)) = is_new_lexical_level (p);
 272  // The default.
 273        UNIT (&GPROP (p)) = genie_unit;
 274        SOURCE (&GPROP (p)) = p;
 275  #if defined (BUILD_A68_COMPILER)
 276        if (OPTION_OPT_LEVEL (&A68_JOB) > 0 && COMPILE_NAME (GINFO (p)) != NO_TEXT && compile_plugin != NULL) {
 277          if (COMPILE_NAME (GINFO (p)) == last_compile_name) {
 278  // We copy.
 279            UNIT (&GPROP (p)) = last_compile_unit;
 280          } else {
 281  // We look up.
 282  // Next line may provoke a warning even with this POSIX workaround. Tant pis.
 283            *(void **) &(UNIT (&GPROP (p))) = dlsym (compile_plugin, COMPILE_NAME (GINFO (p)));
 284            ABEND (UNIT (&GPROP (p)) == NULL, ERROR_INTERNAL_CONSISTENCY, dlerror ());
 285            last_compile_name = COMPILE_NAME (GINFO (p));
 286            last_compile_unit = UNIT (&GPROP (p));
 287          }
 288        }
 289  #endif
 290      }
 291      if (MOID (p) != NO_MOID) {
 292        SIZE (MOID (p)) = moid_size (MOID (p));
 293        DIGITS (MOID (p)) = moid_digits (MOID (p));
 294        SHORT_ID (MOID (p)) = mode_attribute (MOID (p));
 295        if (GINFO (p) != NO_GINFO) {
 296          NEED_DNS (GINFO (p)) = A68_FALSE;
 297          if (IS_REF (MOID (p))) {
 298            NEED_DNS (GINFO (p)) = A68_TRUE;
 299          } else if (IS (MOID (p), PROC_SYMBOL)) {
 300            NEED_DNS (GINFO (p)) = A68_TRUE;
 301          } else if (IS (MOID (p), FORMAT_SYMBOL)) {
 302            NEED_DNS (GINFO (p)) = A68_TRUE;
 303          }
 304        }
 305      }
 306      if (TABLE (p) != NO_TABLE) {
 307        if (LEX_LEVEL (p) > *max_lev) {
 308          *max_lev = LEX_LEVEL (p);
 309        }
 310      }
 311      if (IS (p, FORMAT_TEXT)) {
 312        TAG_T *q = TAX (p);
 313        if (q != NO_TAG && NODE (q) != NO_NODE) {
 314          NODE (q) = p;
 315        }
 316      } else if (IS (p, DEFINING_IDENTIFIER)) {
 317        TAG_T *q = TAX (p);
 318        if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
 319          LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
 320        }
 321      } else if (IS (p, IDENTIFIER)) {
 322        TAG_T *q = TAX (p);
 323        if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
 324          LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
 325          OFFSET (GINFO (p)) = &(A68_STACK[FRAME_INFO_SIZE + OFFSET (q)]);
 326        }
 327      } else if (IS (p, OPERATOR)) {
 328        TAG_T *q = TAX (p);
 329        if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
 330          LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
 331          OFFSET (GINFO (p)) = &(A68_STACK[FRAME_INFO_SIZE + OFFSET (q)]);
 332        }
 333      }
 334      if (SUB (p) != NO_NODE) {
 335        if (GINFO (p) != NO_GINFO) {
 336          GPARENT (SUB (p)) = p;
 337        }
 338        genie_preprocess (SUB (p), max_lev, compile_plugin);
 339      }
 340    }
 341  }
 342  
 343  //! @brief Get outermost lexical level in the user program.
 344  
 345  void get_global_level (NODE_T * p)
 346  {
 347    for (; p != NO_NODE; FORWARD (p)) {
 348      if (LINE_NUMBER (p) != 0 && IS (p, UNIT)) {
 349        if (LEX_LEVEL (p) < A68 (global_level)) {
 350          A68 (global_level) = LEX_LEVEL (p);
 351        }
 352      }
 353      get_global_level (SUB (p));
 354    }
 355  }
 356  
 357  //! @brief Driver for the interpreter.
 358  
 359  void genie (void *compile_plugin)
 360  {
 361    MOID_T *m;
 362  // Fill in final info for modes.
 363    for (m = TOP_MOID (&A68_JOB); m != NO_MOID; FORWARD (m)) {
 364      SIZE (m) = moid_size (m);
 365      DIGITS (m) = moid_digits (m);
 366      SHORT_ID (m) = mode_attribute (m);
 367    }
 368  // Preprocessing.
 369    A68 (max_lex_lvl) = 0;
 370  //  genie_lex_levels (TOP_NODE (&A68_JOB), 1);.
 371    genie_preprocess (TOP_NODE (&A68_JOB), &A68 (max_lex_lvl), compile_plugin);
 372    change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE);
 373    A68_MON (watchpoint_expression) = NO_TEXT;
 374    A68 (frame_stack_limit) = A68 (frame_end) - A68 (storage_overhead);
 375    A68 (expr_stack_limit) = A68 (stack_end) - A68 (storage_overhead);
 376    if (OPTION_REGRESSION_TEST (&A68_JOB)) {
 377      init_rng (1);
 378    } else {
 379      genie_init_rng ();
 380    }
 381    io_close_tty_line ();
 382    if (OPTION_TRACE (&A68_JOB)) {
 383      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "genie: frame stack %uk, expression stack %uk, heap %uk, handles %uk\n", A68 (frame_stack_size) / KILOBYTE, A68 (expr_stack_size) / KILOBYTE, A68 (heap_size) / KILOBYTE, A68 (handle_pool_size) / KILOBYTE) >= 0);
 384      WRITE (STDOUT_FILENO, A68 (output_line));
 385    }
 386    install_signal_handlers ();
 387    set_default_event_procedure (&A68 (on_gc_event));
 388    A68 (do_confirm_exit) = A68_TRUE;
 389  #if defined (BUILD_PARALLEL_CLAUSE)
 390    ASSERT (pthread_mutex_init (&A68_PAR (unit_sema), NULL) == 0);
 391  #endif
 392  // Dive into the program.
 393    if (setjmp (A68 (genie_exit_label)) == 0) {
 394      NODE_T *p = SUB (TOP_NODE (&A68_JOB));
 395  // If we are to stop in the monitor, set a breakpoint on the first unit.
 396      if (OPTION_DEBUG (&A68_JOB)) {
 397        change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
 398        WRITE (STDOUT_FILENO, "Execution begins ...");
 399      }
 400      errno = 0;
 401      A68 (ret_code) = 0;
 402      A68 (global_level) = INT_MAX;
 403      A68_GLOBALS = 0;
 404      get_global_level (p);
 405      A68_FP = A68 (frame_start);
 406      A68_SP = A68 (stack_start);
 407      FRAME_DYNAMIC_LINK (A68_FP) = 0;
 408      FRAME_DNS (A68_FP) = 0;
 409      FRAME_STATIC_LINK (A68_FP) = 0;
 410      FRAME_NUMBER (A68_FP) = 0;
 411      FRAME_TREE (A68_FP) = (NODE_T *) p;
 412      FRAME_LEXICAL_LEVEL (A68_FP) = LEX_LEVEL (p);
 413      FRAME_PARAMETER_LEVEL (A68_FP) = LEX_LEVEL (p);
 414      FRAME_PARAMETERS (A68_FP) = A68_FP;
 415      initialise_frame (p);
 416      genie_init_heap (p);
 417      genie_init_transput (TOP_NODE (&A68_JOB));
 418      A68 (cputime_0) = seconds ();
 419  // Here we go ...
 420      A68 (in_execution) = A68_TRUE;
 421      A68 (f_entry) = TOP_NODE (&A68_JOB);
 422  #if defined (BUILD_UNIX)
 423      (void) alarm (1);
 424  #endif
 425      if (OPTION_TRACE (&A68_JOB)) {
 426        WIS (TOP_NODE (&A68_JOB));
 427      }
 428      (void) genie_enclosed (TOP_NODE (&A68_JOB));
 429    } else {
 430  // Here we have jumped out of the interpreter. What happened?.
 431      if (OPTION_DEBUG (&A68_JOB)) {
 432        WRITE (STDOUT_FILENO, "Execution discontinued");
 433      }
 434      if (A68 (ret_code) == A68_RERUN) {
 435        diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR);
 436        genie (compile_plugin);
 437      } else if (A68 (ret_code) == A68_RUNTIME_ERROR) {
 438        if (OPTION_BACKTRACE (&A68_JOB)) {
 439          int printed = 0;
 440          ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0);
 441          WRITE (STDOUT_FILENO, A68 (output_line));
 442          stack_dump (STDOUT_FILENO, A68_FP, 16, &printed);
 443          WRITE (STDOUT_FILENO, NEWLINE_STRING);
 444        }
 445        if (FILE_LISTING_OPENED (&A68_JOB)) {
 446          int printed = 0;
 447          ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0);
 448          WRITE (FILE_LISTING_FD (&A68_JOB), A68 (output_line));
 449          stack_dump (FILE_LISTING_FD (&A68_JOB), A68_FP, 32, &printed);
 450        }
 451      }
 452    }
 453    A68 (in_execution) = A68_FALSE;
 454  }
 455  
 456  // This file contains interpreter ("genie") routines related to executing primitive
 457  // A68 actions.
 458  // 
 459  // The genie is self-optimising as when it traverses the tree, it stores terminals
 460  // it ends up in at the root where traversing for that terminal started.
 461  // Such piece of information is called a PROP.
 462  
 463  //! @brief Shows line where 'p' is at and draws a '-' beneath the position.
 464  
 465  void where_in_source (FILE_T f, NODE_T * p)
 466  {
 467    write_source_line (f, LINE (INFO (p)), p, A68_NO_DIAGNOSTICS);
 468  }
 469  
 470  // Since Algol 68 can pass procedures as parameters, we use static links rather
 471  // than a display.
 472  
 473  //! @brief Initialise PROC and OP identities.
 474  
 475  void genie_init_proc_op (NODE_T * p, NODE_T ** seq, int *count)
 476  {
 477    for (; p != NO_NODE; FORWARD (p)) {
 478      switch (ATTRIBUTE (p)) {
 479      case OP_SYMBOL:
 480      case PROC_SYMBOL:
 481      case OPERATOR_PLAN:
 482      case DECLARER:
 483        {
 484          break;
 485        }
 486      case DEFINING_IDENTIFIER:
 487      case DEFINING_OPERATOR:
 488        {
 489  // Store position so we need not search again.
 490          NODE_T *save = *seq;
 491          (*seq) = p;
 492          SEQUENCE (*seq) = save;
 493          (*count)++;
 494          return;
 495        }
 496      default:
 497        {
 498          genie_init_proc_op (SUB (p), seq, count);
 499          break;
 500        }
 501      }
 502    }
 503  }
 504  
 505  //! @brief Initialise PROC and OP identity declarations.
 506  
 507  void genie_find_proc_op (NODE_T * p, int *count)
 508  {
 509    for (; p != NO_NODE; FORWARD (p)) {
 510      if (GINFO (p) != NO_GINFO && IS_NEW_LEXICAL_LEVEL (GINFO (p))) {
 511  // Don't enter a new lexical level - it will have its own initialisation.
 512        return;
 513      } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) {
 514        genie_init_proc_op (SUB (p), &(SEQUENCE (TABLE (p))), count);
 515        return;
 516      } else {
 517        genie_find_proc_op (SUB (p), count);
 518      }
 519    }
 520  }
 521  
 522  //! @brief Initialise stack frame.
 523  
 524  void initialise_frame (NODE_T * p)
 525  {
 526    if (INITIALISE_ANON (TABLE (p))) {
 527      TAG_T *_a_;
 528      INITIALISE_ANON (TABLE (p)) = A68_FALSE;
 529      for (_a_ = ANONYMOUS (TABLE (p)); _a_ != NO_TAG; FORWARD (_a_)) {
 530        if (PRIO (_a_) == ROUTINE_TEXT) {
 531          int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_)));
 532          A68_PROCEDURE *_z_ = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (_a_)));
 533          STATUS (_z_) = INIT_MASK;
 534          NODE (&(BODY (_z_))) = NODE (_a_);
 535          if (youngest > 0) {
 536            STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest);
 537          } else {
 538            ENVIRON (_z_) = 0;
 539          }
 540          LOCALE (_z_) = NO_HANDLE;
 541          MOID (_z_) = MOID (_a_);
 542          INITIALISE_ANON (TABLE (p)) = A68_TRUE;
 543        } else if (PRIO (_a_) == FORMAT_TEXT) {
 544          int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_)));
 545          A68_FORMAT *_z_ = (A68_FORMAT *) (FRAME_OBJECT (OFFSET (_a_)));
 546          STATUS (_z_) = INIT_MASK;
 547          BODY (_z_) = NODE (_a_);
 548          if (youngest > 0) {
 549            STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest);
 550          } else {
 551            ENVIRON (_z_) = 0;
 552          }
 553          INITIALISE_ANON (TABLE (p)) = A68_TRUE;
 554        }
 555      }
 556    }
 557    if (PROC_OPS (TABLE (p))) {
 558      NODE_T *_q_;
 559      if (SEQUENCE (TABLE (p)) == NO_NODE) {
 560        int count = 0;
 561        genie_find_proc_op (p, &count);
 562        PROC_OPS (TABLE (p)) = (BOOL_T) (count > 0);
 563      }
 564      for (_q_ = SEQUENCE (TABLE (p)); _q_ != NO_NODE; _q_ = SEQUENCE (_q_)) {
 565        NODE_T *u = NEXT_NEXT (_q_);
 566        if (IS (u, ROUTINE_TEXT)) {
 567          NODE_T *src = SOURCE (&(GPROP (u)));
 568          *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src))));
 569        } else if ((IS (u, UNIT) && IS (SUB (u), ROUTINE_TEXT))) {
 570          NODE_T *src = SOURCE (&(GPROP (SUB (u))));
 571          *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src))));
 572        }
 573      }
 574    }
 575    INITIALISE_FRAME (TABLE (p)) = (BOOL_T) (INITIALISE_ANON (TABLE (p)) || PROC_OPS (TABLE (p)));
 576  }
 577  
 578  //! @brief Whether item at "w" of mode "q" is initialised.
 579  
 580  void genie_check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q)
 581  {
 582    switch (SHORT_ID (q)) {
 583    case REF_SYMBOL:
 584      {
 585        A68_REF *z = (A68_REF *) w;
 586        CHECK_INIT (p, INITIALISED (z), q);
 587        return;
 588      }
 589    case PROC_SYMBOL:
 590      {
 591        A68_PROCEDURE *z = (A68_PROCEDURE *) w;
 592        CHECK_INIT (p, INITIALISED (z), q);
 593        return;
 594      }
 595    case MODE_INT:
 596      {
 597        A68_INT *z = (A68_INT *) w;
 598        CHECK_INIT (p, INITIALISED (z), q);
 599        return;
 600      }
 601    case MODE_REAL:
 602      {
 603        A68_REAL *z = (A68_REAL *) w;
 604        CHECK_INIT (p, INITIALISED (z), q);
 605        return;
 606      }
 607    case MODE_COMPLEX:
 608      {
 609        A68_REAL *r = (A68_REAL *) w;
 610        A68_REAL *i = (A68_REAL *) (w + SIZE_ALIGNED (A68_REAL));
 611        CHECK_INIT (p, INITIALISED (r), q);
 612        CHECK_INIT (p, INITIALISED (i), q);
 613        return;
 614      }
 615  #if (A68_LEVEL >= 3)
 616    case MODE_LONG_INT:
 617    case MODE_LONG_REAL:
 618    case MODE_LONG_BITS:
 619      {
 620        A68_DOUBLE *z = (A68_DOUBLE *) w;
 621        CHECK_INIT (p, INITIALISED (z), q);
 622        return;
 623      }
 624    case MODE_LONG_COMPLEX:
 625      {
 626        A68_LONG_REAL *r = (A68_LONG_REAL *) w;
 627        A68_LONG_REAL *i = (A68_LONG_REAL *) (w + SIZE_ALIGNED (A68_LONG_REAL));
 628        CHECK_INIT (p, INITIALISED (r), q);
 629        CHECK_INIT (p, INITIALISED (i), q);
 630        return;
 631      }
 632    case MODE_LONG_LONG_INT:
 633    case MODE_LONG_LONG_REAL:
 634    case MODE_LONG_LONG_BITS:
 635      {
 636        MP_T *z = (MP_T *) w;
 637        CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q);
 638        return;
 639      }
 640  #else
 641    case MODE_LONG_INT:
 642    case MODE_LONG_LONG_INT:
 643    case MODE_LONG_REAL:
 644    case MODE_LONG_LONG_REAL:
 645    case MODE_LONG_BITS:
 646    case MODE_LONG_LONG_BITS:
 647      {
 648        MP_T *z = (MP_T *) w;
 649        CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q);
 650        return;
 651      }
 652    case MODE_LONG_COMPLEX:
 653      {
 654        MP_T *r = (MP_T *) w;
 655        MP_T *i = (MP_T *) (w + size_mp ());
 656        CHECK_INIT (p, (unt) r[0] & INIT_MASK, q);
 657        CHECK_INIT (p, (unt) i[0] & INIT_MASK, q);
 658        return;
 659      }
 660  #endif
 661    case MODE_LONG_LONG_COMPLEX:
 662      {
 663        MP_T *r = (MP_T *) w;
 664        MP_T *i = (MP_T *) (w + size_long_mp ());
 665        CHECK_INIT (p, (unt) r[0] & INIT_MASK, q);
 666        CHECK_INIT (p, (unt) i[0] & INIT_MASK, q);
 667        return;
 668      }
 669    case MODE_BOOL:
 670      {
 671        A68_BOOL *z = (A68_BOOL *) w;
 672        CHECK_INIT (p, INITIALISED (z), q);
 673        return;
 674      }
 675    case MODE_CHAR:
 676      {
 677        A68_CHAR *z = (A68_CHAR *) w;
 678        CHECK_INIT (p, INITIALISED (z), q);
 679        return;
 680      }
 681    case MODE_BITS:
 682      {
 683        A68_BITS *z = (A68_BITS *) w;
 684        CHECK_INIT (p, INITIALISED (z), q);
 685        return;
 686      }
 687    case MODE_BYTES:
 688      {
 689        A68_BYTES *z = (A68_BYTES *) w;
 690        CHECK_INIT (p, INITIALISED (z), q);
 691        return;
 692      }
 693    case MODE_LONG_BYTES:
 694      {
 695        A68_LONG_BYTES *z = (A68_LONG_BYTES *) w;
 696        CHECK_INIT (p, INITIALISED (z), q);
 697        return;
 698      }
 699    case MODE_FILE:
 700      {
 701        A68_FILE *z = (A68_FILE *) w;
 702        CHECK_INIT (p, INITIALISED (z), q);
 703        return;
 704      }
 705    case MODE_FORMAT:
 706      {
 707        A68_FORMAT *z = (A68_FORMAT *) w;
 708        CHECK_INIT (p, INITIALISED (z), q);
 709        return;
 710      }
 711    case MODE_PIPE:
 712      {
 713        A68_REF *pipe_read = (A68_REF *) w;
 714        A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE);
 715        A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE);
 716        CHECK_INIT (p, INITIALISED (pipe_read), q);
 717        CHECK_INIT (p, INITIALISED (pipe_write), q);
 718        CHECK_INIT (p, INITIALISED (pid), q);
 719        return;
 720      }
 721    case MODE_SOUND:
 722      {
 723        A68_SOUND *z = (A68_SOUND *) w;
 724        CHECK_INIT (p, INITIALISED (z), q);
 725        return;
 726      }
 727    }
 728  }
 729  
 730  //! @brief Push constant stored in the tree.
 731  
 732  PROP_T genie_constant (NODE_T * p)
 733  {
 734    PUSH (p, CONSTANT (GINFO (p)), SIZE (GINFO (p)));
 735    return GPROP (p);
 736  }
 737  
 738  //! @brief Push argument units.
 739  
 740  void genie_argument (NODE_T * p, NODE_T ** seq)
 741  {
 742    for (; p != NO_NODE; FORWARD (p)) {
 743      if (IS (p, UNIT)) {
 744        EXECUTE_UNIT (p);
 745        STACK_DNS (p, MOID (p), A68_FP);
 746        SEQUENCE (*seq) = p;
 747        (*seq) = p;
 748        return;
 749      } else if (IS (p, TRIMMER)) {
 750        return;
 751      } else {
 752        genie_argument (SUB (p), seq);
 753      }
 754    }
 755  }
 756  
 757  //! @brief Evaluate partial call.
 758  
 759  void genie_partial_call (NODE_T * p, MOID_T * pr_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE z, ADDR_T pop_sp, ADDR_T pop_fp)
 760  {
 761    int voids = 0;
 762    BYTE_T *u, *v;
 763    PACK_T *s, *t;
 764    A68_REF ref;
 765    A68_HANDLE *loc;
 766  // Get locale for the new procedure descriptor. Copy is necessary.
 767    if (LOCALE (&z) == NO_HANDLE) {
 768      int size = 0;
 769      for (s = PACK (pr_mode); s != NO_PACK; FORWARD (s)) {
 770        size += (SIZE (M_BOOL) + SIZE (MOID (s)));
 771      }
 772      ref = heap_generator (p, pr_mode, size);
 773      loc = REF_HANDLE (&ref);
 774    } else {
 775      int size = SIZE (LOCALE (&z));
 776      ref = heap_generator (p, pr_mode, size);
 777      loc = REF_HANDLE (&ref);
 778      COPY (POINTER (loc), POINTER (LOCALE (&z)), size);
 779    }
 780  // Move arguments from stack to locale using pmap.
 781    u = POINTER (loc);
 782    s = PACK (pr_mode);
 783    v = STACK_ADDRESS (pop_sp);
 784    t = PACK (pmap);
 785    for (; t != NO_PACK && s != NO_PACK; FORWARD (t)) {
 786  // Skip already initialised arguments.
 787      while (u != NULL && VALUE ((A68_BOOL *) & u[0])) {
 788        u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
 789        FORWARD (s);
 790      }
 791      if (u != NULL && MOID (t) == M_VOID) {
 792  // Move to next field in locale.
 793        voids++;
 794        u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
 795        FORWARD (s);
 796      } else {
 797  // Move argument from stack to locale.
 798        A68_BOOL w;
 799        STATUS (&w) = INIT_MASK;
 800        VALUE (&w) = A68_TRUE;
 801        *(A68_BOOL *) & u[0] = w;
 802        COPY (&(u[SIZE (M_BOOL)]), v, SIZE (MOID (t)));
 803        u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
 804        v = &(v[SIZE (MOID (t))]);
 805        FORWARD (s);
 806      }
 807    }
 808    A68_SP = pop_sp;
 809    LOCALE (&z) = loc;
 810  // Is closure complete?.
 811    if (voids == 0) {
 812  // Closure is complete. Push locale onto the stack and call procedure body.
 813      A68_SP = pop_sp;
 814      u = POINTER (loc);
 815      v = STACK_ADDRESS (A68_SP);
 816      s = PACK (pr_mode);
 817      for (; s != NO_PACK; FORWARD (s)) {
 818        int size = SIZE (MOID (s));
 819        COPY (v, &u[SIZE (M_BOOL)], size);
 820        u = &(u[SIZE (M_BOOL) + size]);
 821        v = &(v[SIZE (MOID (s))]);
 822        INCREMENT_STACK_POINTER (p, size);
 823      }
 824      genie_call_procedure (p, pr_mode, pproc, M_VOID, &z, pop_sp, pop_fp);
 825    } else {
 826  //  Closure is not complete. Return procedure body.
 827      PUSH_PROCEDURE (p, z);
 828    }
 829  }
 830  
 831  //! @brief Closure and deproceduring of routines with PARAMSETY.
 832  
 833  void genie_call_procedure (NODE_T * p, MOID_T * pr_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE * z, ADDR_T pop_sp, ADDR_T pop_fp)
 834  {
 835    if (pmap != M_VOID && pr_mode != pmap) {
 836      genie_partial_call (p, pr_mode, pproc, pmap, *z, pop_sp, pop_fp);
 837    } else if (STATUS (z) & STANDENV_PROC_MASK) {
 838      (void) ((*(PROCEDURE (&(BODY (z))))) (p));
 839    } else if (STATUS (z) & SKIP_PROCEDURE_MASK) {
 840      A68_SP = pop_sp;
 841      genie_push_undefined (p, SUB ((MOID (z))));
 842    } else {
 843      NODE_T *body = NODE (&(BODY (z)));
 844      if (IS (body, ROUTINE_TEXT)) {
 845        NODE_T *entry = SUB (body);
 846        PACK_T *args = PACK (pr_mode);
 847        ADDR_T fp0 = 0;
 848  // Copy arguments from stack to frame.
 849        OPEN_PROC_FRAME (entry, ENVIRON (z));
 850        INIT_STATIC_FRAME (entry);
 851        FRAME_DNS (A68_FP) = pop_fp;
 852        for (; args != NO_PACK; FORWARD (args)) {
 853          int size = SIZE (MOID (args));
 854          COPY ((FRAME_OBJECT (fp0)), STACK_ADDRESS (pop_sp + fp0), size);
 855          fp0 += size;
 856        }
 857        A68_SP = pop_sp;
 858        ARGSIZE (GINFO (p)) = fp0;
 859  // Interpret routine text.
 860        if (DIM (pr_mode) > 0) {
 861  // With PARAMETERS.
 862          entry = NEXT (NEXT_NEXT (entry));
 863        } else {
 864  // Without PARAMETERS.
 865          entry = NEXT_NEXT (entry);
 866        }
 867        EXECUTE_UNIT_TRACE (entry);
 868        if (A68_FP == A68_MON (finish_frame_pointer)) {
 869          change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
 870        }
 871        CLOSE_FRAME;
 872        STACK_DNS (p, SUB (pr_mode), A68_FP);
 873      } else {
 874        OPEN_PROC_FRAME (body, ENVIRON (z));
 875        INIT_STATIC_FRAME (body);
 876        FRAME_DNS (A68_FP) = pop_fp;
 877        EXECUTE_UNIT_TRACE (body);
 878        if (A68_FP == A68_MON (finish_frame_pointer)) {
 879          change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
 880        }
 881        CLOSE_FRAME;
 882        STACK_DNS (p, SUB (pr_mode), A68_FP);
 883      }
 884    }
 885  }
 886  
 887  //! @brief Call event routine.
 888  
 889  void genie_call_event_routine (NODE_T * p, MOID_T * m, A68_PROCEDURE * proc, ADDR_T pop_sp, ADDR_T pop_fp)
 890  {
 891    if (NODE (&(BODY (proc))) != NO_NODE) {
 892      A68_PROCEDURE save = *proc;
 893      set_default_event_procedure (proc);
 894      genie_call_procedure (p, MOID (&save), m, m, &save, pop_sp, pop_fp);
 895      (*proc) = save;
 896    }
 897  }
 898  
 899  //! @brief Call PROC with arguments and push result.
 900  
 901  PROP_T genie_call_standenv_quick (NODE_T * p)
 902  {
 903    NODE_T *pr = SUB (p), *q = SEQUENCE (p);
 904    TAG_T *proc = TAX (SOURCE (&GPROP (pr)));
 905  // Get arguments.
 906    for (; q != NO_NODE; q = SEQUENCE (q)) {
 907      EXECUTE_UNIT (q);
 908      STACK_DNS (p, MOID (q), A68_FP);
 909    }
 910    (void) ((*(PROCEDURE (proc))) (p));
 911    return GPROP (p);
 912  }
 913  
 914  //! @brief Call PROC with arguments and push result.
 915  
 916  PROP_T genie_call_quick (NODE_T * p)
 917  {
 918    A68_PROCEDURE z;
 919    NODE_T *proc = SUB (p);
 920    ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
 921  // Get procedure.
 922    EXECUTE_UNIT (proc);
 923    POP_OBJECT (proc, &z, A68_PROCEDURE);
 924    genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
 925  // Get arguments.
 926    if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
 927      NODE_T top_seq;
 928      NODE_T *seq = &top_seq;
 929      GINFO_T g;
 930      GINFO (&top_seq) = &g;
 931      genie_argument (NEXT (proc), &seq);
 932      SEQUENCE (p) = SEQUENCE (&top_seq);
 933      STATUS_SET (p, SEQUENCE_MASK);
 934    } else {
 935      NODE_T *q = SEQUENCE (p);
 936      for (; q != NO_NODE; q = SEQUENCE (q)) {
 937        EXECUTE_UNIT (q);
 938        STACK_DNS (p, MOID (q), A68_FP);
 939      }
 940    }
 941    genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
 942    return GPROP (p);
 943  }
 944  
 945  //! @brief Call PROC with arguments and push result.
 946  
 947  PROP_T genie_call (NODE_T * p)
 948  {
 949    PROP_T self;
 950    A68_PROCEDURE z;
 951    NODE_T *proc = SUB (p);
 952    ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
 953    UNIT (&self) = genie_call_quick;
 954    SOURCE (&self) = p;
 955  // Get procedure.
 956    EXECUTE_UNIT (proc);
 957    POP_OBJECT (proc, &z, A68_PROCEDURE);
 958    genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
 959  // Get arguments.
 960    if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
 961      NODE_T top_seq;
 962      NODE_T *seq = &top_seq;
 963      GINFO_T g;
 964      GINFO (&top_seq) = &g;
 965      genie_argument (NEXT (proc), &seq);
 966      SEQUENCE (p) = SEQUENCE (&top_seq);
 967      STATUS_SET (p, SEQUENCE_MASK);
 968    } else {
 969      NODE_T *q = SEQUENCE (p);
 970      for (; q != NO_NODE; q = SEQUENCE (q)) {
 971        EXECUTE_UNIT (q);
 972      }
 973    }
 974    genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
 975    if (PARTIAL_LOCALE (GINFO (proc)) != M_VOID && MOID (&z) != PARTIAL_LOCALE (GINFO (proc))) {
 976      ;
 977    } else if (STATUS (&z) & STANDENV_PROC_MASK) {
 978      if (UNIT (&GPROP (proc)) == genie_identifier_standenv_proc) {
 979        UNIT (&self) = genie_call_standenv_quick;
 980      }
 981    }
 982    return self;
 983  }
 984  
 985  //! @brief Push value of denotation.
 986  
 987  PROP_T genie_denotation (NODE_T * p)
 988  {
 989    MOID_T *moid = MOID (p);
 990    PROP_T self;
 991    UNIT (&self) = genie_denotation;
 992    SOURCE (&self) = p;
 993    if (moid == M_INT) {
 994  // INT denotation.
 995      A68_INT z;
 996      NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
 997      if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
 998        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
 999        exit_genie (p, A68_RUNTIME_ERROR);
1000      }
1001      UNIT (&self) = genie_constant;
1002      STATUS (&z) = INIT_MASK;
1003      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE (M_INT));
1004      SIZE (GINFO (p)) = SIZE (M_INT);
1005      COPY (CONSTANT (GINFO (p)), &z, SIZE (M_INT));
1006      PUSH_VALUE (p, VALUE ((A68_INT *) (CONSTANT (GINFO (p)))), A68_INT);
1007      return self;
1008    }
1009    if (moid == M_REAL) {
1010  // REAL denotation.
1011      A68_REAL z;
1012      NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
1013      if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1014        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1015        exit_genie (p, A68_RUNTIME_ERROR);
1016      }
1017      STATUS (&z) = INIT_MASK;
1018      UNIT (&self) = genie_constant;
1019      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_REAL));
1020      SIZE (GINFO (p)) = SIZE_ALIGNED (A68_REAL);
1021      COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_REAL));
1022      PUSH_VALUE (p, VALUE ((A68_REAL *) (CONSTANT (GINFO (p)))), A68_REAL);
1023      return self;
1024    }
1025  #if (A68_LEVEL >= 3)
1026    if (moid == M_LONG_INT) {
1027  // LONG INT denotation.
1028      A68_LONG_INT z;
1029      size_t len = (size_t) SIZE_ALIGNED (A68_LONG_INT);
1030      NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
1031      if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1032        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1033        exit_genie (p, A68_RUNTIME_ERROR);
1034      }
1035      UNIT (&self) = genie_constant;
1036      STATUS (&z) = INIT_MASK;
1037      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) len);
1038      SIZE (GINFO (p)) = len;
1039      COPY (CONSTANT (GINFO (p)), &z, len);
1040      PUSH_VALUE (p, VALUE ((A68_LONG_INT *) (CONSTANT (GINFO (p)))), A68_LONG_INT);
1041      return self;
1042    }
1043    if (moid == M_LONG_REAL) {
1044  // LONG REAL denotation.
1045      A68_LONG_REAL z;
1046      NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
1047      if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1048        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1049        exit_genie (p, A68_RUNTIME_ERROR);
1050      }
1051      STATUS (&z) = INIT_MASK;
1052      UNIT (&self) = genie_constant;
1053      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_LONG_REAL));
1054      SIZE (GINFO (p)) = SIZE_ALIGNED (A68_LONG_REAL);
1055      COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_LONG_REAL));
1056      PUSH_VALUE (p, VALUE ((A68_LONG_REAL *) (CONSTANT (GINFO (p)))), A68_LONG_REAL);
1057      return self;
1058    }
1059  // LONG BITS denotation.
1060    if (moid == M_LONG_BITS) {
1061      A68_LONG_BITS z;
1062      NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
1063      if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1064        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1065        exit_genie (p, A68_RUNTIME_ERROR);
1066      }
1067      UNIT (&self) = genie_constant;
1068      STATUS (&z) = INIT_MASK;
1069      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_LONG_BITS));
1070      SIZE (GINFO (p)) = SIZE_ALIGNED (A68_LONG_BITS);
1071      COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_LONG_BITS));
1072      PUSH_VALUE (p, VALUE ((A68_LONG_BITS *) (CONSTANT (GINFO (p)))), A68_LONG_BITS);
1073      return self;
1074    }
1075  #endif
1076    if (moid == M_LONG_INT || moid == M_LONG_LONG_INT) {
1077  // [LONG] LONG INT denotation.
1078      int digits = DIGITS (moid);
1079      int size = SIZE (moid);
1080      NODE_T *number;
1081      if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
1082        number = NEXT_SUB (p);
1083      } else {
1084        number = SUB (p);
1085      }
1086      MP_T *z = nil_mp (p, digits);
1087      if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
1088        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1089        exit_genie (p, A68_RUNTIME_ERROR);
1090      }
1091      MP_STATUS (z) = (MP_T) INIT_MASK;
1092      UNIT (&self) = genie_constant;
1093      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
1094      SIZE (GINFO (p)) = size;
1095      COPY (CONSTANT (GINFO (p)), z, size);
1096      return self;
1097    }
1098    if (moid == M_LONG_REAL || moid == M_LONG_LONG_REAL) {
1099  // [LONG] LONG REAL denotation.
1100      int digits = DIGITS (moid);
1101      int size = SIZE (moid);
1102      NODE_T *number;
1103      if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
1104        number = NEXT_SUB (p);
1105      } else {
1106        number = SUB (p);
1107      }
1108      MP_T *z = nil_mp (p, digits);
1109      if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
1110        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1111        exit_genie (p, A68_RUNTIME_ERROR);
1112      }
1113      MP_STATUS (z) = (MP_T) INIT_MASK;
1114      UNIT (&self) = genie_constant;
1115      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
1116      SIZE (GINFO (p)) = size;
1117      COPY (CONSTANT (GINFO (p)), z, size);
1118      return self;
1119    }
1120    if (moid == M_BITS) {
1121  // BITS denotation.
1122      A68_BITS z;
1123      NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
1124      if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1125        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1126        exit_genie (p, A68_RUNTIME_ERROR);
1127      }
1128      UNIT (&self) = genie_constant;
1129      STATUS (&z) = INIT_MASK;
1130      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_BITS));
1131      SIZE (GINFO (p)) = SIZE_ALIGNED (A68_BITS);
1132      COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_BITS));
1133      PUSH_VALUE (p, VALUE ((A68_BITS *) (CONSTANT (GINFO (p)))), A68_BITS);
1134    }
1135    if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) {
1136  // [LONG] LONG BITS denotation.
1137      int digits = DIGITS (moid);
1138      int size = SIZE (moid);
1139      NODE_T *number;
1140      if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
1141        number = NEXT_SUB (p);
1142      } else {
1143        number = SUB (p);
1144      }
1145      MP_T *z = nil_mp (p, digits);
1146      if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
1147        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1148        exit_genie (p, A68_RUNTIME_ERROR);
1149      }
1150      MP_STATUS (z) = (MP_T) INIT_MASK;
1151      UNIT (&self) = genie_constant;
1152      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
1153      SIZE (GINFO (p)) = size;
1154      COPY (CONSTANT (GINFO (p)), z, size);
1155      return self;
1156    }
1157    if (moid == M_BOOL) {
1158  // BOOL denotation.
1159      A68_BOOL z;
1160      ASSERT (genie_string_to_value_internal (p, M_BOOL, NSYMBOL (p), (BYTE_T *) & z) == A68_TRUE);
1161      PUSH_VALUE (p, VALUE (&z), A68_BOOL);
1162      return self;
1163    } else if (moid == M_CHAR) {
1164  // CHAR denotation.
1165      PUSH_VALUE (p, TO_UCHAR (NSYMBOL (p)[0]), A68_CHAR);
1166      return self;
1167    } else if (moid == M_ROW_CHAR) {
1168  // [] CHAR denotation - permanent string in the heap.
1169      A68_REF z;
1170      A68_ARRAY *arr;
1171      A68_TUPLE *tup;
1172      z = c_to_a_string (p, NSYMBOL (p), DEFAULT_WIDTH);
1173      GET_DESCRIPTOR (arr, tup, &z);
1174      BLOCK_GC_HANDLE (&z);
1175      BLOCK_GC_HANDLE (&(ARRAY (arr)));
1176      UNIT (&self) = genie_constant;
1177      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) A68_REF_SIZE);
1178      SIZE (GINFO (p)) = A68_REF_SIZE;
1179      COPY (CONSTANT (GINFO (p)), &z, A68_REF_SIZE);
1180      PUSH_REF (p, *(A68_REF *) (CONSTANT (GINFO (p))));
1181      (void) tup;
1182      return self;
1183    }
1184    if (moid == M_VOID) {
1185  // VOID denotation: EMPTY.
1186      return self;
1187    }
1188  // ?.
1189    return self;
1190  }
1191  
1192  //! @brief Push a local identifier.
1193  
1194  PROP_T genie_frame_identifier (NODE_T * p)
1195  {
1196    BYTE_T *z;
1197    FRAME_GET (z, BYTE_T, p);
1198    PUSH (p, z, SIZE (MOID (p)));
1199    return GPROP (p);
1200  }
1201  
1202  //! @brief Push standard environ routine as PROC.
1203  
1204  PROP_T genie_identifier_standenv_proc (NODE_T * p)
1205  {
1206    A68_PROCEDURE z;
1207    TAG_T *q = TAX (p);
1208    STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | STANDENV_PROC_MASK);
1209    PROCEDURE (&(BODY (&z))) = PROCEDURE (q);
1210    ENVIRON (&z) = 0;
1211    LOCALE (&z) = NO_HANDLE;
1212    MOID (&z) = MOID (p);
1213    PUSH_PROCEDURE (p, z);
1214    return GPROP (p);
1215  }
1216  
1217  //! @brief (optimised) push identifier from standard environ
1218  
1219  PROP_T genie_identifier_standenv (NODE_T * p)
1220  {
1221    (void) ((*(PROCEDURE (TAX (p)))) (p));
1222    return GPROP (p);
1223  }
1224  
1225  //! @brief Push identifier onto the stack.
1226  
1227  PROP_T genie_identifier (NODE_T * p)
1228  {
1229    static PROP_T self;
1230    TAG_T *q = TAX (p);
1231    SOURCE (&self) = p;
1232    if (A68_STANDENV_PROC (q)) {
1233      if (IS (MOID (q), PROC_SYMBOL)) {
1234        (void) genie_identifier_standenv_proc (p);
1235        UNIT (&self) = genie_identifier_standenv_proc;
1236      } else {
1237        (void) genie_identifier_standenv (p);
1238        UNIT (&self) = genie_identifier_standenv;
1239      }
1240    } else if (STATUS_TEST (q, CONSTANT_MASK)) {
1241      int size = SIZE (MOID (p));
1242      BYTE_T *sp_0 = STACK_TOP;
1243      (void) genie_frame_identifier (p);
1244      CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
1245      SIZE (GINFO (p)) = size;
1246      COPY (CONSTANT (GINFO (p)), (void *) sp_0, size);
1247      UNIT (&self) = genie_constant;
1248    } else {
1249      (void) genie_frame_identifier (p);
1250      UNIT (&self) = genie_frame_identifier;
1251    }
1252    return self;
1253  }
1254  
1255  //! @brief Push result of cast (coercions are deeper in the tree).
1256  
1257  PROP_T genie_cast (NODE_T * p)
1258  {
1259    PROP_T self;
1260    EXECUTE_UNIT (NEXT_SUB (p));
1261    UNIT (&self) = genie_cast;
1262    SOURCE (&self) = p;
1263    return self;
1264  }
1265  
1266  //! @brief Execute assertion.
1267  
1268  PROP_T genie_assertion (NODE_T * p)
1269  {
1270    PROP_T self;
1271    if (STATUS_TEST (p, ASSERT_MASK)) {
1272      A68_BOOL z;
1273      EXECUTE_UNIT (NEXT_SUB (p));
1274      POP_OBJECT (p, &z, A68_BOOL);
1275      if (VALUE (&z) == A68_FALSE) {
1276        diagnostic (A68_RUNTIME_ERROR, p, ERROR_FALSE_ASSERTION);
1277        exit_genie (p, A68_RUNTIME_ERROR);
1278      }
1279    }
1280    UNIT (&self) = genie_assertion;
1281    SOURCE (&self) = p;
1282    return self;
1283  }
1284  
1285  //! @brief Push format text.
1286  
1287  PROP_T genie_format_text (NODE_T * p)
1288  {
1289    static PROP_T self;
1290    A68_FORMAT z = *(A68_FORMAT *) (FRAME_OBJECT (OFFSET (TAX (p))));
1291    PUSH_FORMAT (p, z);
1292    UNIT (&self) = genie_format_text;
1293    SOURCE (&self) = p;
1294    return self;
1295  }
1296  
1297  //! @brief Call operator.
1298  
1299  void genie_call_operator (NODE_T * p, ADDR_T pop_sp)
1300  {
1301    A68_PROCEDURE *z;
1302    ADDR_T pop_fp = A68_FP;
1303    MOID_T *pr_mode = MOID (TAX (p));
1304    FRAME_GET (z, A68_PROCEDURE, p);
1305    genie_call_procedure (p, pr_mode, MOID (z), pr_mode, z, pop_sp, pop_fp);
1306    STACK_DNS (p, SUB (pr_mode), A68_FP);
1307  }
1308  
1309  //! @brief Push result of monadic formula OP "u".
1310  
1311  PROP_T genie_monadic (NODE_T * p)
1312  {
1313    NODE_T *op = SUB (p);
1314    NODE_T *u = NEXT (op);
1315    PROP_T self;
1316    ADDR_T sp = A68_SP;
1317    EXECUTE_UNIT (u);
1318    STACK_DNS (u, MOID (u), A68_FP);
1319    if (PROCEDURE (TAX (op)) != NO_GPROC) {
1320      (void) ((*(PROCEDURE (TAX (op)))) (op));
1321    } else {
1322      genie_call_operator (op, sp);
1323    }
1324    UNIT (&self) = genie_monadic;
1325    SOURCE (&self) = p;
1326    return self;
1327  }
1328  
1329  //! @brief Push result of formula.
1330  
1331  PROP_T genie_dyadic_quick (NODE_T * p)
1332  {
1333    NODE_T *u = SUB (p);
1334    NODE_T *op = NEXT (u);
1335    NODE_T *v = NEXT (op);
1336    EXECUTE_UNIT (u);
1337    STACK_DNS (u, MOID (u), A68_FP);
1338    EXECUTE_UNIT (v);
1339    STACK_DNS (v, MOID (v), A68_FP);
1340    (void) ((*(PROCEDURE (TAX (op)))) (op));
1341    return GPROP (p);
1342  }
1343  
1344  //! @brief Push result of formula.
1345  
1346  PROP_T genie_dyadic (NODE_T * p)
1347  {
1348    NODE_T *u = SUB (p);
1349    NODE_T *op = NEXT (u);
1350    NODE_T *v = NEXT (op);
1351    ADDR_T pop_sp = A68_SP;
1352    EXECUTE_UNIT (u);
1353    STACK_DNS (u, MOID (u), A68_FP);
1354    EXECUTE_UNIT (v);
1355    STACK_DNS (v, MOID (v), A68_FP);
1356    if (PROCEDURE (TAX (op)) != NO_GPROC) {
1357      (void) ((*(PROCEDURE (TAX (op)))) (op));
1358    } else {
1359      genie_call_operator (op, pop_sp);
1360    }
1361    return GPROP (p);
1362  }
1363  
1364  //! @brief Push result of formula.
1365  
1366  PROP_T genie_formula (NODE_T * p)
1367  {
1368    PROP_T self, lhs, rhs;
1369    NODE_T *u = SUB (p);
1370    NODE_T *op = NEXT (u);
1371    ADDR_T pop_sp = A68_SP;
1372    UNIT (&self) = genie_formula;
1373    SOURCE (&self) = p;
1374    EXECUTE_UNIT_2 (u, lhs);
1375    STACK_DNS (u, MOID (u), A68_FP);
1376    if (op != NO_NODE) {
1377      NODE_T *v = NEXT (op);
1378      GPROC *proc = PROCEDURE (TAX (op));
1379      EXECUTE_UNIT_2 (v, rhs);
1380      STACK_DNS (v, MOID (v), A68_FP);
1381      UNIT (&self) = genie_dyadic;
1382      if (proc != NO_GPROC) {
1383        (void) ((*(proc)) (op));
1384        UNIT (&self) = genie_dyadic_quick;
1385      } else {
1386        genie_call_operator (op, pop_sp);
1387      }
1388      return self;
1389    } else if (UNIT (&lhs) == genie_monadic) {
1390      return lhs;
1391    }
1392    (void) rhs;
1393    return self;
1394  }
1395  
1396  //! @brief Push NIL.
1397  
1398  PROP_T genie_nihil (NODE_T * p)
1399  {
1400    PROP_T self;
1401    PUSH_REF (p, nil_ref);
1402    UNIT (&self) = genie_nihil;
1403    SOURCE (&self) = p;
1404    return self;
1405  }
1406  
1407  //! @brief Assign a value to a name and voiden.
1408  
1409  PROP_T genie_voiding_assignation_constant (NODE_T * p)
1410  {
1411    NODE_T *dst = SUB (p);
1412    NODE_T *src = SOURCE (&PROP (GINFO (NEXT_NEXT (dst))));
1413    ADDR_T pop_sp = A68_SP;
1414    A68_REF *z = (A68_REF *) STACK_TOP;
1415    PROP_T self;
1416    UNIT (&self) = genie_voiding_assignation_constant;
1417    SOURCE (&self) = p;
1418    EXECUTE_UNIT (dst);
1419    CHECK_REF (p, *z, MOID (p));
1420    COPY (ADDRESS (z), CONSTANT (GINFO (src)), SIZE (GINFO (src)));
1421    A68_SP = pop_sp;
1422    return self;
1423  }
1424  
1425  //! @brief Assign a value to a name and voiden.
1426  
1427  PROP_T genie_voiding_assignation (NODE_T * p)
1428  {
1429    NODE_T *dst = SUB (p);
1430    NODE_T *src = NEXT_NEXT (dst);
1431    MOID_T *src_mode = SUB_MOID (dst);
1432    ADDR_T pop_sp = A68_SP, pop_fp = FRAME_DNS (A68_FP);
1433    A68_REF z;
1434    PROP_T self;
1435    UNIT (&self) = genie_voiding_assignation;
1436    SOURCE (&self) = p;
1437    EXECUTE_UNIT (dst);
1438    POP_OBJECT (p, &z, A68_REF);
1439    CHECK_REF (p, z, MOID (p));
1440    FRAME_DNS (A68_FP) = REF_SCOPE (&z);
1441    EXECUTE_UNIT (src);
1442    STACK_DNS (src, src_mode, REF_SCOPE (&z));
1443    FRAME_DNS (A68_FP) = pop_fp;
1444    A68_SP = pop_sp;
1445    if (HAS_ROWS (src_mode)) {
1446      genie_clone_stack (p, src_mode, &z, &z);
1447    } else {
1448      COPY_ALIGNED (ADDRESS (&z), STACK_TOP, SIZE (src_mode));
1449    }
1450    return self;
1451  }
1452  
1453  //! @brief Assign a value to a name and push the name.
1454  
1455  PROP_T genie_assignation_constant (NODE_T * p)
1456  {
1457    NODE_T *dst = SUB (p);
1458    NODE_T *src = SOURCE (&PROP (GINFO (NEXT_NEXT (dst))));
1459    A68_REF *z = (A68_REF *) STACK_TOP;
1460    PROP_T self;
1461    UNIT (&self) = genie_assignation_constant;
1462    SOURCE (&self) = p;
1463    EXECUTE_UNIT (dst);
1464    CHECK_REF (p, *z, MOID (p));
1465    COPY (ADDRESS (z), CONSTANT (GINFO (src)), SIZE (GINFO (src)));
1466    return self;
1467  }
1468  
1469  //! @brief Assign a value to a name and push the name.
1470  
1471  PROP_T genie_assignation_quick (NODE_T * p)
1472  {
1473    PROP_T self;
1474    NODE_T *dst = SUB (p);
1475    NODE_T *src = NEXT_NEXT (dst);
1476    MOID_T *src_mode = SUB_MOID (dst);
1477    int size = SIZE (src_mode);
1478    ADDR_T pop_fp = FRAME_DNS (A68_FP);
1479    A68_REF *z = (A68_REF *) STACK_TOP;
1480    EXECUTE_UNIT (dst);
1481    CHECK_REF (p, *z, MOID (p));
1482    FRAME_DNS (A68_FP) = REF_SCOPE (z);
1483    EXECUTE_UNIT (src);
1484    STACK_DNS (src, src_mode, REF_SCOPE (z));
1485    FRAME_DNS (A68_FP) = pop_fp;
1486    DECREMENT_STACK_POINTER (p, size);
1487    if (HAS_ROWS (src_mode)) {
1488      genie_clone_stack (p, src_mode, z, z);
1489    } else {
1490      COPY (ADDRESS (z), STACK_TOP, size);
1491    }
1492    UNIT (&self) = genie_assignation_quick;
1493    SOURCE (&self) = p;
1494    return self;
1495  }
1496  
1497  //! @brief Assign a value to a name and push the name.
1498  
1499  PROP_T genie_assignation (NODE_T * p)
1500  {
1501    PROP_T self, srp;
1502    NODE_T *dst = SUB (p);
1503    NODE_T *src = NEXT_NEXT (dst);
1504    MOID_T *src_mode = SUB_MOID (dst);
1505    int size = SIZE (src_mode);
1506    ADDR_T pop_fp = FRAME_DNS (A68_FP);
1507    A68_REF *z = (A68_REF *) STACK_TOP;
1508    EXECUTE_UNIT (dst);
1509    CHECK_REF (p, *z, MOID (p));
1510    FRAME_DNS (A68_FP) = REF_SCOPE (z);
1511    EXECUTE_UNIT_2 (src, srp);
1512    STACK_DNS (src, src_mode, REF_SCOPE (z));
1513    FRAME_DNS (A68_FP) = pop_fp;
1514    DECREMENT_STACK_POINTER (p, size);
1515    if (HAS_ROWS (src_mode)) {
1516      genie_clone_stack (p, src_mode, z, z);
1517      UNIT (&self) = genie_assignation;
1518    } else {
1519      COPY (ADDRESS (z), STACK_TOP, size);
1520      if (UNIT (&srp) == genie_constant) {
1521        UNIT (&self) = genie_assignation_constant;
1522      } else {
1523        UNIT (&self) = genie_assignation_quick;
1524      }
1525    }
1526    SOURCE (&self) = p;
1527    return self;
1528  }
1529  
1530  //! @brief Push equality of two REFs.
1531  
1532  PROP_T genie_identity_relation (NODE_T * p)
1533  {
1534    PROP_T self;
1535    NODE_T *lhs = SUB (p), *rhs = NEXT_NEXT (lhs);
1536    A68_REF x, y;
1537    UNIT (&self) = genie_identity_relation;
1538    SOURCE (&self) = p;
1539    EXECUTE_UNIT (lhs);
1540    POP_REF (p, &y);
1541    EXECUTE_UNIT (rhs);
1542    POP_REF (p, &x);
1543    if (IS (NEXT_SUB (p), IS_SYMBOL)) {
1544      PUSH_VALUE (p, (BOOL_T) (ADDRESS (&x) == ADDRESS (&y)), A68_BOOL);
1545    } else {
1546      PUSH_VALUE (p, (BOOL_T) (ADDRESS (&x) != ADDRESS (&y)), A68_BOOL);
1547    }
1548    return self;
1549  }
1550  
1551  //! @brief Push result of ANDF.
1552  
1553  PROP_T genie_and_function (NODE_T * p)
1554  {
1555    PROP_T self;
1556    A68_BOOL x;
1557    EXECUTE_UNIT (SUB (p));
1558    POP_OBJECT (p, &x, A68_BOOL);
1559    if (VALUE (&x) == A68_TRUE) {
1560      EXECUTE_UNIT (NEXT_NEXT (SUB (p)));
1561    } else {
1562      PUSH_VALUE (p, A68_FALSE, A68_BOOL);
1563    }
1564    UNIT (&self) = genie_and_function;
1565    SOURCE (&self) = p;
1566    return self;
1567  }
1568  
1569  //! @brief Push result of ORF.
1570  
1571  PROP_T genie_or_function (NODE_T * p)
1572  {
1573    PROP_T self;
1574    A68_BOOL x;
1575    EXECUTE_UNIT (SUB (p));
1576    POP_OBJECT (p, &x, A68_BOOL);
1577    if (VALUE (&x) == A68_FALSE) {
1578      EXECUTE_UNIT (NEXT_NEXT (SUB (p)));
1579    } else {
1580      PUSH_VALUE (p, A68_TRUE, A68_BOOL);
1581    }
1582    UNIT (&self) = genie_or_function;
1583    SOURCE (&self) = p;
1584    return self;
1585  }
1586  
1587  //! @brief Push routine text.
1588  
1589  PROP_T genie_routine_text (NODE_T * p)
1590  {
1591    static PROP_T self;
1592    A68_PROCEDURE z = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p))));
1593    PUSH_PROCEDURE (p, z);
1594    UNIT (&self) = genie_routine_text;
1595    SOURCE (&self) = p;
1596    return self;
1597  }
1598  
1599  //! @brief Push an undefined value of the required mode.
1600  
1601  void genie_push_undefined (NODE_T * p, MOID_T * u)
1602  {
1603  // For primitive modes we push an initialised value.
1604    if (u == M_VOID) {
1605      ;
1606    } else if (u == M_INT) {
1607      PUSH_VALUE (p, 1, A68_INT); // Because users write [~] INT !
1608    } else if (u == M_REAL) {
1609      PUSH_VALUE (p, (a68_unif_rand ()), A68_REAL);
1610    } else if (u == M_BOOL) {
1611      PUSH_VALUE (p, (BOOL_T) (a68_unif_rand () < 0.5), A68_BOOL);
1612    } else if (u == M_CHAR) {
1613      PUSH_VALUE (p, (char) (32 + 96 * a68_unif_rand ()), A68_CHAR);
1614    } else if (u == M_BITS) {
1615      PUSH_VALUE (p, (UNSIGNED_T) (a68_unif_rand () * A68_MAX_BITS), A68_BITS);
1616    } else if (u == M_COMPLEX) {
1617      PUSH_COMPLEX (p, a68_unif_rand (), a68_unif_rand ());
1618    } else if (u == M_BYTES) {
1619      PUSH_BYTES (p, "SKIP");
1620    } else if (u == M_LONG_BYTES) {
1621      PUSH_LONG_BYTES (p, "SKIP");
1622    } else if (u == M_STRING) {
1623      PUSH_REF (p, empty_string (p));
1624    } else if (u == M_LONG_INT) {
1625  #if (A68_LEVEL >= 3)
1626      DOUBLE_NUM_T w;
1627      set_lw (w, 1);
1628      PUSH_VALUE (p, w, A68_LONG_INT);    // Because users write [~] INT !
1629  #else
1630      (void) nil_mp (p, DIGITS (u));
1631  #endif
1632    } else if (u == M_LONG_REAL) {
1633  #if (A68_LEVEL >= 3)
1634      genie_next_random_double_real (p);
1635  #else
1636      (void) nil_mp (p, DIGITS (u));
1637  #endif
1638    } else if (u == M_LONG_BITS) {
1639  #if (A68_LEVEL >= 3)
1640      DOUBLE_NUM_T w;
1641      set_lw (w, 1);
1642      PUSH_VALUE (p, w, A68_LONG_BITS);   // Because users write [~] INT !
1643  #else
1644      (void) nil_mp (p, DIGITS (u));
1645  #endif
1646    } else if (u == M_LONG_LONG_INT) {
1647      (void) nil_mp (p, DIGITS (u));
1648    } else if (u == M_LONG_LONG_REAL) {
1649      (void) nil_mp (p, DIGITS (u));
1650    } else if (u == M_LONG_LONG_BITS) {
1651      (void) nil_mp (p, DIGITS (u));
1652    } else if (u == M_LONG_COMPLEX) {
1653  #if (A68_LEVEL >= 3)
1654      genie_next_random_double_real (p);
1655      genie_next_random_double_real (p);
1656  #else
1657      (void) nil_mp (p, DIGITSC (u));
1658      (void) nil_mp (p, DIGITSC (u));
1659  #endif
1660    } else if (u == M_LONG_LONG_COMPLEX) {
1661      (void) nil_mp (p, DIGITSC (u));
1662      (void) nil_mp (p, DIGITSC (u));
1663    } else if (IS_REF (u)) {
1664  // All REFs are NIL.
1665      PUSH_REF (p, nil_ref);
1666    } else if (IS_ROW (u) || IS_FLEX (u)) {
1667  // [] AMODE or FLEX [] AMODE.
1668      A68_REF er = empty_row (p, u);
1669      STATUS (&er) |= SKIP_ROW_MASK;
1670      PUSH_REF (p, er);
1671    } else if (IS_STRUCT (u)) {
1672  // STRUCT.
1673      PACK_T *v;
1674      for (v = PACK (u); v != NO_PACK; FORWARD (v)) {
1675        genie_push_undefined (p, MOID (v));
1676      }
1677    } else if (IS_UNION (u)) {
1678  // UNION.
1679      ADDR_T sp = A68_SP;
1680      PUSH_UNION (p, MOID (PACK (u)));
1681      genie_push_undefined (p, MOID (PACK (u)));
1682      A68_SP = sp + SIZE (u);
1683    } else if (IS (u, PROC_SYMBOL)) {
1684  // PROC.
1685      A68_PROCEDURE z;
1686      STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | SKIP_PROCEDURE_MASK);
1687      (NODE (&BODY (&z))) = NO_NODE;
1688      ENVIRON (&z) = 0;
1689      LOCALE (&z) = NO_HANDLE;
1690      MOID (&z) = u;
1691      PUSH_PROCEDURE (p, z);
1692    } else if (u == M_FORMAT) {
1693  // FORMAT etc. - what arbitrary FORMAT could mean anything at all?.
1694      A68_FORMAT z;
1695      STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | SKIP_FORMAT_MASK);
1696      BODY (&z) = NO_NODE;
1697      ENVIRON (&z) = 0;
1698      PUSH_FORMAT (p, z);
1699    } else if (u == M_SIMPLOUT) {
1700      ADDR_T sp = A68_SP;
1701      PUSH_UNION (p, M_STRING);
1702      PUSH_REF (p, c_to_a_string (p, "SKIP", DEFAULT_WIDTH));
1703      A68_SP = sp + SIZE (u);
1704    } else if (u == M_SIMPLIN) {
1705      ADDR_T sp = A68_SP;
1706      PUSH_UNION (p, M_REF_STRING);
1707      genie_push_undefined (p, M_REF_STRING);
1708      A68_SP = sp + SIZE (u);
1709    } else if (u == M_REF_FILE) {
1710      PUSH_REF (p, A68 (skip_file));
1711    } else if (u == M_FILE) {
1712      A68_REF *z = (A68_REF *) STACK_TOP;
1713      int size = SIZE (M_FILE);
1714      ADDR_T pop_sp = A68_SP;
1715      PUSH_REF (p, A68 (skip_file));
1716      A68_SP = pop_sp;
1717      PUSH (p, ADDRESS (z), size);
1718    } else if (u == M_CHANNEL) {
1719      PUSH_OBJECT (p, A68 (skip_channel), A68_CHANNEL);
1720    } else if (u == M_PIPE) {
1721      genie_push_undefined (p, M_REF_FILE);
1722      genie_push_undefined (p, M_REF_FILE);
1723      genie_push_undefined (p, M_INT);
1724    } else if (u == M_SOUND) {
1725      A68_SOUND *z = (A68_SOUND *) STACK_TOP;
1726      int size = SIZE (M_SOUND);
1727      INCREMENT_STACK_POINTER (p, size);
1728      FILL (z, 0, size);
1729      STATUS (z) = INIT_MASK;
1730    } else {
1731      BYTE_T *_sp_ = STACK_TOP;
1732      int size = SIZE_ALIGNED (u);
1733      INCREMENT_STACK_POINTER (p, size);
1734      FILL (_sp_, 0, size);
1735    }
1736  }
1737  
1738  //! @brief Push an undefined value of the required mode.
1739  
1740  PROP_T genie_skip (NODE_T * p)
1741  {
1742    PROP_T self;
1743    if (MOID (p) != M_VOID) {
1744      genie_push_undefined (p, MOID (p));
1745    }
1746    UNIT (&self) = genie_skip;
1747    SOURCE (&self) = p;
1748    return self;
1749  }
1750  
1751  //! @brief Jump to the serial clause where the label is at.
1752  
1753  void genie_jump (NODE_T * p)
1754  {
1755  // Stack pointer and frame pointer were saved at target serial clause.
1756    NODE_T *jump = SUB (p);
1757    NODE_T *label = (IS (jump, GOTO_SYMBOL)) ? NEXT (jump) : jump;
1758    ADDR_T target_frame_pointer = A68_FP;
1759    jmp_buf *jump_stat = NO_JMP_BUF;
1760  // Find the stack frame this jump points to.
1761    BOOL_T found = A68_FALSE;
1762    while (target_frame_pointer > 0 && !found) {
1763      found = (BOOL_T) ((TAG_TABLE (TAX (label)) == TABLE (FRAME_TREE (target_frame_pointer))) && FRAME_JUMP_STAT (target_frame_pointer) != NO_JMP_BUF);
1764      if (!found) {
1765        target_frame_pointer = FRAME_STATIC_LINK (target_frame_pointer);
1766      }
1767    }
1768  // Beam us up, Scotty!.
1769  #if defined (BUILD_PARALLEL_CLAUSE)
1770    {
1771      pthread_t target_id = FRAME_THREAD_ID (target_frame_pointer);
1772      if (SAME_THREAD (target_id, pthread_self ())) {
1773        jump_stat = FRAME_JUMP_STAT (target_frame_pointer);
1774        JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label));
1775        longjmp (*(jump_stat), 1);
1776      } else if (SAME_THREAD (target_id, A68_PAR (main_thread_id))) {
1777  // A jump out of all parallel clauses back into the main program.
1778        genie_abend_all_threads (p, FRAME_JUMP_STAT (target_frame_pointer), label);
1779        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1780      } else {
1781        diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_JUMP);
1782        exit_genie (p, A68_RUNTIME_ERROR);
1783      }
1784    }
1785  #else
1786    jump_stat = FRAME_JUMP_STAT (target_frame_pointer);
1787    JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label));
1788    longjmp (*(jump_stat), 1);
1789  #endif
1790  }
1791  
1792  //! @brief Execute a unit, tertiary, secondary or primary.
1793  
1794  PROP_T genie_unit (NODE_T * p)
1795  {
1796    if (IS_COERCION (GINFO (p))) {
1797      GLOBAL_PROP (&A68_JOB) = genie_coercion (p);
1798    } else {
1799      switch (ATTRIBUTE (p)) {
1800      case DECLARATION_LIST:
1801        {
1802          genie_declaration (SUB (p));
1803          UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit;
1804          SOURCE (&GLOBAL_PROP (&A68_JOB)) = p;
1805          break;
1806        }
1807      case UNIT:
1808        {
1809          EXECUTE_UNIT_2 (SUB (p), GLOBAL_PROP (&A68_JOB));
1810          break;
1811        }
1812      case TERTIARY:
1813      case SECONDARY:
1814      case PRIMARY:
1815        {
1816          GLOBAL_PROP (&A68_JOB) = genie_unit (SUB (p));
1817          break;
1818        }
1819  // Ex primary.
1820      case ENCLOSED_CLAUSE:
1821        {
1822          GLOBAL_PROP (&A68_JOB) = genie_enclosed ((volatile NODE_T *) p);
1823          break;
1824        }
1825      case IDENTIFIER:
1826        {
1827          GLOBAL_PROP (&A68_JOB) = genie_identifier (p);
1828          break;
1829        }
1830      case CALL:
1831        {
1832          GLOBAL_PROP (&A68_JOB) = genie_call (p);
1833          break;
1834        }
1835      case SLICE:
1836        {
1837          GLOBAL_PROP (&A68_JOB) = genie_slice (p);
1838          break;
1839        }
1840      case DENOTATION:
1841        {
1842          GLOBAL_PROP (&A68_JOB) = genie_denotation (p);
1843          break;
1844        }
1845      case CAST:
1846        {
1847          GLOBAL_PROP (&A68_JOB) = genie_cast (p);
1848          break;
1849        }
1850      case FORMAT_TEXT:
1851        {
1852          GLOBAL_PROP (&A68_JOB) = genie_format_text (p);
1853          break;
1854        }
1855  // Ex secondary.
1856      case GENERATOR:
1857        {
1858          GLOBAL_PROP (&A68_JOB) = genie_generator (p);
1859          break;
1860        }
1861      case SELECTION:
1862        {
1863          GLOBAL_PROP (&A68_JOB) = genie_selection (p);
1864          break;
1865        }
1866  // Ex tertiary.
1867      case FORMULA:
1868        {
1869          GLOBAL_PROP (&A68_JOB) = genie_formula (p);
1870          break;
1871        }
1872      case MONADIC_FORMULA:
1873        {
1874          GLOBAL_PROP (&A68_JOB) = genie_monadic (p);
1875          break;
1876        }
1877      case NIHIL:
1878        {
1879          GLOBAL_PROP (&A68_JOB) = genie_nihil (p);
1880          break;
1881        }
1882      case DIAGONAL_FUNCTION:
1883        {
1884          GLOBAL_PROP (&A68_JOB) = genie_diagonal_function (p);
1885          break;
1886        }
1887      case TRANSPOSE_FUNCTION:
1888        {
1889          GLOBAL_PROP (&A68_JOB) = genie_transpose_function (p);
1890          break;
1891        }
1892      case ROW_FUNCTION:
1893        {
1894          GLOBAL_PROP (&A68_JOB) = genie_row_function (p);
1895          break;
1896        }
1897      case COLUMN_FUNCTION:
1898        {
1899          GLOBAL_PROP (&A68_JOB) = genie_column_function (p);
1900          break;
1901        }
1902  // Ex unit.
1903      case ASSIGNATION:
1904        {
1905          GLOBAL_PROP (&A68_JOB) = genie_assignation (p);
1906          break;
1907        }
1908      case IDENTITY_RELATION:
1909        {
1910          GLOBAL_PROP (&A68_JOB) = genie_identity_relation (p);
1911          break;
1912        }
1913      case ROUTINE_TEXT:
1914        {
1915          GLOBAL_PROP (&A68_JOB) = genie_routine_text (p);
1916          break;
1917        }
1918      case SKIP:
1919        {
1920          GLOBAL_PROP (&A68_JOB) = genie_skip (p);
1921          break;
1922        }
1923      case JUMP:
1924        {
1925          UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit;
1926          SOURCE (&GLOBAL_PROP (&A68_JOB)) = p;
1927          genie_jump (p);
1928          break;
1929        }
1930      case AND_FUNCTION:
1931        {
1932          GLOBAL_PROP (&A68_JOB) = genie_and_function (p);
1933          break;
1934        }
1935      case OR_FUNCTION:
1936        {
1937          GLOBAL_PROP (&A68_JOB) = genie_or_function (p);
1938          break;
1939        }
1940      case ASSERTION:
1941        {
1942          GLOBAL_PROP (&A68_JOB) = genie_assertion (p);
1943          break;
1944        }
1945      case CODE_CLAUSE:
1946        {
1947          diagnostic (A68_RUNTIME_ERROR, p, ERROR_CODE);
1948          exit_genie (p, A68_RUNTIME_ERROR);
1949          break;
1950        }
1951      }
1952    }
1953    return GPROP (p) = GLOBAL_PROP (&A68_JOB);
1954  }
1955  
1956  //! @brief Execution of serial clause without labels.
1957  
1958  void genie_serial_units_no_label (NODE_T * p, ADDR_T pop_sp, NODE_T ** seq)
1959  {
1960    for (; p != NO_NODE; FORWARD (p)) {
1961      switch (ATTRIBUTE (p)) {
1962      case DECLARATION_LIST:
1963      case UNIT:
1964        {
1965          EXECUTE_UNIT_TRACE (p);
1966          SEQUENCE (*seq) = p;
1967          (*seq) = p;
1968          return;
1969        }
1970      case SEMI_SYMBOL:
1971        {
1972  // Voiden the expression stack.
1973          A68_SP = pop_sp;
1974          SEQUENCE (*seq) = p;
1975          (*seq) = p;
1976          break;
1977        }
1978      default:
1979        {
1980          genie_serial_units_no_label (SUB (p), pop_sp, seq);
1981          break;
1982        }
1983      }
1984    }
1985  }
1986  
1987  //! @brief Execution of serial clause with labels.
1988  
1989  void genie_serial_units (NODE_T * p, NODE_T ** jump_to, jmp_buf * exit_buf, ADDR_T pop_sp)
1990  {
1991    LOW_STACK_ALERT (p);
1992    for (; p != NO_NODE; FORWARD (p)) {
1993      switch (ATTRIBUTE (p)) {
1994      case DECLARATION_LIST:
1995      case UNIT:
1996        {
1997          if (*jump_to == NO_NODE) {
1998            EXECUTE_UNIT_TRACE (p);
1999          } else if (p == *jump_to) {
2000  // If we dropped in this clause from a jump then this unit is the target.
2001            *jump_to = NO_NODE;
2002            EXECUTE_UNIT_TRACE (p);
2003          }
2004          return;
2005        }
2006      case EXIT_SYMBOL:
2007        {
2008          if (*jump_to == NO_NODE) {
2009            longjmp (*exit_buf, 1);
2010          }
2011          break;
2012        }
2013      case SEMI_SYMBOL:
2014        {
2015          if (*jump_to == NO_NODE) {
2016  // Voiden the expression stack.
2017            A68_SP = pop_sp;
2018          }
2019          break;
2020        }
2021      default:
2022        {
2023          genie_serial_units (SUB (p), jump_to, exit_buf, pop_sp);
2024          break;
2025        }
2026      }
2027    }
2028  }
2029  
2030  //! @brief Execute serial clause.
2031  
2032  void genie_serial_clause (NODE_T * p, jmp_buf * exit_buf)
2033  {
2034    if (LABELS (TABLE (p)) == NO_TAG) {
2035  // No labels in this clause.
2036      if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
2037        NODE_T top_seq;
2038        NODE_T *seq = &top_seq;
2039        GINFO_T g;
2040        GINFO (&top_seq) = &g;
2041        genie_serial_units_no_label (SUB (p), A68_SP, &seq);
2042        SEQUENCE (p) = SEQUENCE (&top_seq);
2043        STATUS_SET (p, SEQUENCE_MASK);
2044        STATUS_SET (p, SERIAL_MASK);
2045        if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) {
2046          STATUS_SET (p, OPTIMAL_MASK);
2047        }
2048      } else {
2049  // A linear list without labels.
2050        NODE_T *q;
2051        ADDR_T pop_sp = A68_SP;
2052        STATUS_SET (p, SERIAL_CLAUSE);
2053        for (q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
2054          switch (ATTRIBUTE (q)) {
2055          case DECLARATION_LIST:
2056          case UNIT:
2057            {
2058              EXECUTE_UNIT_TRACE (q);
2059              break;
2060            }
2061          case SEMI_SYMBOL:
2062            {
2063              A68_SP = pop_sp;
2064              break;
2065            }
2066          }
2067        }
2068      }
2069    } else {
2070  // Labels in this clause.
2071      jmp_buf jump_stat;
2072      ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
2073      ADDR_T pop_dns = FRAME_DNS (A68_FP);
2074      FRAME_JUMP_STAT (A68_FP) = &jump_stat;
2075      if (!setjmp (jump_stat)) {
2076        NODE_T *jump_to = NO_NODE;
2077        genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP);
2078      } else {
2079  // HIjol! Restore state and look for indicated unit.
2080        NODE_T *jump_to = JUMP_TO (TABLE (p));
2081        A68_SP = pop_sp;
2082        A68_FP = pop_fp;
2083        FRAME_DNS (A68_FP) = pop_dns;
2084        genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP);
2085      }
2086    }
2087  }
2088  
2089  //! @brief Execute enquiry clause.
2090  
2091  void genie_enquiry_clause (NODE_T * p)
2092  {
2093    if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
2094      NODE_T top_seq;
2095      NODE_T *seq = &top_seq;
2096      GINFO_T g;
2097      GINFO (&top_seq) = &g;
2098      genie_serial_units_no_label (SUB (p), A68_SP, &seq);
2099      SEQUENCE (p) = SEQUENCE (&top_seq);
2100      STATUS_SET (p, SEQUENCE_MASK);
2101      if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) {
2102        STATUS_SET (p, OPTIMAL_MASK);
2103      }
2104    } else {
2105  // A linear list without labels (of course, it's an enquiry clause).
2106      NODE_T *q;
2107      ADDR_T pop_sp = A68_SP;
2108      STATUS_SET (p, SERIAL_MASK);
2109      for (q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
2110        switch (ATTRIBUTE (q)) {
2111        case DECLARATION_LIST:
2112        case UNIT:
2113          {
2114            EXECUTE_UNIT_TRACE (q);
2115            break;
2116          }
2117        case SEMI_SYMBOL:
2118          {
2119            A68_SP = pop_sp;
2120            break;
2121          }
2122        }
2123      }
2124    }
2125  }
2126  
2127  //! @brief Execute collateral units.
2128  
2129  void genie_collateral_units (NODE_T * p, int *count)
2130  {
2131    for (; p != NO_NODE; FORWARD (p)) {
2132      if (IS (p, UNIT)) {
2133        EXECUTE_UNIT_TRACE (p);
2134        STACK_DNS (p, MOID (p), FRAME_DNS (A68_FP));
2135        (*count)++;
2136        return;
2137      } else {
2138        genie_collateral_units (SUB (p), count);
2139      }
2140    }
2141  }
2142  
2143  //! @brief Execute collateral clause.
2144  
2145  PROP_T genie_collateral (NODE_T * p)
2146  {
2147    PROP_T self;
2148  // VOID clause and STRUCT display.
2149    if (MOID (p) == M_VOID || IS_STRUCT (MOID (p))) {
2150      int count = 0;
2151      genie_collateral_units (SUB (p), &count);
2152    } else {
2153  // Row display.
2154      A68_REF new_display;
2155      int count = 0;
2156      ADDR_T sp = A68_SP;
2157      MOID_T *m = MOID (p);
2158      genie_collateral_units (SUB (p), &count);
2159  // [] AMODE vacuum.
2160      if (count == 0) {
2161        A68_SP = sp;
2162        INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
2163        *(A68_REF *) STACK_ADDRESS (sp) = empty_row (p, m);
2164      } else if (DIM (DEFLEX (m)) == 1) {
2165  // [] AMODE display.
2166        new_display = genie_make_row (p, SLICE (DEFLEX (m)), count, sp);
2167        A68_SP = sp;
2168        INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
2169        *(A68_REF *) STACK_ADDRESS (sp) = new_display;
2170      } else {
2171  // [,,] AMODE display, we concatenate 1 + (n-1) to n dimensions.
2172        new_display = genie_make_rowrow (p, m, count, sp);
2173        A68_SP = sp;
2174        INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
2175        *(A68_REF *) STACK_ADDRESS (sp) = new_display;
2176      }
2177    }
2178    UNIT (&self) = genie_collateral;
2179    SOURCE (&self) = p;
2180    return self;
2181  }
2182  
2183  //! @brief Execute unit from integral-case in-part.
2184  
2185  BOOL_T genie_int_case_unit (NODE_T * p, int k, int *count)
2186  {
2187    if (p == NO_NODE) {
2188      return A68_FALSE;
2189    } else {
2190      if (IS (p, UNIT)) {
2191        if (k == *count) {
2192          EXECUTE_UNIT_TRACE (p);
2193          return A68_TRUE;
2194        } else {
2195          (*count)++;
2196          return A68_FALSE;
2197        }
2198      } else {
2199        if (genie_int_case_unit (SUB (p), k, count)) {
2200          return A68_TRUE;
2201        } else {
2202          return genie_int_case_unit (NEXT (p), k, count);
2203        }
2204      }
2205    }
2206  }
2207  
2208  //! @brief Execute unit from united-case in-part.
2209  
2210  BOOL_T genie_united_case_unit (NODE_T * p, MOID_T * m)
2211  {
2212    if (p == NO_NODE) {
2213      return A68_FALSE;
2214    } else {
2215      if (IS (p, SPECIFIER)) {
2216        MOID_T *spec_moid = MOID (NEXT_SUB (p));
2217        BOOL_T equal_modes;
2218        if (m != NO_MOID) {
2219          if (IS_UNION (spec_moid)) {
2220            equal_modes = is_unitable (m, spec_moid, SAFE_DEFLEXING);
2221          } else {
2222            equal_modes = (BOOL_T) (m == spec_moid);
2223          }
2224        } else {
2225          equal_modes = A68_FALSE;
2226        }
2227        if (equal_modes) {
2228          NODE_T *q = NEXT_NEXT (SUB (p));
2229          OPEN_STATIC_FRAME (p);
2230          INIT_STATIC_FRAME (p);
2231          if (IS (q, IDENTIFIER)) {
2232            if (IS_UNION (spec_moid)) {
2233              COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_TOP, SIZE (spec_moid));
2234            } else {
2235              COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_OFFSET (A68_UNION_SIZE), SIZE (spec_moid));
2236            }
2237          }
2238          EXECUTE_UNIT_TRACE (NEXT_NEXT (p));
2239          CLOSE_FRAME;
2240          return A68_TRUE;
2241        } else {
2242          return A68_FALSE;
2243        }
2244      } else {
2245        if (genie_united_case_unit (SUB (p), m)) {
2246          return A68_TRUE;
2247        } else {
2248          return genie_united_case_unit (NEXT (p), m);
2249        }
2250      }
2251    }
2252  }
2253  
2254  //! @brief Execute identity declaration.
2255  
2256  void genie_identity_dec (NODE_T * p)
2257  {
2258    for (; p != NO_NODE; FORWARD (p)) {
2259      if (ISNT (p, DEFINING_IDENTIFIER)) {
2260        genie_identity_dec (SUB (p));
2261      } else {
2262        A68_REF loc;
2263        NODE_T *src = NEXT_NEXT (p);
2264        MOID_T *src_mode = MOID (p);
2265        unt size = (unt) SIZE (src_mode);
2266        BYTE_T *stack_top = STACK_TOP;
2267        ADDR_T pop_sp = A68_SP;
2268        ADDR_T pop_dns = FRAME_DNS (A68_FP);
2269        FRAME_DNS (A68_FP) = A68_FP;
2270        EXECUTE_UNIT_TRACE (src);
2271        genie_check_initialisation (src, stack_top, src_mode);
2272        STACK_DNS (src, src_mode, A68_FP);
2273        FRAME_DNS (A68_FP) = pop_dns;
2274  // Make a temporary REF to the object in the frame.
2275        STATUS (&loc) = (STATUS_MASK_T) (INIT_MASK | IN_FRAME_MASK);
2276        REF_HANDLE (&loc) = (A68_HANDLE *) & nil_handle;
2277        OFFSET (&loc) = A68_FP + FRAME_INFO_SIZE + OFFSET (TAX (p));
2278        REF_SCOPE (&loc) = A68_FP;
2279        ABEND (ADDRESS (&loc) != FRAME_OBJECT (OFFSET (TAX (p))), ERROR_INTERNAL_CONSISTENCY, __func__);
2280  // Initialise the tag, value is in the stack.
2281        if (HAS_ROWS (src_mode)) {
2282          A68_SP = pop_sp;
2283          genie_clone_stack (p, src_mode, &loc, (A68_REF *) & nil_ref);
2284        } else if (UNIT (&GPROP (src)) == genie_constant) {
2285          STATUS_SET (TAX (p), CONSTANT_MASK);
2286          POP_ALIGNED (p, ADDRESS (&loc), size);
2287        } else {
2288          POP_ALIGNED (p, ADDRESS (&loc), size);
2289        }
2290        return;
2291      }
2292    }
2293  }
2294  
2295  //! @brief Execute variable declaration.
2296  
2297  void genie_variable_dec (NODE_T * p, NODE_T ** declarer, ADDR_T sp)
2298  {
2299    for (; p != NO_NODE; FORWARD (p)) {
2300      if (IS (p, VARIABLE_DECLARATION)) {
2301        genie_variable_dec (SUB (p), declarer, sp);
2302      } else {
2303        if (IS (p, DECLARER)) {
2304          (*declarer) = SUB (p);
2305          genie_generator_bounds (*declarer);
2306          FORWARD (p);
2307        }
2308        if (IS (p, DEFINING_IDENTIFIER)) {
2309          MOID_T *ref_mode = MOID (p);
2310          TAG_T *tag = TAX (p);
2311          LEAP_T leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL);
2312          A68_REF *z;
2313          MOID_T *src_mode = SUB_MOID (p);
2314          z = (A68_REF *) (FRAME_OBJECT (OFFSET (TAX (p))));
2315          genie_generator_internal (*declarer, ref_mode, BODY (tag), leap, sp);
2316          POP_REF (p, z);
2317          if (NEXT (p) != NO_NODE && IS (NEXT (p), ASSIGN_SYMBOL)) {
2318            NODE_T *src = NEXT_NEXT (p);
2319            ADDR_T pop_sp = A68_SP;
2320            ADDR_T pop_dns = FRAME_DNS (A68_FP);
2321            FRAME_DNS (A68_FP) = A68_FP;
2322            EXECUTE_UNIT_TRACE (src);
2323            STACK_DNS (src, src_mode, A68_FP);
2324            FRAME_DNS (A68_FP) = pop_dns;
2325            A68_SP = pop_sp;
2326            if (HAS_ROWS (src_mode)) {
2327              genie_clone_stack (p, src_mode, z, z);
2328            } else {
2329              MOVE (ADDRESS (z), STACK_TOP, (unt) SIZE (src_mode));
2330            }
2331          }
2332        }
2333      }
2334    }
2335  }
2336  
2337  //! @brief Execute PROC variable declaration.
2338  
2339  void genie_proc_variable_dec (NODE_T * p)
2340  {
2341    for (; p != NO_NODE; FORWARD (p)) {
2342      switch (ATTRIBUTE (p)) {
2343      case DEFINING_IDENTIFIER:
2344        {
2345          ADDR_T sp_for_voiding = A68_SP;
2346          MOID_T *ref_mode = MOID (p);
2347          TAG_T *tag = TAX (p);
2348          LEAP_T leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL);
2349          A68_REF *z = (A68_REF *) (FRAME_OBJECT (OFFSET (TAX (p))));
2350          genie_generator_internal (p, ref_mode, BODY (tag), leap, A68_SP);
2351          POP_REF (p, z);
2352          if (NEXT (p) != NO_NODE && IS (NEXT (p), ASSIGN_SYMBOL)) {
2353            MOID_T *src_mode = SUB_MOID (p);
2354            ADDR_T pop_sp = A68_SP;
2355            ADDR_T pop_dns = FRAME_DNS (A68_FP);
2356            FRAME_DNS (A68_FP) = A68_FP;
2357            EXECUTE_UNIT_TRACE (NEXT_NEXT (p));
2358            STACK_DNS (p, SUB (ref_mode), A68_FP);
2359            FRAME_DNS (A68_FP) = pop_dns;
2360            A68_SP = pop_sp;
2361            MOVE (ADDRESS (z), STACK_TOP, (unt) SIZE (src_mode));
2362          }
2363          A68_SP = sp_for_voiding;        // Voiding
2364          return;
2365        }
2366      default:
2367        {
2368          genie_proc_variable_dec (SUB (p));
2369          break;
2370        }
2371      }
2372    }
2373  }
2374  
2375  //! @brief Execute operator declaration.
2376  
2377  void genie_operator_dec (NODE_T * p)
2378  {
2379    for (; p != NO_NODE; FORWARD (p)) {
2380      switch (ATTRIBUTE (p)) {
2381      case DEFINING_OPERATOR:
2382        {
2383          A68_PROCEDURE *z = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p))));
2384          ADDR_T pop_dns = FRAME_DNS (A68_FP);
2385          FRAME_DNS (A68_FP) = A68_FP;
2386          EXECUTE_UNIT_TRACE (NEXT_NEXT (p));
2387          STACK_DNS (p, MOID (p), A68_FP);
2388          FRAME_DNS (A68_FP) = pop_dns;
2389          POP_PROCEDURE (p, z);
2390          return;
2391        }
2392      default:
2393        {
2394          genie_operator_dec (SUB (p));
2395          break;
2396        }
2397      }
2398    }
2399  }
2400  
2401  //! @brief Execute declaration.
2402  
2403  void genie_declaration (NODE_T * p)
2404  {
2405    for (; p != NO_NODE; FORWARD (p)) {
2406      switch (ATTRIBUTE (p)) {
2407      case MODE_DECLARATION:
2408      case PROCEDURE_DECLARATION:
2409      case BRIEF_OPERATOR_DECLARATION:
2410      case PRIORITY_DECLARATION:
2411        {
2412  // Already resolved.
2413          return;
2414        }
2415      case IDENTITY_DECLARATION:
2416        {
2417          genie_identity_dec (SUB (p));
2418          break;
2419        }
2420      case OPERATOR_DECLARATION:
2421        {
2422          genie_operator_dec (SUB (p));
2423          break;
2424        }
2425      case VARIABLE_DECLARATION:
2426        {
2427          NODE_T *declarer = NO_NODE;
2428          ADDR_T pop_sp = A68_SP;
2429          genie_variable_dec (SUB (p), &declarer, A68_SP);
2430  // Voiding to remove garbage from declarers.
2431          A68_SP = pop_sp;
2432          break;
2433        }
2434      case PROCEDURE_VARIABLE_DECLARATION:
2435        {
2436          ADDR_T pop_sp = A68_SP;
2437          genie_proc_variable_dec (SUB (p));
2438          A68_SP = pop_sp;
2439          break;
2440        }
2441      default:
2442        {
2443          genie_declaration (SUB (p));
2444          break;
2445        }
2446      }
2447    }
2448  }
2449  
2450  #define LABEL_FREE(_p_) {\
2451    NODE_T *_m_q; ADDR_T pop_sp_lf = A68_SP;\
2452    for (_m_q = SEQUENCE (_p_); _m_q != NO_NODE; _m_q = SEQUENCE (_m_q)) {\
2453      if (IS (_m_q, UNIT) || IS (_m_q, DECLARATION_LIST)) {\
2454        EXECUTE_UNIT_TRACE (_m_q);\
2455      }\
2456      if (SEQUENCE (_m_q) != NO_NODE) {\
2457        A68_SP = pop_sp_lf;\
2458        _m_q = SEQUENCE (_m_q);\
2459      }\
2460    }}
2461  
2462  #define SERIAL_CLAUSE(_p_)\
2463    genie_preemptive_gc_heap ((NODE_T *) (_p_));\
2464    if (STATUS_TEST ((_p_), OPTIMAL_MASK)) {\
2465      EXECUTE_UNIT_TRACE (SEQUENCE (_p_));\
2466    } else if (STATUS_TEST ((_p_), SERIAL_MASK)) {\
2467      LABEL_FREE (_p_);\
2468    } else {\
2469      if (!setjmp (exit_buf)) {\
2470        genie_serial_clause ((NODE_T *) (_p_), (jmp_buf *) exit_buf);\
2471    }}
2472  
2473  #define ENQUIRY_CLAUSE(_p_)\
2474    genie_preemptive_gc_heap ((NODE_T *) (_p_));\
2475    if (STATUS_TEST ((_p_), OPTIMAL_MASK)) {\
2476      EXECUTE_UNIT (SEQUENCE (_p_));\
2477    } else if (STATUS_TEST ((_p_), SERIAL_MASK)) {\
2478      LABEL_FREE (_p_);\
2479    } else {\
2480      genie_enquiry_clause ((NODE_T *) (_p_));\
2481    }
2482  
2483  //! @brief Execute integral-case-clause.
2484  
2485  PROP_T genie_int_case (volatile NODE_T * p)
2486  {
2487    volatile int unit_count;
2488    volatile BOOL_T found_unit;
2489    jmp_buf exit_buf;
2490    A68_INT k;
2491    volatile NODE_T *q = SUB (p);
2492    volatile MOID_T *yield = MOID (q);
2493  // CASE or OUSE.
2494    OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2495    INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
2496    INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2497    ENQUIRY_CLAUSE (NEXT_SUB (q));
2498    POP_OBJECT (q, &k, A68_INT);
2499  // IN.
2500    FORWARD (q);
2501    OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2502    INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2503    unit_count = 1;
2504    found_unit = genie_int_case_unit (NEXT_SUB ((NODE_T *) q), (int) VALUE (&k), (int *) &unit_count);
2505    CLOSE_FRAME;
2506  // OUT.
2507    if (!found_unit) {
2508      FORWARD (q);
2509      switch (ATTRIBUTE (q)) {
2510      case CHOICE:
2511      case OUT_PART:
2512        {
2513          OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2514          INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2515          SERIAL_CLAUSE (NEXT_SUB (q));
2516          CLOSE_FRAME;
2517          break;
2518        }
2519      case CLOSE_SYMBOL:
2520      case ESAC_SYMBOL:
2521        {
2522          if (yield != M_VOID) {
2523            genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
2524          }
2525          break;
2526        }
2527      default:
2528        {
2529          MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
2530          (void) genie_int_case (q);
2531          break;
2532        }
2533      }
2534    }
2535  // ESAC.
2536    CLOSE_FRAME;
2537    return GPROP (p);
2538  }
2539  
2540  //! @brief Execute united-case-clause.
2541  
2542  PROP_T genie_united_case (volatile NODE_T * p)
2543  {
2544    volatile BOOL_T found_unit = A68_FALSE;
2545    volatile MOID_T *um;
2546    volatile ADDR_T pop_sp;
2547    jmp_buf exit_buf;
2548    volatile NODE_T *q = SUB (p);
2549    volatile MOID_T *yield = MOID (q);
2550  // CASE or OUSE.
2551    OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2552    INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
2553    INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2554    pop_sp = A68_SP;
2555    ENQUIRY_CLAUSE (NEXT_SUB (q));
2556    A68_SP = pop_sp;
2557    um = (volatile MOID_T *) VALUE ((A68_UNION *) STACK_TOP);
2558  // IN.
2559    FORWARD (q);
2560    if (um != NO_MOID) {
2561      OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2562      INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2563      found_unit = genie_united_case_unit (NEXT_SUB ((NODE_T *) q), (MOID_T *) um);
2564      CLOSE_FRAME;
2565    } else {
2566      found_unit = A68_FALSE;
2567    }
2568  // OUT.
2569    if (!found_unit) {
2570      FORWARD (q);
2571      switch (ATTRIBUTE (q)) {
2572      case CHOICE:
2573      case OUT_PART:
2574        {
2575          OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2576          INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2577          SERIAL_CLAUSE (NEXT_SUB (q));
2578          CLOSE_FRAME;
2579          break;
2580        }
2581      case CLOSE_SYMBOL:
2582      case ESAC_SYMBOL:
2583        {
2584          if (yield != M_VOID) {
2585            genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
2586          }
2587          break;
2588        }
2589      default:
2590        {
2591          MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
2592          (void) genie_united_case (q);
2593          break;
2594        }
2595      }
2596    }
2597  // ESAC.
2598    CLOSE_FRAME;
2599    return GPROP (p);
2600  }
2601  
2602  //! @brief Execute conditional-clause.
2603  
2604  PROP_T genie_conditional (volatile NODE_T * p)
2605  {
2606    volatile ADDR_T pop_sp = A68_SP;
2607    jmp_buf exit_buf;
2608    volatile NODE_T *q = SUB (p);
2609    volatile MOID_T *yield = MOID (q);
2610  // IF or ELIF.
2611    OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2612    INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
2613    INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2614    ENQUIRY_CLAUSE (NEXT_SUB (q));
2615    A68_SP = pop_sp;
2616    FORWARD (q);
2617    if (VALUE ((A68_BOOL *) STACK_TOP) == A68_TRUE) {
2618  // THEN.
2619      OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2620      INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2621      SERIAL_CLAUSE (NEXT_SUB (q));
2622      CLOSE_FRAME;
2623    } else {
2624  // ELSE.
2625      FORWARD (q);
2626      switch (ATTRIBUTE (q)) {
2627      case CHOICE:
2628      case ELSE_PART:
2629        {
2630          OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2631          INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2632          SERIAL_CLAUSE (NEXT_SUB (q));
2633          CLOSE_FRAME;
2634          break;
2635        }
2636      case CLOSE_SYMBOL:
2637      case FI_SYMBOL:
2638        {
2639          if (yield != M_VOID) {
2640            genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
2641          }
2642          break;
2643        }
2644      default:
2645        {
2646          MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
2647          (void) genie_conditional (q);
2648          break;
2649        }
2650      }
2651    }
2652  // FI.
2653    CLOSE_FRAME;
2654    return GPROP (p);
2655  }
2656  
2657  // INCREMENT_COUNTER procures that the counter only increments if there is
2658  // a for-part or a to-part. Otherwise an infinite loop would trigger overflow
2659  // when the anonymous counter reaches max int, which is strange behaviour.
2660  // This is less relevant using 64-bit integers.
2661  
2662  #define INCREMENT_COUNTER\
2663    if (!(for_part == NO_NODE && to_part == NO_NODE)) {\
2664      CHECK_INT_ADDITION ((NODE_T *) p, counter, by);\
2665      counter += by;\
2666    }
2667  
2668  //! @brief Execute loop-clause.
2669  
2670  PROP_T genie_loop (volatile NODE_T * p)
2671  {
2672    volatile ADDR_T pop_sp = A68_SP;
2673    volatile INT_T from, by, to, counter;
2674    volatile BOOL_T siga, conditional;
2675    volatile NODE_T *for_part = NO_NODE, *to_part = NO_NODE, *q = NO_NODE;
2676    jmp_buf exit_buf;
2677  // FOR  identifier.
2678    if (IS (p, FOR_PART)) {
2679      for_part = NEXT_SUB (p);
2680      FORWARD (p);
2681    }
2682  // FROM unit.
2683    if (IS (p, FROM_PART)) {
2684      EXECUTE_UNIT (NEXT_SUB (p));
2685      A68_SP = pop_sp;
2686      from = VALUE ((A68_INT *) STACK_TOP);
2687      FORWARD (p);
2688    } else {
2689      from = 1;
2690    }
2691  // BY unit.
2692    if (IS (p, BY_PART)) {
2693      EXECUTE_UNIT (NEXT_SUB (p));
2694      A68_SP = pop_sp;
2695      by = VALUE ((A68_INT *) STACK_TOP);
2696      FORWARD (p);
2697    } else {
2698      by = 1;
2699    }
2700  // TO unit, DOWNTO unit.
2701    if (IS (p, TO_PART)) {
2702      if (IS (SUB (p), DOWNTO_SYMBOL)) {
2703        by = -by;
2704      }
2705      EXECUTE_UNIT (NEXT_SUB (p));
2706      A68_SP = pop_sp;
2707      to = VALUE ((A68_INT *) STACK_TOP);
2708      to_part = p;
2709      FORWARD (p);
2710    } else {
2711      to = (by >= 0 ? A68_MAX_INT : -A68_MAX_INT);
2712    }
2713    q = NEXT_SUB (p);
2714  // Here the loop part starts.
2715  // We open the frame only once and reinitialise if necessary
2716    OPEN_STATIC_FRAME ((NODE_T *) q);
2717    INIT_GLOBAL_POINTER ((NODE_T *) q);
2718    INIT_STATIC_FRAME ((NODE_T *) q);
2719    counter = from;
2720  // Does the loop contain conditionals?.
2721    if (IS (p, WHILE_PART)) {
2722      conditional = A68_TRUE;
2723    } else if (IS (p, DO_PART) || IS (p, ALT_DO_PART)) {
2724      NODE_T *until_part = NEXT_SUB (p);
2725      if (IS (until_part, SERIAL_CLAUSE)) {
2726        until_part = NEXT (until_part);
2727      }
2728      conditional = (BOOL_T) (until_part != NO_NODE && IS (until_part, UNTIL_PART));
2729    } else {
2730      conditional = A68_FALSE;
2731    }
2732    if (conditional) {
2733  // [FOR ...] [WHILE ...] DO [...] [UNTIL ...] OD.
2734      siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
2735      while (siga) {
2736        if (for_part != NO_NODE) {
2737          A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part))));
2738          STATUS (z) = INIT_MASK;
2739          VALUE (z) = counter;
2740        }
2741        A68_SP = pop_sp;
2742        if (IS (p, WHILE_PART)) {
2743          ENQUIRY_CLAUSE (q);
2744          A68_SP = pop_sp;
2745          siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) != A68_FALSE);
2746        }
2747        if (siga) {
2748          volatile NODE_T *do_part = p, *until_part;
2749          if (IS (p, WHILE_PART)) {
2750            do_part = NEXT_SUB (NEXT (p));
2751            OPEN_STATIC_FRAME ((NODE_T *) do_part);
2752            INIT_STATIC_FRAME ((NODE_T *) do_part);
2753          } else {
2754            do_part = NEXT_SUB (p);
2755          }
2756          if (IS (do_part, SERIAL_CLAUSE)) {
2757            SERIAL_CLAUSE (do_part);
2758            until_part = NEXT (do_part);
2759          } else {
2760            until_part = do_part;
2761          }
2762  // UNTIL part.
2763          if (until_part != NO_NODE && IS (until_part, UNTIL_PART)) {
2764            NODE_T *v = NEXT_SUB (until_part);
2765            OPEN_STATIC_FRAME ((NODE_T *) v);
2766            INIT_STATIC_FRAME ((NODE_T *) v);
2767            A68_SP = pop_sp;
2768            ENQUIRY_CLAUSE (v);
2769            A68_SP = pop_sp;
2770            siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) == A68_FALSE);
2771            CLOSE_FRAME;
2772          }
2773          if (IS (p, WHILE_PART)) {
2774            CLOSE_FRAME;
2775          }
2776  // Increment counter.
2777          if (siga) {
2778            INCREMENT_COUNTER;
2779            siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
2780          }
2781  // The genie cannot take things to next iteration: re-initialise stack frame.
2782          if (siga) {
2783            FRAME_CLEAR (AP_INCREMENT (TABLE (q)));
2784            if (INITIALISE_FRAME (TABLE (q))) {
2785              initialise_frame ((NODE_T *) q);
2786            }
2787          }
2788        }
2789      }
2790    } else {
2791  // [FOR ...] DO ... OD.
2792      siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
2793      while (siga) {
2794        if (for_part != NO_NODE) {
2795          A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part))));
2796          STATUS (z) = INIT_MASK;
2797          VALUE (z) = counter;
2798        }
2799        A68_SP = pop_sp;
2800        SERIAL_CLAUSE (q);
2801        INCREMENT_COUNTER;
2802        siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
2803  // The genie cannot take things to next iteration: re-initialise stack frame.
2804        if (siga) {
2805          FRAME_CLEAR (AP_INCREMENT (TABLE (q)));
2806          if (INITIALISE_FRAME (TABLE (q))) {
2807            initialise_frame ((NODE_T *) q);
2808          }
2809        }
2810      }
2811    }
2812  // OD.
2813    CLOSE_FRAME;
2814    A68_SP = pop_sp;
2815    return GPROP (p);
2816  }
2817  
2818  #undef INCREMENT_COUNTER
2819  #undef LOOP_OVERFLOW
2820  
2821  //! @brief Execute closed clause.
2822  
2823  PROP_T genie_closed (volatile NODE_T * p)
2824  {
2825    jmp_buf exit_buf;
2826    volatile NODE_T *q = NEXT_SUB (p);
2827    OPEN_STATIC_FRAME ((NODE_T *) q);
2828    INIT_GLOBAL_POINTER ((NODE_T *) q);
2829    INIT_STATIC_FRAME ((NODE_T *) q);
2830    SERIAL_CLAUSE (q);
2831    CLOSE_FRAME;
2832    return GPROP (p);
2833  }
2834  
2835  //! @brief Execute enclosed clause.
2836  
2837  PROP_T genie_enclosed (volatile NODE_T * p)
2838  {
2839    PROP_T self;
2840    UNIT (&self) = (PROP_PROC *) genie_enclosed;
2841    SOURCE (&self) = (NODE_T *) p;
2842    switch (ATTRIBUTE (p)) {
2843    case PARTICULAR_PROGRAM:
2844      {
2845        self = genie_enclosed (SUB (p));
2846        break;
2847      }
2848    case ENCLOSED_CLAUSE:
2849      {
2850        self = genie_enclosed (SUB (p));
2851        break;
2852      }
2853    case CLOSED_CLAUSE:
2854      {
2855        self = genie_closed ((NODE_T *) p);
2856        if (UNIT (&self) == genie_unit) {
2857          UNIT (&self) = (PROP_PROC *) genie_closed;
2858          SOURCE (&self) = (NODE_T *) p;
2859        }
2860        break;
2861      }
2862  #if defined (BUILD_PARALLEL_CLAUSE)
2863    case PARALLEL_CLAUSE:
2864      {
2865        (void) genie_parallel ((NODE_T *) NEXT_SUB (p));
2866        break;
2867      }
2868  #endif
2869    case COLLATERAL_CLAUSE:
2870      {
2871        (void) genie_collateral ((NODE_T *) p);
2872        break;
2873      }
2874    case CONDITIONAL_CLAUSE:
2875      {
2876        MOID (SUB ((NODE_T *) p)) = MOID (p);
2877        (void) genie_conditional (p);
2878        UNIT (&self) = (PROP_PROC *) genie_conditional;
2879        SOURCE (&self) = (NODE_T *) p;
2880        break;
2881      }
2882    case CASE_CLAUSE:
2883      {
2884        MOID (SUB ((NODE_T *) p)) = MOID (p);
2885        (void) genie_int_case (p);
2886        UNIT (&self) = (PROP_PROC *) genie_int_case;
2887        SOURCE (&self) = (NODE_T *) p;
2888        break;
2889      }
2890    case CONFORMITY_CLAUSE:
2891      {
2892        MOID (SUB ((NODE_T *) p)) = MOID (p);
2893        (void) genie_united_case (p);
2894        UNIT (&self) = (PROP_PROC *) genie_united_case;
2895        SOURCE (&self) = (NODE_T *) p;
2896        break;
2897      }
2898    case LOOP_CLAUSE:
2899      {
2900        (void) genie_loop (SUB ((NODE_T *) p));
2901        UNIT (&self) = (PROP_PROC *) genie_loop;
2902        SOURCE (&self) = SUB ((NODE_T *) p);
2903        break;
2904      }
2905    }
2906    GPROP (p) = self;
2907    return self;
2908  }
2909  
2910  //! @brief Propagator_name.
2911  
2912  char *propagator_name (PROP_PROC * p)
2913  {
2914    if (p == genie_and_function) {
2915      return "genie_and_function";
2916    }
2917    if (p == genie_assertion) {
2918      return "genie_assertion";
2919    }
2920    if (p == genie_assignation) {
2921      return "genie_assignation";
2922    }
2923    if (p == genie_assignation_constant) {
2924      return "genie_assignation_constant";
2925    }
2926    if (p == genie_call) {
2927      return "genie_call";
2928    }
2929    if (p == genie_cast) {
2930      return "genie_cast";
2931    }
2932    if (p == (PROP_PROC *) genie_closed) {
2933      return "genie_closed";
2934    }
2935    if (p == genie_coercion) {
2936      return "genie_coercion";
2937    }
2938    if (p == genie_collateral) {
2939      return "genie_collateral";
2940    }
2941    if (p == genie_column_function) {
2942      return "genie_column_function";
2943    }
2944    if (p == (PROP_PROC *) genie_conditional) {
2945      return "genie_conditional";
2946    }
2947    if (p == genie_constant) {
2948      return "genie_constant";
2949    }
2950    if (p == genie_denotation) {
2951      return "genie_denotation";
2952    }
2953    if (p == genie_deproceduring) {
2954      return "genie_deproceduring";
2955    }
2956    if (p == genie_dereference_frame_identifier) {
2957      return "genie_dereference_frame_identifier";
2958    }
2959    if (p == genie_dereference_selection_name_quick) {
2960      return "genie_dereference_selection_name_quick";
2961    }
2962    if (p == genie_dereference_slice_name_quick) {
2963      return "genie_dereference_slice_name_quick";
2964    }
2965    if (p == genie_dereferencing) {
2966      return "genie_dereferencing";
2967    }
2968    if (p == genie_dereferencing_quick) {
2969      return "genie_dereferencing_quick";
2970    }
2971    if (p == genie_diagonal_function) {
2972      return "genie_diagonal_function";
2973    }
2974    if (p == genie_dyadic) {
2975      return "genie_dyadic";
2976    }
2977    if (p == genie_dyadic_quick) {
2978      return "genie_dyadic_quick";
2979    }
2980    if (p == (PROP_PROC *) genie_enclosed) {
2981      return "genie_enclosed";
2982    }
2983    if (p == genie_format_text) {
2984      return "genie_format_text";
2985    }
2986    if (p == genie_formula) {
2987      return "genie_formula";
2988    }
2989    if (p == genie_generator) {
2990      return "genie_generator";
2991    }
2992    if (p == genie_identifier) {
2993      return "genie_identifier";
2994    }
2995    if (p == genie_identifier_standenv) {
2996      return "genie_identifier_standenv";
2997    }
2998    if (p == genie_identifier_standenv_proc) {
2999      return "genie_identifier_standenv_proc";
3000    }
3001    if (p == genie_identity_relation) {
3002      return "genie_identity_relation";
3003    }
3004    if (p == (PROP_PROC *) genie_int_case) {
3005      return "genie_int_case";
3006    }
3007    if (p == genie_field_selection) {
3008      return "genie_field_selection";
3009    }
3010    if (p == genie_frame_identifier) {
3011      return "genie_frame_identifier";
3012    }
3013    if (p == (PROP_PROC *) genie_loop) {
3014      return "genie_loop";
3015    }
3016    if (p == genie_monadic) {
3017      return "genie_monadic";
3018    }
3019    if (p == genie_nihil) {
3020      return "genie_nihil";
3021    }
3022    if (p == genie_or_function) {
3023      return "genie_or_function";
3024    }
3025  #if defined (BUILD_PARALLEL_CLAUSE)
3026    if (p == genie_parallel) {
3027      return "genie_parallel";
3028    }
3029  #endif
3030    if (p == genie_routine_text) {
3031      return "genie_routine_text";
3032    }
3033    if (p == genie_row_function) {
3034      return "genie_row_function";
3035    }
3036    if (p == genie_rowing) {
3037      return "genie_rowing";
3038    }
3039    if (p == genie_rowing_ref_row_of_row) {
3040      return "genie_rowing_ref_row_of_row";
3041    }
3042    if (p == genie_rowing_ref_row_row) {
3043      return "genie_rowing_ref_row_row";
3044    }
3045    if (p == genie_rowing_row_of_row) {
3046      return "genie_rowing_row_of_row";
3047    }
3048    if (p == genie_rowing_row_row) {
3049      return "genie_rowing_row_row";
3050    }
3051    if (p == genie_selection) {
3052      return "genie_selection";
3053    }
3054    if (p == genie_selection_name_quick) {
3055      return "genie_selection_name_quick";
3056    }
3057    if (p == genie_selection_value_quick) {
3058      return "genie_selection_value_quick";
3059    }
3060    if (p == genie_skip) {
3061      return "genie_skip";
3062    }
3063    if (p == genie_slice) {
3064      return "genie_slice";
3065    }
3066    if (p == genie_slice_name_quick) {
3067      return "genie_slice_name_quick";
3068    }
3069    if (p == genie_transpose_function) {
3070      return "genie_transpose_function";
3071    }
3072    if (p == genie_unit) {
3073      return "genie_unit";
3074    }
3075    if (p == (PROP_PROC *) genie_united_case) {
3076      return "genie_united_case";
3077    }
3078    if (p == genie_uniting) {
3079      return "genie_uniting";
3080    }
3081    if (p == genie_voiding) {
3082      return "genie_voiding";
3083    }
3084    if (p == genie_voiding_assignation) {
3085      return "genie_voiding_assignation";
3086    }
3087    if (p == genie_voiding_assignation_constant) {
3088      return "genie_voiding_assignation_constant";
3089    }
3090    if (p == genie_widen) {
3091      return "genie_widen";
3092    }
3093    if (p == genie_widen_int_to_real) {
3094      return "genie_widen_int_to_real";
3095    }
3096    return NO_TEXT;
3097  }