rts-monitor.c

     
   1  //! @file monitor.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  //! GDB-style monitor for the interpreter.
  25  
  26  // This is a basic monitor for Algol68G. It activates when the interpreter
  27  // receives SIGINT (CTRL-C, for instance) or when PROC VOID break, debug or
  28  // evaluate is called, or when a runtime error occurs and --debug is selected.
  29  //
  30  // The monitor allows single stepping (unit-wise through serial/enquiry
  31  // clauses) and has basic means for inspecting call-frame stack and heap. 
  32  
  33  #include "a68g.h"
  34  #include "a68g-genie.h"
  35  #include "a68g-frames.h"
  36  #include "a68g-prelude.h"
  37  #include "a68g-mp.h"
  38  #include "a68g-transput.h"
  39  #include "a68g-parser.h"
  40  #include "a68g-listing.h"
  41  
  42  #define CANNOT_SHOW " unprintable value or uninitialised value"
  43  #define MAX_ROW_ELEMS 24
  44  #define NOT_A_NUM (-1)
  45  #define NO_VALUE " uninitialised value"
  46  #define TOP_MODE (A68_MON (_m_stack)[A68_MON (_m_sp) - 1])
  47  #define LOGOUT_STRING "exit"
  48  
  49  void parse (FILE_T, NODE_T *, int);
  50  
  51  BOOL_T check_initialisation (NODE_T *, BYTE_T *, MOID_T *, BOOL_T *);
  52  
  53  #define SKIP_ONE_SYMBOL(sym) {\
  54    while (!IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
  55      (sym)++;\
  56    }\
  57    while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
  58      (sym)++;\
  59    }}
  60  
  61  #define SKIP_SPACE(sym) {\
  62    while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
  63      (sym)++;\
  64    }}
  65  
  66  #define CHECK_MON_REF(p, z, m)\
  67    if (! INITIALISED (&z)) {\
  68      ASSERT (snprintf(A68 (edit_line), SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\
  69      monitor_error (NO_VALUE, A68 (edit_line));\
  70      QUIT_ON_ERROR;\
  71    } else if (IS_NIL (z)) {\
  72      ASSERT (snprintf(A68 (edit_line), SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\
  73      monitor_error ("accessing NIL name", A68 (edit_line));\
  74      QUIT_ON_ERROR;\
  75    }
  76  
  77  #define QUIT_ON_ERROR\
  78    if (A68_MON (mon_errors) > 0) {\
  79      return;\
  80    }
  81  
  82  #define PARSE_CHECK(f, p, d)\
  83    parse ((f), (p), (d));\
  84    QUIT_ON_ERROR;
  85  
  86  #define SCAN_CHECK(f, p)\
  87    scan_sym((f), (p));\
  88    QUIT_ON_ERROR;
  89  
  90  //! @brief Confirm that we really want to quit.
  91  
  92  BOOL_T confirm_exit (void)
  93  {
  94    ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Terminate %s (yes|no): ", A68 (a68_cmd_name)) >= 0);
  95    WRITELN (STDOUT_FILENO, A68 (output_line));
  96    char *cmd = read_string_from_tty (NULL);
  97    if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) {
  98      return confirm_exit ();
  99    }
 100    for (int k = 0; cmd[k] != NULL_CHAR; k++) {
 101      cmd[k] = (char) TO_LOWER (cmd[k]);
 102    }
 103    if (strcmp (cmd, "y") == 0) {
 104      return A68_TRUE;
 105    }
 106    if (strcmp (cmd, "yes") == 0) {
 107      return A68_TRUE;
 108    }
 109    if (strcmp (cmd, "n") == 0) {
 110      return A68_FALSE;
 111    }
 112    if (strcmp (cmd, "no") == 0) {
 113      return A68_FALSE;
 114    }
 115    return confirm_exit ();
 116  }
 117  
 118  //! @brief Give a monitor error message.
 119  
 120  void monitor_error (char *msg, char *info)
 121  {
 122    QUIT_ON_ERROR;
 123    A68_MON (mon_errors)++;
 124    bufcpy (A68_MON (error_text), msg, BUFFER_SIZE);
 125    WRITELN (STDOUT_FILENO, A68 (a68_cmd_name));
 126    WRITE (STDOUT_FILENO, ": monitor error: ");
 127    WRITE (STDOUT_FILENO, A68_MON (error_text));
 128    if (info != NO_TEXT) {
 129      WRITE (STDOUT_FILENO, " (");
 130      WRITE (STDOUT_FILENO, info);
 131      WRITE (STDOUT_FILENO, ")");
 132    }
 133    WRITE (STDOUT_FILENO, ".");
 134  }
 135  
 136  //! @brief Scan symbol from input.
 137  
 138  void scan_sym (FILE_T f, NODE_T * p)
 139  {
 140    int k = 0;
 141    (void) f;
 142    (void) p;
 143    A68_MON (symbol)[0] = NULL_CHAR;
 144    A68_MON (attr) = 0;
 145    QUIT_ON_ERROR;
 146    while (IS_SPACE (A68_MON (expr)[A68_MON (pos)])) {
 147      A68_MON (pos)++;
 148    }
 149    if (A68_MON (expr)[A68_MON (pos)] == NULL_CHAR) {
 150      A68_MON (attr) = 0;
 151      A68_MON (symbol)[0] = NULL_CHAR;
 152      return;
 153    } else if (A68_MON (expr)[A68_MON (pos)] == ':') {
 154      if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":=:", 3) == 0) {
 155        A68_MON (pos) += 3;
 156        bufcpy (A68_MON (symbol), ":=:", BUFFER_SIZE);
 157        A68_MON (attr) = IS_SYMBOL;
 158      } else if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":/=:", 4) == 0) {
 159        A68_MON (pos) += 4;
 160        bufcpy (A68_MON (symbol), ":/=:", BUFFER_SIZE);
 161        A68_MON (attr) = ISNT_SYMBOL;
 162      } else if (strncmp (&(A68_MON (expr)[A68_MON (pos)]), ":=", 2) == 0) {
 163        A68_MON (pos) += 2;
 164        bufcpy (A68_MON (symbol), ":=", BUFFER_SIZE);
 165        A68_MON (attr) = ASSIGN_SYMBOL;
 166      } else {
 167        A68_MON (pos)++;
 168        bufcpy (A68_MON (symbol), ":", BUFFER_SIZE);
 169        A68_MON (attr) = COLON_SYMBOL;
 170      }
 171      return;
 172    } else if (A68_MON (expr)[A68_MON (pos)] == QUOTE_CHAR) {
 173      BOOL_T cont = A68_TRUE;
 174      A68_MON (pos)++;
 175      while (cont) {
 176        while (A68_MON (expr)[A68_MON (pos)] != QUOTE_CHAR) {
 177          A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 178        }
 179        if (A68_MON (expr)[++A68_MON (pos)] == QUOTE_CHAR) {
 180          A68_MON (symbol)[k++] = QUOTE_CHAR;
 181        } else {
 182          cont = A68_FALSE;
 183        }
 184      }
 185      A68_MON (symbol)[k] = NULL_CHAR;
 186      A68_MON (attr) = ROW_CHAR_DENOTATION;
 187      return;
 188    } else if (IS_LOWER (A68_MON (expr)[A68_MON (pos)])) {
 189      while (IS_LOWER (A68_MON (expr)[A68_MON (pos)]) || IS_DIGIT (A68_MON (expr)[A68_MON (pos)]) || IS_SPACE (A68_MON (expr)[A68_MON (pos)])) {
 190        if (IS_SPACE (A68_MON (expr)[A68_MON (pos)])) {
 191          A68_MON (pos)++;
 192        } else {
 193          A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 194        }
 195      }
 196      A68_MON (symbol)[k] = NULL_CHAR;
 197      A68_MON (attr) = IDENTIFIER;
 198      return;
 199    } else if (IS_UPPER (A68_MON (expr)[A68_MON (pos)])) {
 200      KEYWORD_T *kw;
 201      while (IS_UPPER (A68_MON (expr)[A68_MON (pos)])) {
 202        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 203      }
 204      A68_MON (symbol)[k] = NULL_CHAR;
 205      kw = find_keyword (A68 (top_keyword), A68_MON (symbol));
 206      if (kw != NO_KEYWORD) {
 207        A68_MON (attr) = ATTRIBUTE (kw);
 208      } else {
 209        A68_MON (attr) = OPERATOR;
 210      }
 211      return;
 212    } else if (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) {
 213      while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) {
 214        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 215      }
 216      if (A68_MON (expr)[A68_MON (pos)] == 'r') {
 217        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 218        while (IS_XDIGIT (A68_MON (expr)[A68_MON (pos)])) {
 219          A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 220        }
 221        A68_MON (symbol)[k] = NULL_CHAR;
 222        A68_MON (attr) = BITS_DENOTATION;
 223        return;
 224      }
 225      if (A68_MON (expr)[A68_MON (pos)] != POINT_CHAR && A68_MON (expr)[A68_MON (pos)] != 'e' && A68_MON (expr)[A68_MON (pos)] != 'E') {
 226        A68_MON (symbol)[k] = NULL_CHAR;
 227        A68_MON (attr) = INT_DENOTATION;
 228        return;
 229      }
 230      if (A68_MON (expr)[A68_MON (pos)] == POINT_CHAR) {
 231        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 232        while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) {
 233          A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 234        }
 235      }
 236      if (A68_MON (expr)[A68_MON (pos)] != 'e' && A68_MON (expr)[A68_MON (pos)] != 'E') {
 237        A68_MON (symbol)[k] = NULL_CHAR;
 238        A68_MON (attr) = REAL_DENOTATION;
 239        return;
 240      }
 241      A68_MON (symbol)[k++] = (char) TO_UPPER (A68_MON (expr)[A68_MON (pos)++]);
 242      if (A68_MON (expr)[A68_MON (pos)] == '+' || A68_MON (expr)[A68_MON (pos)] == '-') {
 243        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 244      }
 245      while (IS_DIGIT (A68_MON (expr)[A68_MON (pos)])) {
 246        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 247      }
 248      A68_MON (symbol)[k] = NULL_CHAR;
 249      A68_MON (attr) = REAL_DENOTATION;
 250      return;
 251    } else if (strchr (MONADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT || strchr (NOMADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT) {
 252      A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 253      if (strchr (NOMADS, A68_MON (expr)[A68_MON (pos)]) != NO_TEXT) {
 254        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 255      }
 256      if (A68_MON (expr)[A68_MON (pos)] == ':') {
 257        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 258        if (A68_MON (expr)[A68_MON (pos)] == '=') {
 259          A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 260        } else {
 261          A68_MON (symbol)[k] = NULL_CHAR;
 262          monitor_error ("invalid operator symbol", A68_MON (symbol));
 263        }
 264      } else if (A68_MON (expr)[A68_MON (pos)] == '=') {
 265        A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 266        if (A68_MON (expr)[A68_MON (pos)] == ':') {
 267          A68_MON (symbol)[k++] = A68_MON (expr)[A68_MON (pos)++];
 268        } else {
 269          A68_MON (symbol)[k] = NULL_CHAR;
 270          monitor_error ("invalid operator symbol", A68_MON (symbol));
 271        }
 272      }
 273      A68_MON (symbol)[k] = NULL_CHAR;
 274      A68_MON (attr) = OPERATOR;
 275      return;
 276    } else if (A68_MON (expr)[A68_MON (pos)] == '(') {
 277      A68_MON (pos)++;
 278      A68_MON (attr) = OPEN_SYMBOL;
 279      return;
 280    } else if (A68_MON (expr)[A68_MON (pos)] == ')') {
 281      A68_MON (pos)++;
 282      A68_MON (attr) = CLOSE_SYMBOL;
 283      return;
 284    } else if (A68_MON (expr)[A68_MON (pos)] == '[') {
 285      A68_MON (pos)++;
 286      A68_MON (attr) = SUB_SYMBOL;
 287      return;
 288    } else if (A68_MON (expr)[A68_MON (pos)] == ']') {
 289      A68_MON (pos)++;
 290      A68_MON (attr) = BUS_SYMBOL;
 291      return;
 292    } else if (A68_MON (expr)[A68_MON (pos)] == ',') {
 293      A68_MON (pos)++;
 294      A68_MON (attr) = COMMA_SYMBOL;
 295      return;
 296    } else if (A68_MON (expr)[A68_MON (pos)] == ';') {
 297      A68_MON (pos)++;
 298      A68_MON (attr) = SEMI_SYMBOL;
 299      return;
 300    }
 301  }
 302  
 303  //! @brief Find a tag, searching symbol tables towards the root.
 304  
 305  TAG_T *find_tag (TABLE_T * table, int a, char *name)
 306  {
 307    if (table != NO_TABLE) {
 308      TAG_T *s = NO_TAG;
 309      if (a == OP_SYMBOL) {
 310        s = OPERATORS (table);
 311      } else if (a == PRIO_SYMBOL) {
 312        s = PRIO (table);
 313      } else if (a == IDENTIFIER) {
 314        s = IDENTIFIERS (table);
 315      } else if (a == INDICANT) {
 316        s = INDICANTS (table);
 317      } else if (a == LABEL) {
 318        s = LABELS (table);
 319      } else {
 320        ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 321      }
 322      for (; s != NO_TAG; FORWARD (s)) {
 323        if (strcmp (NSYMBOL (NODE (s)), name) == 0) {
 324          return s;
 325        }
 326      }
 327      return find_tag_global (PREVIOUS (table), a, name);
 328    } else {
 329      return NO_TAG;
 330    }
 331  }
 332  
 333  //! @brief Priority for symbol at input.
 334  
 335  int prio (FILE_T f, NODE_T * p)
 336  {
 337    TAG_T *s = find_tag (A68_STANDENV, PRIO_SYMBOL, A68_MON (symbol));
 338    (void) p;
 339    (void) f;
 340    if (s == NO_TAG) {
 341      monitor_error ("unknown operator, cannot set priority", A68_MON (symbol));
 342      return 0;
 343    }
 344    return PRIO (s);
 345  }
 346  
 347  //! @brief Push a mode on the stack.
 348  
 349  void push_mode (FILE_T f, MOID_T * m)
 350  {
 351    (void) f;
 352    if (A68_MON (_m_sp) < MON_STACK_SIZE) {
 353      A68_MON (_m_stack)[A68_MON (_m_sp)++] = m;
 354    } else {
 355      monitor_error ("expression too complex", NO_TEXT);
 356    }
 357  }
 358  
 359  //! @brief Dereference, WEAK or otherwise.
 360  
 361  BOOL_T deref_condition (int k, int context)
 362  {
 363    MOID_T *u = A68_MON (_m_stack)[k];
 364    if (context == WEAK && SUB (u) != NO_MOID) {
 365      MOID_T *v = SUB (u);
 366      BOOL_T stowed = (BOOL_T) (IS_FLEX (v) || IS_ROW (v) || IS_STRUCT (v));
 367      return (BOOL_T) (IS_REF (u) && !stowed);
 368    } else {
 369      return (BOOL_T) (IS_REF (u));
 370    }
 371  }
 372  
 373  //! @brief Weak dereferencing.
 374  
 375  void deref (NODE_T * p, int k, int context)
 376  {
 377    while (deref_condition (k, context)) {
 378      A68_REF z;
 379      POP_REF (p, &z);
 380      CHECK_MON_REF (p, z, A68_MON (_m_stack)[k]);
 381      A68_MON (_m_stack)[k] = SUB (A68_MON (_m_stack)[k]);
 382      PUSH (p, ADDRESS (&z), SIZE (A68_MON (_m_stack)[k]));
 383    }
 384  }
 385  
 386  //! @brief Search moid that matches indicant.
 387  
 388  MOID_T *search_mode (int refs, int leng, char *indy)
 389  {
 390    MOID_T *m = NO_MOID, *z = NO_MOID;
 391    for (m = TOP_MOID (&A68_JOB); m != NO_MOID; FORWARD (m)) {
 392      if (NODE (m) != NO_NODE) {
 393        if (indy == NSYMBOL (NODE (m)) && leng == DIM (m)) {
 394          z = m;
 395          while (EQUIVALENT (z) != NO_MOID) {
 396            z = EQUIVALENT (z);
 397          }
 398        }
 399      }
 400    }
 401    if (z == NO_MOID) {
 402      monitor_error ("unknown indicant", indy);
 403      return NO_MOID;
 404    }
 405    for (m = TOP_MOID (&A68_JOB); m != NO_MOID; FORWARD (m)) {
 406      int k = 0;
 407      while (IS_REF (m)) {
 408        k++;
 409        m = SUB (m);
 410      }
 411      if (k == refs && m == z) {
 412        while (EQUIVALENT (z) != NO_MOID) {
 413          z = EQUIVALENT (z);
 414        }
 415        return z;
 416      }
 417    }
 418    return NO_MOID;
 419  }
 420  
 421  //! @brief Search operator X SYM Y.
 422  
 423  TAG_T *search_operator (char *sym, MOID_T * x, MOID_T * y)
 424  {
 425    TAG_T *t;
 426    for (t = OPERATORS (A68_STANDENV); t != NO_TAG; FORWARD (t)) {
 427      if (strcmp (NSYMBOL (NODE (t)), sym) == 0) {
 428        PACK_T *p = PACK (MOID (t));
 429        if (x == MOID (p)) {
 430          FORWARD (p);
 431          if (p == NO_PACK && y == NO_MOID) {
 432  // Matched in case of a monad.
 433            return t;
 434          } else if (p != NO_PACK && y != NO_MOID && y == MOID (p)) {
 435  // Matched in case of a nomad.
 436            return t;
 437          }
 438        }
 439      }
 440    }
 441  // Not found yet, try dereferencing.
 442    if (IS_REF (x)) {
 443      return search_operator (sym, SUB (x), y);
 444    }
 445    if (y != NO_MOID && IS_REF (y)) {
 446      return search_operator (sym, x, SUB (y));
 447    }
 448  // Not found. Grrrr. Give a message.
 449    if (y == NO_MOID) {
 450      ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s %s", sym, moid_to_string (x, MOID_WIDTH, NO_NODE)) >= 0);
 451    } else {
 452      ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s %s %s", moid_to_string (x, MOID_WIDTH, NO_NODE), sym, moid_to_string (y, MOID_WIDTH, NO_NODE)) >= 0);
 453    }
 454    monitor_error ("cannot find operator in standard environ", A68 (edit_line));
 455    return NO_TAG;
 456  }
 457  
 458  //! @brief Search identifier in frame stack and push value.
 459  
 460  void search_identifier (FILE_T f, NODE_T * p, ADDR_T a68_link, char *sym)
 461  {
 462    if (a68_link > 0) {
 463      int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
 464      if (A68_MON (current_frame) == 0 || (A68_MON (current_frame) == FRAME_NUMBER (a68_link))) {
 465        NODE_T *u = FRAME_TREE (a68_link);
 466        if (u != NO_NODE) {
 467          TABLE_T *q = TABLE (u);
 468          TAG_T *i = IDENTIFIERS (q);
 469          for (; i != NO_TAG; FORWARD (i)) {
 470            if (strcmp (NSYMBOL (NODE (i)), sym) == 0) {
 471              ADDR_T posit = a68_link + FRAME_INFO_SIZE + OFFSET (i);
 472              MOID_T *m = MOID (i);
 473              PUSH (p, FRAME_ADDRESS (posit), SIZE (m));
 474              push_mode (f, m);
 475              return;
 476            }
 477          }
 478        }
 479      }
 480      search_identifier (f, p, dynamic_a68_link, sym);
 481    } else {
 482      TABLE_T *q = A68_STANDENV;
 483      TAG_T *i = IDENTIFIERS (q);
 484      for (; i != NO_TAG; FORWARD (i)) {
 485        if (strcmp (NSYMBOL (NODE (i)), sym) == 0) {
 486          if (IS (MOID (i), PROC_SYMBOL)) {
 487            static A68_PROCEDURE z;
 488            STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | STANDENV_PROC_MASK);
 489            PROCEDURE (&(BODY (&z))) = PROCEDURE (i);
 490            ENVIRON (&z) = 0;
 491            LOCALE (&z) = NO_HANDLE;
 492            MOID (&z) = MOID (i);
 493            PUSH_PROCEDURE (p, z);
 494          } else {
 495            (*(PROCEDURE (i))) (p);
 496          }
 497          push_mode (f, MOID (i));
 498          return;
 499        }
 500      }
 501      monitor_error ("cannot find identifier", sym);
 502    }
 503  }
 504  
 505  //! @brief Coerce arguments in a call.
 506  
 507  void coerce_arguments (FILE_T f, NODE_T * p, MOID_T * proc, int bot, int top, int top_sp)
 508  {
 509    int k;
 510    PACK_T *u;
 511    ADDR_T pop_sp = top_sp;
 512    (void) f;
 513    if ((top - bot) != DIM (proc)) {
 514      monitor_error ("invalid procedure argument count", NO_TEXT);
 515    }
 516    QUIT_ON_ERROR;
 517    for (k = bot, u = PACK (proc); k < top; k++, FORWARD (u)) {
 518      if (A68_MON (_m_stack)[k] == MOID (u)) {
 519        PUSH (p, STACK_ADDRESS (pop_sp), SIZE (MOID (u)));
 520        pop_sp += SIZE (MOID (u));
 521      } else if (IS_REF (A68_MON (_m_stack)[k])) {
 522        A68_REF *v = (A68_REF *) STACK_ADDRESS (pop_sp);
 523        PUSH_REF (p, *v);
 524        pop_sp += A68_REF_SIZE;
 525        deref (p, k, STRONG);
 526        if (A68_MON (_m_stack)[k] != MOID (u)) {
 527          ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s to %s", moid_to_string (A68_MON (_m_stack)[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0);
 528          monitor_error ("invalid argument mode", A68 (edit_line));
 529        }
 530      } else {
 531        ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s to %s", moid_to_string (A68_MON (_m_stack)[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0);
 532        monitor_error ("cannot coerce argument", A68 (edit_line));
 533      }
 534      QUIT_ON_ERROR;
 535    }
 536    MOVE (STACK_ADDRESS (top_sp), STACK_ADDRESS (pop_sp), A68_SP - pop_sp);
 537    A68_SP = top_sp + (A68_SP - pop_sp);
 538  }
 539  
 540  //! @brief Perform a selection.
 541  
 542  void selection (FILE_T f, NODE_T * p, char *field)
 543  {
 544    BOOL_T name;
 545    MOID_T *moid;
 546    PACK_T *u, *v;
 547    SCAN_CHECK (f, p);
 548    if (A68_MON (attr) != IDENTIFIER && A68_MON (attr) != OPEN_SYMBOL) {
 549      monitor_error ("invalid selection syntax", NO_TEXT);
 550    }
 551    QUIT_ON_ERROR;
 552    PARSE_CHECK (f, p, MAX_PRIORITY + 1);
 553    deref (p, A68_MON (_m_sp) - 1, WEAK);
 554    if (IS_REF (TOP_MODE)) {
 555      name = A68_TRUE;
 556      u = PACK (NAME (TOP_MODE));
 557      moid = SUB (A68_MON (_m_stack)[--A68_MON (_m_sp)]);
 558      v = PACK (moid);
 559    } else {
 560      name = A68_FALSE;
 561      moid = A68_MON (_m_stack)[--A68_MON (_m_sp)];
 562      u = PACK (moid);
 563      v = PACK (moid);
 564    }
 565    if (!IS (moid, STRUCT_SYMBOL)) {
 566      monitor_error ("invalid selection mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
 567    }
 568    QUIT_ON_ERROR;
 569    for (; u != NO_PACK; FORWARD (u), FORWARD (v)) {
 570      if (strcmp (field, TEXT (u)) == 0) {
 571        if (name) {
 572          A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE));
 573          CHECK_MON_REF (p, *z, moid);
 574          OFFSET (z) += OFFSET (v);
 575        } else {
 576          DECREMENT_STACK_POINTER (p, SIZE (moid));
 577          MOVE (STACK_TOP, STACK_OFFSET (OFFSET (v)), (unt) SIZE (MOID (u)));
 578          INCREMENT_STACK_POINTER (p, SIZE (MOID (u)));
 579        }
 580        push_mode (f, MOID (u));
 581        return;
 582      }
 583    }
 584    monitor_error ("invalid field name", field);
 585  }
 586  
 587  //! @brief Perform a call.
 588  
 589  void call (FILE_T f, NODE_T * p, int depth)
 590  {
 591    A68_PROCEDURE z;
 592    NODE_T q;
 593    int args, old_m_sp;
 594    MOID_T *proc;
 595    (void) depth;
 596    QUIT_ON_ERROR;
 597    deref (p, A68_MON (_m_sp) - 1, STRONG);
 598    proc = A68_MON (_m_stack)[--A68_MON (_m_sp)];
 599    old_m_sp = A68_MON (_m_sp);
 600    if (!IS (proc, PROC_SYMBOL)) {
 601      monitor_error ("invalid procedure mode", moid_to_string (proc, MOID_WIDTH, NO_NODE));
 602    }
 603    QUIT_ON_ERROR;
 604    POP_PROCEDURE (p, &z);
 605    args = A68_MON (_m_sp);
 606    ADDR_T top_sp = A68_SP;
 607    if (A68_MON (attr) == OPEN_SYMBOL) {
 608      do {
 609        SCAN_CHECK (f, p);
 610        PARSE_CHECK (f, p, 0);
 611      } while (A68_MON (attr) == COMMA_SYMBOL);
 612      if (A68_MON (attr) != CLOSE_SYMBOL) {
 613        monitor_error ("unmatched parenthesis", NO_TEXT);
 614      }
 615      SCAN_CHECK (f, p);
 616    }
 617    coerce_arguments (f, p, proc, args, A68_MON (_m_sp), top_sp);
 618    if (STATUS (&z) & STANDENV_PROC_MASK) {
 619      MOID (&q) = A68_MON (_m_stack)[--A68_MON (_m_sp)];
 620      INFO (&q) = INFO (p);
 621      NSYMBOL (&q) = NSYMBOL (p);
 622      (void) ((*PROCEDURE (&(BODY (&z)))) (&q));
 623      A68_MON (_m_sp) = old_m_sp;
 624      push_mode (f, SUB_MOID (&z));
 625    } else {
 626      monitor_error ("can only call standard environ routines", NO_TEXT);
 627    }
 628  }
 629  
 630  //! @brief Perform a slice.
 631  
 632  void slice (FILE_T f, NODE_T * p, int depth)
 633  {
 634    MOID_T *moid, *res;
 635    A68_REF z;
 636    A68_ARRAY *arr;
 637    A68_TUPLE *tup;
 638    ADDR_T address;
 639    int dim, k, iindex, args;
 640    BOOL_T name;
 641    (void) depth;
 642    QUIT_ON_ERROR;
 643    deref (p, A68_MON (_m_sp) - 1, WEAK);
 644    if (IS_REF (TOP_MODE)) {
 645      name = A68_TRUE;
 646      res = NAME (TOP_MODE);
 647      deref (p, A68_MON (_m_sp) - 1, STRONG);
 648      moid = A68_MON (_m_stack)[--A68_MON (_m_sp)];
 649    } else {
 650      name = A68_FALSE;
 651      moid = A68_MON (_m_stack)[--A68_MON (_m_sp)];
 652      res = SUB (moid);
 653    }
 654    if (!IS_ROW (moid) && !IS_FLEX (moid)) {
 655      monitor_error ("invalid row mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
 656    }
 657    QUIT_ON_ERROR;
 658  // Get descriptor.
 659    POP_REF (p, &z);
 660    CHECK_MON_REF (p, z, moid);
 661    GET_DESCRIPTOR (arr, tup, &z);
 662    if (IS_FLEX (moid)) {
 663      dim = DIM (SUB (moid));
 664    } else {
 665      dim = DIM (moid);
 666    }
 667  // Get iindexer.
 668    args = A68_MON (_m_sp);
 669    if (A68_MON (attr) == SUB_SYMBOL) {
 670      do {
 671        SCAN_CHECK (f, p);
 672        PARSE_CHECK (f, p, 0);
 673      } while (A68_MON (attr) == COMMA_SYMBOL);
 674      if (A68_MON (attr) != BUS_SYMBOL) {
 675        monitor_error ("unmatched parenthesis", NO_TEXT);
 676      }
 677      SCAN_CHECK (f, p);
 678    }
 679    if ((A68_MON (_m_sp) - args) != dim) {
 680      monitor_error ("invalid slice index count", NO_TEXT);
 681    }
 682    QUIT_ON_ERROR;
 683    for (k = 0, iindex = 0; k < dim; k++, A68_MON (_m_sp)--) {
 684      A68_TUPLE *t = &(tup[dim - k - 1]);
 685      A68_INT i;
 686      deref (p, A68_MON (_m_sp) - 1, MEEK);
 687      if (TOP_MODE != M_INT) {
 688        monitor_error ("invalid indexer mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
 689      }
 690      QUIT_ON_ERROR;
 691      POP_OBJECT (p, &i, A68_INT);
 692      if (VALUE (&i) < LOWER_BOUND (t) || VALUE (&i) > UPPER_BOUND (t)) {
 693        diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
 694        exit_genie (p, A68_RUNTIME_ERROR);
 695      }
 696      QUIT_ON_ERROR;
 697      iindex += SPAN (t) * VALUE (&i) - SHIFT (t);
 698    }
 699    address = ROW_ELEMENT (arr, iindex);
 700    if (name) {
 701      z = ARRAY (arr);
 702      OFFSET (&z) += address;
 703      REF_SCOPE (&z) = PRIMAL_SCOPE;
 704      PUSH_REF (p, z);
 705    } else {
 706      PUSH (p, ADDRESS (&(ARRAY (arr))) + address, SIZE (res));
 707    }
 708    push_mode (f, res);
 709  }
 710  
 711  //! @brief Perform a call or a slice.
 712  
 713  void call_or_slice (FILE_T f, NODE_T * p, int depth)
 714  {
 715    while (A68_MON (attr) == OPEN_SYMBOL || A68_MON (attr) == SUB_SYMBOL) {
 716      QUIT_ON_ERROR;
 717      if (A68_MON (attr) == OPEN_SYMBOL) {
 718        call (f, p, depth);
 719      } else if (A68_MON (attr) == SUB_SYMBOL) {
 720        slice (f, p, depth);
 721      }
 722    }
 723  }
 724  
 725  //! @brief Parse expression on input.
 726  
 727  void parse (FILE_T f, NODE_T * p, int depth)
 728  {
 729    LOW_STACK_ALERT (p);
 730    QUIT_ON_ERROR;
 731    if (depth <= MAX_PRIORITY) {
 732      if (depth == 0) {
 733  // Identity relations.
 734        PARSE_CHECK (f, p, 1);
 735        while (A68_MON (attr) == IS_SYMBOL || A68_MON (attr) == ISNT_SYMBOL) {
 736          A68_REF x, y;
 737          BOOL_T res;
 738          int op = A68_MON (attr);
 739          if (TOP_MODE != M_HIP && !IS_REF (TOP_MODE)) {
 740            monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
 741          }
 742          SCAN_CHECK (f, p);
 743          PARSE_CHECK (f, p, 1);
 744          if (TOP_MODE != M_HIP && !IS_REF (TOP_MODE)) {
 745            monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
 746          }
 747          QUIT_ON_ERROR;
 748          if (TOP_MODE != M_HIP && A68_MON (_m_stack)[A68_MON (_m_sp) - 2] != M_HIP) {
 749            if (TOP_MODE != A68_MON (_m_stack)[A68_MON (_m_sp) - 2]) {
 750              monitor_error ("invalid identity relation operand mode", NO_TEXT);
 751            }
 752          }
 753          QUIT_ON_ERROR;
 754          A68_MON (_m_sp) -= 2;
 755          POP_REF (p, &y);
 756          POP_REF (p, &x);
 757          res = (BOOL_T) (ADDRESS (&x) == ADDRESS (&y));
 758          PUSH_VALUE (p, (BOOL_T) (op == IS_SYMBOL ? res : !res), A68_BOOL);
 759          push_mode (f, M_BOOL);
 760        }
 761      } else {
 762  // Dyadic expressions.
 763        PARSE_CHECK (f, p, depth + 1);
 764        while (A68_MON (attr) == OPERATOR && prio (f, p) == depth) {
 765          int args;
 766          NODE_T q;
 767          TAG_T *opt;
 768          BUFFER name;
 769          bufcpy (name, A68_MON (symbol), BUFFER_SIZE);
 770          args = A68_MON (_m_sp) - 1;
 771          ADDR_T top_sp = A68_SP - SIZE (A68_MON (_m_stack)[args]);
 772          SCAN_CHECK (f, p);
 773          PARSE_CHECK (f, p, depth + 1);
 774          opt = search_operator (name, A68_MON (_m_stack)[A68_MON (_m_sp) - 2], TOP_MODE);
 775          QUIT_ON_ERROR;
 776          coerce_arguments (f, p, MOID (opt), args, A68_MON (_m_sp), top_sp);
 777          A68_MON (_m_sp) -= 2;
 778          MOID (&q) = MOID (opt);
 779          INFO (&q) = INFO (p);
 780          NSYMBOL (&q) = NSYMBOL (p);
 781          (void) ((*(PROCEDURE (opt)))) (&q);
 782          push_mode (f, SUB_MOID (opt));
 783        }
 784      }
 785    } else if (A68_MON (attr) == OPERATOR) {
 786      int args;
 787      NODE_T q;
 788      TAG_T *opt;
 789      BUFFER name;
 790      bufcpy (name, A68_MON (symbol), BUFFER_SIZE);
 791      args = A68_MON (_m_sp);
 792      ADDR_T top_sp = A68_SP;
 793      SCAN_CHECK (f, p);
 794      PARSE_CHECK (f, p, depth);
 795      opt = search_operator (name, TOP_MODE, NO_MOID);
 796      QUIT_ON_ERROR;
 797      coerce_arguments (f, p, MOID (opt), args, A68_MON (_m_sp), top_sp);
 798      A68_MON (_m_sp)--;
 799      MOID (&q) = MOID (opt);
 800      INFO (&q) = INFO (p);
 801      NSYMBOL (&q) = NSYMBOL (p);
 802      (void) ((*(PROCEDURE (opt))) (&q));
 803      push_mode (f, SUB_MOID (opt));
 804    } else if (A68_MON (attr) == REF_SYMBOL) {
 805      int refs = 0, length = 0;
 806      MOID_T *m = NO_MOID;
 807      while (A68_MON (attr) == REF_SYMBOL) {
 808        refs++;
 809        SCAN_CHECK (f, p);
 810      }
 811      while (A68_MON (attr) == LONG_SYMBOL) {
 812        length++;
 813        SCAN_CHECK (f, p);
 814      }
 815      m = search_mode (refs, length, A68_MON (symbol));
 816      QUIT_ON_ERROR;
 817      if (m == NO_MOID) {
 818        monitor_error ("unknown reference to mode", NO_TEXT);
 819      }
 820      SCAN_CHECK (f, p);
 821      if (A68_MON (attr) != OPEN_SYMBOL) {
 822        monitor_error ("cast expects open-symbol", NO_TEXT);
 823      }
 824      SCAN_CHECK (f, p);
 825      PARSE_CHECK (f, p, 0);
 826      if (A68_MON (attr) != CLOSE_SYMBOL) {
 827        monitor_error ("cast expects close-symbol", NO_TEXT);
 828      }
 829      SCAN_CHECK (f, p);
 830      while (IS_REF (TOP_MODE) && TOP_MODE != m) {
 831        MOID_T *sub = SUB (TOP_MODE);
 832        A68_REF z;
 833        POP_REF (p, &z);
 834        CHECK_MON_REF (p, z, TOP_MODE);
 835        PUSH (p, ADDRESS (&z), SIZE (sub));
 836        TOP_MODE = sub;
 837      }
 838      if (TOP_MODE != m) {
 839        monitor_error ("invalid cast mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
 840      }
 841    } else if (A68_MON (attr) == LONG_SYMBOL) {
 842      int length = 0;
 843      MOID_T *m;
 844      while (A68_MON (attr) == LONG_SYMBOL) {
 845        length++;
 846        SCAN_CHECK (f, p);
 847      }
 848  // Cast L INT -> L REAL.
 849      if (A68_MON (attr) == REAL_SYMBOL) {
 850        MOID_T *i = (length == 1 ? M_LONG_INT : M_LONG_LONG_INT);
 851        MOID_T *r = (length == 1 ? M_LONG_REAL : M_LONG_LONG_REAL);
 852        SCAN_CHECK (f, p);
 853        if (A68_MON (attr) != OPEN_SYMBOL) {
 854          monitor_error ("cast expects open-symbol", NO_TEXT);
 855        }
 856        SCAN_CHECK (f, p);
 857        PARSE_CHECK (f, p, 0);
 858        if (A68_MON (attr) != CLOSE_SYMBOL) {
 859          monitor_error ("cast expects close-symbol", NO_TEXT);
 860        }
 861        SCAN_CHECK (f, p);
 862        if (TOP_MODE != i) {
 863          monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
 864        }
 865        QUIT_ON_ERROR;
 866        TOP_MODE = r;
 867        return;
 868      }
 869  // L INT or L REAL denotation.
 870      if (A68_MON (attr) == INT_DENOTATION) {
 871        m = (length == 1 ? M_LONG_INT : M_LONG_LONG_INT);
 872      } else if (A68_MON (attr) == REAL_DENOTATION) {
 873        m = (length == 1 ? M_LONG_REAL : M_LONG_LONG_REAL);
 874      } else if (A68_MON (attr) == BITS_DENOTATION) {
 875        m = (length == 1 ? M_LONG_BITS : M_LONG_LONG_BITS);
 876      } else {
 877        m = NO_MOID;
 878      }
 879      if (m != NO_MOID) {
 880        int digits = DIGITS (m);
 881        MP_T *z = nil_mp (p, digits);
 882        if (genie_string_to_value_internal (p, m, A68_MON (symbol), (BYTE_T *) z) == A68_FALSE) {
 883          diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m);
 884          exit_genie (p, A68_RUNTIME_ERROR);
 885        }
 886        MP_STATUS (z) = (MP_T) (INIT_MASK | CONSTANT_MASK);
 887        push_mode (f, m);
 888        SCAN_CHECK (f, p);
 889      } else {
 890        monitor_error ("invalid mode", NO_TEXT);
 891      }
 892    } else if (A68_MON (attr) == INT_DENOTATION) {
 893      A68_INT z;
 894      if (genie_string_to_value_internal (p, M_INT, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) {
 895        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_INT);
 896        exit_genie (p, A68_RUNTIME_ERROR);
 897      }
 898      PUSH_VALUE (p, VALUE (&z), A68_INT);
 899      push_mode (f, M_INT);
 900      SCAN_CHECK (f, p);
 901    } else if (A68_MON (attr) == REAL_DENOTATION) {
 902      A68_REAL z;
 903      if (genie_string_to_value_internal (p, M_REAL, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) {
 904        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_REAL);
 905        exit_genie (p, A68_RUNTIME_ERROR);
 906      }
 907      PUSH_VALUE (p, VALUE (&z), A68_REAL);
 908      push_mode (f, M_REAL);
 909      SCAN_CHECK (f, p);
 910    } else if (A68_MON (attr) == BITS_DENOTATION) {
 911      A68_BITS z;
 912      if (genie_string_to_value_internal (p, M_BITS, A68_MON (symbol), (BYTE_T *) & z) == A68_FALSE) {
 913        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_BITS);
 914        exit_genie (p, A68_RUNTIME_ERROR);
 915      }
 916      PUSH_VALUE (p, VALUE (&z), A68_BITS);
 917      push_mode (f, M_BITS);
 918      SCAN_CHECK (f, p);
 919    } else if (A68_MON (attr) == ROW_CHAR_DENOTATION) {
 920      if (strlen (A68_MON (symbol)) == 1) {
 921        PUSH_VALUE (p, A68_MON (symbol)[0], A68_CHAR);
 922        push_mode (f, M_CHAR);
 923      } else {
 924        A68_REF z;
 925        A68_ARRAY *arr;
 926        A68_TUPLE *tup;
 927        z = c_to_a_string (p, A68_MON (symbol), DEFAULT_WIDTH);
 928        GET_DESCRIPTOR (arr, tup, &z);
 929        BLOCK_GC_HANDLE (&z);
 930        BLOCK_GC_HANDLE (&(ARRAY (arr)));
 931        PUSH_REF (p, z);
 932        push_mode (f, M_STRING);
 933        (void) tup;
 934      }
 935      SCAN_CHECK (f, p);
 936    } else if (A68_MON (attr) == TRUE_SYMBOL) {
 937      PUSH_VALUE (p, A68_TRUE, A68_BOOL);
 938      push_mode (f, M_BOOL);
 939      SCAN_CHECK (f, p);
 940    } else if (A68_MON (attr) == FALSE_SYMBOL) {
 941      PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 942      push_mode (f, M_BOOL);
 943      SCAN_CHECK (f, p);
 944    } else if (A68_MON (attr) == NIL_SYMBOL) {
 945      PUSH_REF (p, nil_ref);
 946      push_mode (f, M_HIP);
 947      SCAN_CHECK (f, p);
 948    } else if (A68_MON (attr) == REAL_SYMBOL) {
 949      A68_INT k;
 950      SCAN_CHECK (f, p);
 951      if (A68_MON (attr) != OPEN_SYMBOL) {
 952        monitor_error ("cast expects open-symbol", NO_TEXT);
 953      }
 954      SCAN_CHECK (f, p);
 955      PARSE_CHECK (f, p, 0);
 956      if (A68_MON (attr) != CLOSE_SYMBOL) {
 957        monitor_error ("cast expects close-symbol", NO_TEXT);
 958      }
 959      SCAN_CHECK (f, p);
 960      if (TOP_MODE != M_INT) {
 961        monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
 962      }
 963      QUIT_ON_ERROR;
 964      POP_OBJECT (p, &k, A68_INT);
 965      PUSH_VALUE (p, (REAL_T) VALUE (&k), A68_REAL);
 966      TOP_MODE = M_REAL;
 967    } else if (A68_MON (attr) == IDENTIFIER) {
 968      ADDR_T old_sp = A68_SP;
 969      BOOL_T init;
 970      MOID_T *moid;
 971      BUFFER name;
 972      bufcpy (name, A68_MON (symbol), BUFFER_SIZE);
 973      SCAN_CHECK (f, p);
 974      if (A68_MON (attr) == OF_SYMBOL) {
 975        selection (f, p, name);
 976      } else {
 977        search_identifier (f, p, A68_FP, name);
 978        QUIT_ON_ERROR;
 979        call_or_slice (f, p, depth);
 980      }
 981      moid = TOP_MODE;
 982      QUIT_ON_ERROR;
 983      if (check_initialisation (p, STACK_ADDRESS (old_sp), moid, &init)) {
 984        if (init == A68_FALSE) {
 985          monitor_error (NO_VALUE, name);
 986        }
 987      } else {
 988        monitor_error ("cannot process value of mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
 989      }
 990    } else if (A68_MON (attr) == OPEN_SYMBOL) {
 991      do {
 992        SCAN_CHECK (f, p);
 993        PARSE_CHECK (f, p, 0);
 994      } while (A68_MON (attr) == COMMA_SYMBOL);
 995      if (A68_MON (attr) != CLOSE_SYMBOL) {
 996        monitor_error ("unmatched parenthesis", NO_TEXT);
 997      }
 998      SCAN_CHECK (f, p);
 999      call_or_slice (f, p, depth);
1000    } else {
1001      monitor_error ("invalid expression syntax", NO_TEXT);
1002    }
1003  }
1004  
1005  //! @brief Perform assignment.
1006  
1007  void assign (FILE_T f, NODE_T * p)
1008  {
1009    LOW_STACK_ALERT (p);
1010    PARSE_CHECK (f, p, 0);
1011    if (A68_MON (attr) == ASSIGN_SYMBOL) {
1012      MOID_T *m = A68_MON (_m_stack)[--A68_MON (_m_sp)];
1013      A68_REF z;
1014      if (!IS_REF (m)) {
1015        monitor_error ("invalid destination mode", moid_to_string (m, MOID_WIDTH, NO_NODE));
1016      }
1017      QUIT_ON_ERROR;
1018      POP_REF (p, &z);
1019      CHECK_MON_REF (p, z, m);
1020      SCAN_CHECK (f, p);
1021      assign (f, p);
1022      QUIT_ON_ERROR;
1023      while (IS_REF (TOP_MODE) && TOP_MODE != SUB (m)) {
1024        MOID_T *sub = SUB (TOP_MODE);
1025        A68_REF y;
1026        POP_REF (p, &y);
1027        CHECK_MON_REF (p, y, TOP_MODE);
1028        PUSH (p, ADDRESS (&y), SIZE (sub));
1029        TOP_MODE = sub;
1030      }
1031      if (TOP_MODE != SUB (m) && TOP_MODE != M_HIP) {
1032        monitor_error ("invalid source mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
1033      }
1034      QUIT_ON_ERROR;
1035      POP (p, ADDRESS (&z), SIZE (TOP_MODE));
1036      PUSH_REF (p, z);
1037      TOP_MODE = m;
1038    }
1039  }
1040  
1041  //! @brief Evaluate expression on input.
1042  
1043  void evaluate (FILE_T f, NODE_T * p, char *str)
1044  {
1045    LOW_STACK_ALERT (p);
1046    A68_MON (_m_sp) = 0;
1047    A68_MON (_m_stack)[0] = NO_MOID;
1048    A68_MON (pos) = 0;
1049    bufcpy (A68_MON (expr), str, BUFFER_SIZE);
1050    SCAN_CHECK (f, p);
1051    QUIT_ON_ERROR;
1052    assign (f, p);
1053    if (A68_MON (attr) != 0) {
1054      monitor_error ("trailing character in expression", A68_MON (symbol));
1055    }
1056  }
1057  
1058  //! @brief Convert string to int.
1059  
1060  int get_num_arg (char *num, char **rest)
1061  {
1062    char *end;
1063    int k;
1064    if (rest != NO_VAR) {
1065      *rest = NO_TEXT;
1066    }
1067    if (num == NO_TEXT) {
1068      return NOT_A_NUM;
1069    }
1070    SKIP_ONE_SYMBOL (num);
1071    if (IS_DIGIT (num[0])) {
1072      errno = 0;
1073      k = (int) a68_strtou (num, &end, 10);
1074      if (end != num && errno == 0) {
1075        if (rest != NO_VAR) {
1076          *rest = end;
1077        }
1078        return k;
1079      } else {
1080        monitor_error ("invalid numerical argument", error_specification ());
1081        return NOT_A_NUM;
1082      }
1083    } else {
1084      if (num[0] != NULL_CHAR) {
1085        monitor_error ("invalid numerical argument", num);
1086      }
1087      return NOT_A_NUM;
1088    }
1089  }
1090  
1091  //! @brief Whether item at "w" of mode "q" is initialised.
1092  
1093  BOOL_T check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q, BOOL_T * result)
1094  {
1095    BOOL_T initialised = A68_FALSE, recognised = A68_FALSE;
1096    (void) p;
1097    switch (SHORT_ID (q)) {
1098    case MODE_NO_CHECK:
1099    case UNION_SYMBOL:
1100      {
1101        initialised = A68_TRUE;
1102        recognised = A68_TRUE;
1103        break;
1104      }
1105    case REF_SYMBOL:
1106      {
1107        A68_REF *z = (A68_REF *) w;
1108        initialised = INITIALISED (z);
1109        recognised = A68_TRUE;
1110        break;
1111      }
1112    case PROC_SYMBOL:
1113      {
1114        A68_PROCEDURE *z = (A68_PROCEDURE *) w;
1115        initialised = INITIALISED (z);
1116        recognised = A68_TRUE;
1117        break;
1118      }
1119    case MODE_INT:
1120      {
1121        A68_INT *z = (A68_INT *) w;
1122        initialised = INITIALISED (z);
1123        recognised = A68_TRUE;
1124        break;
1125      }
1126    case MODE_REAL:
1127      {
1128        A68_REAL *z = (A68_REAL *) w;
1129        initialised = INITIALISED (z);
1130        recognised = A68_TRUE;
1131        break;
1132      }
1133    case MODE_COMPLEX:
1134      {
1135        A68_REAL *r = (A68_REAL *) w;
1136        A68_REAL *i = (A68_REAL *) (w + SIZE_ALIGNED (A68_REAL));
1137        initialised = (BOOL_T) (INITIALISED (r) && INITIALISED (i));
1138        recognised = A68_TRUE;
1139        break;
1140      }
1141  #if (A68_LEVEL >= 3)
1142    case MODE_LONG_INT:
1143    case MODE_LONG_BITS:
1144      {
1145        A68_LONG_INT *z = (A68_LONG_INT *) w;
1146        initialised = INITIALISED (z);
1147        recognised = A68_TRUE;
1148        break;
1149      }
1150    case MODE_LONG_REAL:
1151      {
1152        A68_LONG_REAL *z = (A68_LONG_REAL *) w;
1153        initialised = INITIALISED (z);
1154        recognised = A68_TRUE;
1155        break;
1156      }
1157  #else
1158    case MODE_LONG_INT:
1159    case MODE_LONG_REAL:
1160    case MODE_LONG_BITS:
1161      {
1162        MP_T *z = (MP_T *) w;
1163        initialised = (BOOL_T) ((unt) MP_STATUS (z) & INIT_MASK);
1164        recognised = A68_TRUE;
1165        break;
1166      }
1167  #endif
1168    case MODE_LONG_LONG_INT:
1169    case MODE_LONG_LONG_REAL:
1170    case MODE_LONG_LONG_BITS:
1171      {
1172        MP_T *z = (MP_T *) w;
1173        initialised = (BOOL_T) ((unt) MP_STATUS (z) & INIT_MASK);
1174        recognised = A68_TRUE;
1175        break;
1176      }
1177    case MODE_LONG_COMPLEX:
1178      {
1179        MP_T *r = (MP_T *) w;
1180        MP_T *i = (MP_T *) (w + size_mp ());
1181        initialised = (BOOL_T) (((unt) MP_STATUS (r) & INIT_MASK) && ((unt) MP_STATUS (i) & INIT_MASK));
1182        recognised = A68_TRUE;
1183        break;
1184      }
1185    case MODE_LONG_LONG_COMPLEX:
1186      {
1187        MP_T *r = (MP_T *) w;
1188        MP_T *i = (MP_T *) (w + size_mp ());
1189        initialised = (BOOL_T) (((unt) MP_STATUS (r) & INIT_MASK) && ((unt) MP_STATUS (i) & INIT_MASK));
1190        recognised = A68_TRUE;
1191        break;
1192      }
1193    case MODE_BOOL:
1194      {
1195        A68_BOOL *z = (A68_BOOL *) w;
1196        initialised = INITIALISED (z);
1197        recognised = A68_TRUE;
1198        break;
1199      }
1200    case MODE_CHAR:
1201      {
1202        A68_CHAR *z = (A68_CHAR *) w;
1203        initialised = INITIALISED (z);
1204        recognised = A68_TRUE;
1205        break;
1206      }
1207    case MODE_BITS:
1208      {
1209        A68_BITS *z = (A68_BITS *) w;
1210        initialised = INITIALISED (z);
1211        recognised = A68_TRUE;
1212        break;
1213      }
1214    case MODE_BYTES:
1215      {
1216        A68_BYTES *z = (A68_BYTES *) w;
1217        initialised = INITIALISED (z);
1218        recognised = A68_TRUE;
1219        break;
1220      }
1221    case MODE_LONG_BYTES:
1222      {
1223        A68_LONG_BYTES *z = (A68_LONG_BYTES *) w;
1224        initialised = INITIALISED (z);
1225        recognised = A68_TRUE;
1226        break;
1227      }
1228    case MODE_FILE:
1229      {
1230        A68_FILE *z = (A68_FILE *) w;
1231        initialised = INITIALISED (z);
1232        recognised = A68_TRUE;
1233        break;
1234      }
1235    case MODE_FORMAT:
1236      {
1237        A68_FORMAT *z = (A68_FORMAT *) w;
1238        initialised = INITIALISED (z);
1239        recognised = A68_TRUE;
1240        break;
1241      }
1242    case MODE_PIPE:
1243      {
1244        A68_REF *pipe_read = (A68_REF *) w;
1245        A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE);
1246        A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE);
1247        initialised = (BOOL_T) (INITIALISED (pipe_read) && INITIALISED (pipe_write) && INITIALISED (pid));
1248        recognised = A68_TRUE;
1249        break;
1250      }
1251    case MODE_SOUND:
1252      {
1253        A68_SOUND *z = (A68_SOUND *) w;
1254        initialised = INITIALISED (z);
1255        recognised = A68_TRUE;
1256      }
1257    }
1258    if (result != NO_BOOL) {
1259      *result = initialised;
1260    }
1261    return recognised;
1262  }
1263  
1264  //! @brief Show value of object.
1265  
1266  void print_item (NODE_T * p, FILE_T f, BYTE_T * item, MOID_T * mode)
1267  {
1268    A68_REF nil_file = nil_ref;
1269    reset_transput_buffer (UNFORMATTED_BUFFER);
1270    genie_write_standard (p, mode, item, nil_file);
1271    if (get_transput_buffer_index (UNFORMATTED_BUFFER) > 0) {
1272      if (mode == M_CHAR || mode == M_ROW_CHAR || mode == M_STRING) {
1273        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " \"%s\"", get_transput_buffer (UNFORMATTED_BUFFER)) >= 0);
1274        WRITE (f, A68 (output_line));
1275      } else {
1276        char *str = get_transput_buffer (UNFORMATTED_BUFFER);
1277        while (IS_SPACE (str[0])) {
1278          str++;
1279        }
1280        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %s", str) >= 0);
1281        WRITE (f, A68 (output_line));
1282      }
1283    } else {
1284      WRITE (f, CANNOT_SHOW);
1285    }
1286  }
1287  
1288  //! @brief Indented indent_crlf.
1289  
1290  void indent_crlf (FILE_T f)
1291  {
1292    int k;
1293    io_close_tty_line ();
1294    for (k = 0; k < A68_MON (tabs); k++) {
1295      WRITE (f, "  ");
1296    }
1297  }
1298  
1299  //! @brief Show value of object.
1300  
1301  void show_item (FILE_T f, NODE_T * p, BYTE_T * item, MOID_T * mode)
1302  {
1303    if (item == NO_BYTE || mode == NO_MOID) {
1304      return;
1305    }
1306    if (IS_REF (mode)) {
1307      A68_REF *z = (A68_REF *) item;
1308      if (IS_NIL (*z)) {
1309        if (INITIALISED (z)) {
1310          WRITE (STDOUT_FILENO, " = NIL");
1311        } else {
1312          WRITE (STDOUT_FILENO, NO_VALUE);
1313        }
1314      } else {
1315        if (INITIALISED (z)) {
1316          WRITE (STDOUT_FILENO, " refers to ");
1317          if (IS_IN_HEAP (z)) {
1318            ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "heap(%p)", (void *) ADDRESS (z)) >= 0);
1319            WRITE (STDOUT_FILENO, A68 (output_line));
1320            A68_MON (tabs)++;
1321            show_item (f, p, ADDRESS (z), SUB (mode));
1322            A68_MON (tabs)--;
1323          } else if (IS_IN_FRAME (z)) {
1324            ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "frame(" A68_LU ")", REF_OFFSET (z)) >= 0);
1325            WRITE (STDOUT_FILENO, A68 (output_line));
1326          } else if (IS_IN_STACK (z)) {
1327            ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "stack(" A68_LU ")", REF_OFFSET (z)) >= 0);
1328            WRITE (STDOUT_FILENO, A68 (output_line));
1329          }
1330        } else {
1331          WRITE (STDOUT_FILENO, NO_VALUE);
1332        }
1333      }
1334    } else if (mode == M_STRING) {
1335      if (!INITIALISED ((A68_REF *) item)) {
1336        WRITE (STDOUT_FILENO, NO_VALUE);
1337      } else {
1338        print_item (p, f, item, mode);
1339      }
1340    } else if ((IS_ROW (mode) || IS_FLEX (mode)) && mode != M_STRING) {
1341      MOID_T *deflexed = DEFLEX (mode);
1342      int old_tabs = A68_MON (tabs);
1343      A68_MON (tabs) += 2;
1344      if (!INITIALISED ((A68_REF *) item)) {
1345        WRITE (STDOUT_FILENO, NO_VALUE);
1346      } else {
1347        A68_ARRAY *arr;
1348        A68_TUPLE *tup;
1349        int count = 0, act_count = 0, elems;
1350        GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1351        elems = get_row_size (tup, DIM (arr));
1352        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, ", %d element(s)", elems) >= 0);
1353        WRITE (f, A68 (output_line));
1354        if (get_row_size (tup, DIM (arr)) != 0) {
1355          BYTE_T *base_addr = ADDRESS (&ARRAY (arr));
1356          BOOL_T done = A68_FALSE;
1357          initialise_internal_index (tup, DIM (arr));
1358          while (!done && ++count <= (A68_MON (max_row_elems) + 1)) {
1359            if (count <= A68_MON (max_row_elems)) {
1360              ADDR_T row_index = calculate_internal_index (tup, DIM (arr));
1361              ADDR_T elem_addr = ROW_ELEMENT (arr, row_index);
1362              BYTE_T *elem = &base_addr[elem_addr];
1363              indent_crlf (f);
1364              WRITE (f, "[");
1365              print_internal_index (f, tup, DIM (arr));
1366              WRITE (f, "]");
1367              show_item (f, p, elem, SUB (deflexed));
1368              act_count++;
1369              done = increment_internal_index (tup, DIM (arr));
1370            }
1371          }
1372          indent_crlf (f);
1373          ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " %d element(s) written (%d%%)", act_count, (int) ((100.0 * act_count) / elems)) >= 0);
1374          WRITE (f, A68 (output_line));
1375        }
1376      }
1377      A68_MON (tabs) = old_tabs;
1378    } else if (IS_STRUCT (mode)) {
1379      PACK_T *q = PACK (mode);
1380      A68_MON (tabs)++;
1381      for (; q != NO_PACK; FORWARD (q)) {
1382        BYTE_T *elem = &item[OFFSET (q)];
1383        indent_crlf (f);
1384        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "     %s \"%s\"", moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), TEXT (q)) >= 0);
1385        WRITE (STDOUT_FILENO, A68 (output_line));
1386        show_item (f, p, elem, MOID (q));
1387      }
1388      A68_MON (tabs)--;
1389    } else if (IS (mode, UNION_SYMBOL)) {
1390      A68_UNION *z = (A68_UNION *) item;
1391      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1392      WRITE (STDOUT_FILENO, A68 (output_line));
1393      show_item (f, p, &item[SIZE_ALIGNED (A68_UNION)], (MOID_T *) (VALUE (z)));
1394    } else if (mode == M_SIMPLIN) {
1395      A68_UNION *z = (A68_UNION *) item;
1396      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1397      WRITE (STDOUT_FILENO, A68 (output_line));
1398    } else if (mode == M_SIMPLOUT) {
1399      A68_UNION *z = (A68_UNION *) item;
1400      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
1401      WRITE (STDOUT_FILENO, A68 (output_line));
1402    } else {
1403      BOOL_T init;
1404      if (check_initialisation (p, item, mode, &init)) {
1405        if (init) {
1406          if (IS (mode, PROC_SYMBOL)) {
1407            A68_PROCEDURE *z = (A68_PROCEDURE *) item;
1408            if (z != NO_PROCEDURE && STATUS (z) & STANDENV_PROC_MASK) {
1409              char *fname = standard_environ_proc_name (*(PROCEDURE (&BODY (z))));
1410              WRITE (STDOUT_FILENO, " standenv procedure");
1411              if (fname != NO_TEXT) {
1412                WRITE (STDOUT_FILENO, " (");
1413                WRITE (STDOUT_FILENO, fname);
1414                WRITE (STDOUT_FILENO, ")");
1415              }
1416            } else if (z != NO_PROCEDURE && STATUS (z) & SKIP_PROCEDURE_MASK) {
1417              WRITE (STDOUT_FILENO, " skip procedure");
1418            } else if (z != NO_PROCEDURE && (PROCEDURE (&BODY (z))) != NO_GPROC) {
1419              ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68_LU "), locale %p", LINE_NUMBER ((NODE_T *) NODE (&BODY (z))), ENVIRON (z), (void *) LOCALE (z)) >= 0);
1420              WRITE (STDOUT_FILENO, A68 (output_line));
1421            } else {
1422              WRITE (STDOUT_FILENO, " cannot show value");
1423            }
1424          } else if (mode == M_FORMAT) {
1425            A68_FORMAT *z = (A68_FORMAT *) item;
1426            if (z != NO_FORMAT && BODY (z) != NO_NODE) {
1427              ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68_LU ")", LINE_NUMBER (BODY (z)), ENVIRON (z)) >= 0);
1428              WRITE (STDOUT_FILENO, A68 (output_line));
1429            } else {
1430              monitor_error (CANNOT_SHOW, NO_TEXT);
1431            }
1432          } else if (mode == M_SOUND) {
1433            A68_SOUND *z = (A68_SOUND *) item;
1434            if (z != NO_SOUND) {
1435              ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%u channels, %u bits, %u rate, %u samples", NUM_CHANNELS (z), BITS_PER_SAMPLE (z), SAMPLE_RATE (z), NUM_SAMPLES (z)) >= 0);
1436              WRITE (STDOUT_FILENO, A68 (output_line));
1437  
1438            } else {
1439              monitor_error (CANNOT_SHOW, NO_TEXT);
1440            }
1441          } else {
1442            print_item (p, f, item, mode);
1443          }
1444        } else {
1445          WRITE (STDOUT_FILENO, NO_VALUE);
1446        }
1447      } else {
1448        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, " mode %s, %s", moid_to_string (mode, MOID_WIDTH, NO_NODE), CANNOT_SHOW) >= 0);
1449        WRITE (STDOUT_FILENO, A68 (output_line));
1450      }
1451    }
1452  }
1453  
1454  //! @brief Overview of frame item.
1455  
1456  void show_frame_item (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, int modif)
1457  {
1458    ADDR_T addr = a68_link + FRAME_INFO_SIZE + OFFSET (q);
1459    ADDR_T loc = FRAME_INFO_SIZE + OFFSET (q);
1460    (void) p;
1461    indent_crlf (STDOUT_FILENO);
1462    if (modif != ANONYMOUS) {
1463      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "     frame(" A68_LU "=" A68_LU "+" A68_LU ") %s \"%s\"", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), NSYMBOL (NODE (q))) >= 0);
1464      WRITE (STDOUT_FILENO, A68 (output_line));
1465      show_item (f, p, FRAME_ADDRESS (addr), MOID (q));
1466    } else {
1467      switch (PRIO (q)) {
1468      case GENERATOR:
1469        {
1470          ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "     frame(" A68_LU "=" A68_LU "+" A68_LU ") LOC %s", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0);
1471          WRITE (STDOUT_FILENO, A68 (output_line));
1472          break;
1473        }
1474      default:
1475        {
1476          ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "     frame(" A68_LU "=" A68_LU "+" A68_LU ") internal %s", addr, a68_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0);
1477          WRITE (STDOUT_FILENO, A68 (output_line));
1478          break;
1479        }
1480      }
1481      show_item (f, p, FRAME_ADDRESS (addr), MOID (q));
1482    }
1483  }
1484  
1485  //! @brief Overview of frame items.
1486  
1487  void show_frame_items (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, int modif)
1488  {
1489    (void) p;
1490    for (; q != NO_TAG; FORWARD (q)) {
1491      show_frame_item (f, p, a68_link, q, modif);
1492    }
1493  }
1494  
1495  //! @brief Introduce stack frame.
1496  
1497  void intro_frame (FILE_T f, NODE_T * p, ADDR_T a68_link, int *printed)
1498  {
1499    TABLE_T *q = TABLE (p);
1500    if (*printed > 0) {
1501      WRITELN (f, "");
1502    }
1503    (*printed)++;
1504    where_in_source (f, p);
1505    ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Stack frame %d at frame(" A68_LU "), level=%d, size=" A68_LU " bytes", FRAME_NUMBER (a68_link), a68_link, LEVEL (q), (UNSIGNED_T) (FRAME_INCREMENT (a68_link) + FRAME_INFO_SIZE)) >= 0);
1506    WRITELN (f, A68 (output_line));
1507  }
1508  
1509  //! @brief View contents of stack frame.
1510  
1511  void show_stack_frame (FILE_T f, NODE_T * p, ADDR_T a68_link, int *printed)
1512  {
1513  // show the frame starting at frame pointer 'a68_link', using symbol table from p as a map.
1514    if (p != NO_NODE) {
1515      TABLE_T *q = TABLE (p);
1516      intro_frame (f, p, a68_link, printed);
1517  #if (A68_LEVEL >= 3)
1518      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Dynamic link=frame(%llu), static link=frame(%llu), parameters=frame(%llu)", FRAME_DYNAMIC_LINK (a68_link), FRAME_STATIC_LINK (a68_link), FRAME_PARAMETERS (a68_link)) >= 0);
1519      WRITELN (STDOUT_FILENO, A68 (output_line));
1520  #else
1521      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Dynamic link=frame(%u), static link=frame(%u), parameters=frame(%u)", FRAME_DYNAMIC_LINK (a68_link), FRAME_STATIC_LINK (a68_link), FRAME_PARAMETERS (a68_link)) >= 0);
1522      WRITELN (STDOUT_FILENO, A68 (output_line));
1523  #endif
1524      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Procedure frame=%s", (FRAME_PROC_FRAME (a68_link) ? "yes" : "no")) >= 0);
1525      WRITELN (STDOUT_FILENO, A68 (output_line));
1526  #if defined (BUILD_PARALLEL_CLAUSE)
1527      if (pthread_equal (FRAME_THREAD_ID (a68_link), A68_PAR (main_thread_id)) != 0) {
1528        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "In main thread") >= 0);
1529      } else {
1530        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Not in main thread") >= 0);
1531      }
1532      WRITELN (STDOUT_FILENO, A68 (output_line));
1533  #endif
1534      show_frame_items (f, p, a68_link, IDENTIFIERS (q), IDENTIFIER);
1535      show_frame_items (f, p, a68_link, OPERATORS (q), OPERATOR);
1536      show_frame_items (f, p, a68_link, ANONYMOUS (q), ANONYMOUS);
1537    }
1538  }
1539  
1540  //! @brief Shows lines around the line where 'p' is at.
1541  
1542  void list (FILE_T f, NODE_T * p, int n, int m)
1543  {
1544    if (p != NO_NODE) {
1545      if (m == 0) {
1546        LINE_T *r = LINE (INFO (p));
1547        LINE_T *l = TOP_LINE (&A68_JOB);
1548        for (; l != NO_LINE; FORWARD (l)) {
1549          if (NUMBER (l) > 0 && abs (NUMBER (r) - NUMBER (l)) <= n) {
1550            write_source_line (f, l, NO_NODE, A68_TRUE);
1551          }
1552        }
1553      } else {
1554        LINE_T *l = TOP_LINE (&A68_JOB);
1555        for (; l != NO_LINE; FORWARD (l)) {
1556          if (NUMBER (l) > 0 && NUMBER (l) >= n && NUMBER (l) <= m) {
1557            write_source_line (f, l, NO_NODE, A68_TRUE);
1558          }
1559        }
1560      }
1561    }
1562  }
1563  
1564  //! @brief Overview of the heap.
1565  
1566  void show_heap (FILE_T f, NODE_T * p, A68_HANDLE * z, int top, int n)
1567  {
1568    int k = 0, m = n, sum = 0;
1569    (void) p;
1570    ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "size=%u available=%d garbage collections=" A68_LD, A68 (heap_size), heap_available (), A68_GC (sweeps)) >= 0);
1571    WRITELN (f, A68 (output_line));
1572    for (; z != NO_HANDLE; FORWARD (z), k++) {
1573      if (n > 0 && sum <= top) {
1574        n--;
1575        indent_crlf (f);
1576        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "heap(%p+%d) %s", (void *) POINTER (z), SIZE (z), moid_to_string (MOID (z), MOID_WIDTH, NO_NODE)) >= 0);
1577        WRITE (f, A68 (output_line));
1578        sum += SIZE (z);
1579      }
1580    }
1581    ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "printed %d out of %d handles", m, k) >= 0);
1582    WRITELN (f, A68 (output_line));
1583  }
1584  
1585  //! @brief Search current frame and print it.
1586  
1587  void stack_dump_current (FILE_T f, ADDR_T a68_link)
1588  {
1589    if (a68_link > 0) {
1590      int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1591      NODE_T *p = FRAME_TREE (a68_link);
1592      if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1593        if (FRAME_NUMBER (a68_link) == A68_MON (current_frame)) {
1594          int printed = 0;
1595          show_stack_frame (f, p, a68_link, &printed);
1596        } else {
1597          stack_dump_current (f, dynamic_a68_link);
1598        }
1599      }
1600    }
1601  }
1602  
1603  //! @brief Overview of the stack.
1604  
1605  void stack_a68_link_dump (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1606  {
1607    if (depth > 0 && a68_link > 0) {
1608      NODE_T *p = FRAME_TREE (a68_link);
1609      if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1610        show_stack_frame (f, p, a68_link, printed);
1611        stack_a68_link_dump (f, FRAME_STATIC_LINK (a68_link), depth - 1, printed);
1612      }
1613    }
1614  }
1615  
1616  //! @brief Overview of the stack.
1617  
1618  void stack_dump (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1619  {
1620    if (depth > 0 && a68_link > 0) {
1621      NODE_T *p = FRAME_TREE (a68_link);
1622      if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
1623        show_stack_frame (f, p, a68_link, printed);
1624        stack_dump (f, FRAME_DYNAMIC_LINK (a68_link), depth - 1, printed);
1625      }
1626    }
1627  }
1628  
1629  //! @brief Overview of the stack.
1630  
1631  void stack_trace (FILE_T f, ADDR_T a68_link, int depth, int *printed)
1632  {
1633    if (depth > 0 && a68_link > 0) {
1634      int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1635      if (FRAME_PROC_FRAME (a68_link)) {
1636        NODE_T *p = FRAME_TREE (a68_link);
1637        show_stack_frame (f, p, a68_link, printed);
1638        stack_trace (f, dynamic_a68_link, depth - 1, printed);
1639      } else {
1640        stack_trace (f, dynamic_a68_link, depth, printed);
1641      }
1642    }
1643  }
1644  
1645  //! @brief Examine tags.
1646  
1647  void examine_tags (FILE_T f, NODE_T * p, ADDR_T a68_link, TAG_T * q, char *sym, int *printed)
1648  {
1649    for (; q != NO_TAG; FORWARD (q)) {
1650      if (NODE (q) != NO_NODE && strcmp (NSYMBOL (NODE (q)), sym) == 0) {
1651        intro_frame (f, p, a68_link, printed);
1652        show_frame_item (f, p, a68_link, q, PRIO (q));
1653      }
1654    }
1655  }
1656  
1657  //! @brief Search symbol in stack.
1658  
1659  void examine_stack (FILE_T f, ADDR_T a68_link, char *sym, int *printed)
1660  {
1661    if (a68_link > 0) {
1662      int dynamic_a68_link = FRAME_DYNAMIC_LINK (a68_link);
1663      NODE_T *p = FRAME_TREE (a68_link);
1664      if (p != NO_NODE) {
1665        TABLE_T *q = TABLE (p);
1666        examine_tags (f, p, a68_link, IDENTIFIERS (q), sym, printed);
1667        examine_tags (f, p, a68_link, OPERATORS (q), sym, printed);
1668      }
1669      examine_stack (f, dynamic_a68_link, sym, printed);
1670    }
1671  }
1672  
1673  //! @brief Set or reset breakpoints.
1674  
1675  void change_breakpoints (NODE_T * p, unt set, int num, BOOL_T * is_set, char *loc_expr)
1676  {
1677    for (; p != NO_NODE; FORWARD (p)) {
1678      change_breakpoints (SUB (p), set, num, is_set, loc_expr);
1679      if (set == BREAKPOINT_MASK) {
1680        if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) {
1681          STATUS_SET (p, BREAKPOINT_MASK);
1682          if (EXPR (INFO (p)) != NO_TEXT) {
1683            a68_free (EXPR (INFO (p)));
1684          }
1685          EXPR (INFO (p)) = loc_expr;
1686          *is_set = A68_TRUE;
1687        }
1688      } else if (set == BREAKPOINT_TEMPORARY_MASK) {
1689        if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) {
1690          STATUS_SET (p, BREAKPOINT_TEMPORARY_MASK);
1691          if (EXPR (INFO (p)) != NO_TEXT) {
1692            a68_free (EXPR (INFO (p)));
1693          }
1694          EXPR (INFO (p)) = loc_expr;
1695          *is_set = A68_TRUE;
1696        }
1697      } else if (set == NULL_MASK) {
1698        if (LINE_NUMBER (p) != num) {
1699          STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK));
1700          if (EXPR (INFO (p)) == NO_TEXT) {
1701            a68_free (EXPR (INFO (p)));
1702          }
1703          EXPR (INFO (p)) = NO_TEXT;
1704        } else if (num == 0) {
1705          STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK));
1706          if (EXPR (INFO (p)) != NO_TEXT) {
1707            a68_free (EXPR (INFO (p)));
1708          }
1709          EXPR (INFO (p)) = NO_TEXT;
1710        }
1711      }
1712    }
1713  }
1714  
1715  //! @brief List breakpoints.
1716  
1717  void list_breakpoints (NODE_T * p, int *listed)
1718  {
1719    for (; p != NO_NODE; FORWARD (p)) {
1720      list_breakpoints (SUB (p), listed);
1721      if (STATUS_TEST (p, BREAKPOINT_MASK)) {
1722        (*listed)++;
1723        WIS (p);
1724        if (EXPR (INFO (p)) != NO_TEXT) {
1725          WRITELN (STDOUT_FILENO, "breakpoint condition \"");
1726          WRITE (STDOUT_FILENO, EXPR (INFO (p)));
1727          WRITE (STDOUT_FILENO, "\"");
1728        }
1729      }
1730    }
1731  }
1732  
1733  //! @brief Execute monitor command.
1734  
1735  BOOL_T single_stepper (NODE_T * p, char *cmd)
1736  {
1737    A68_MON (mon_errors) = 0;
1738    errno = 0;
1739    if (strlen (cmd) == 0) {
1740      return A68_FALSE;
1741    }
1742    while (IS_SPACE (cmd[strlen (cmd) - 1])) {
1743      cmd[strlen (cmd) - 1] = NULL_CHAR;
1744    }
1745    if (match_string (cmd, "CAlls", BLANK_CHAR)) {
1746      int k = get_num_arg (cmd, NO_VAR);
1747      int printed = 0;
1748      if (k > 0) {
1749        stack_trace (STDOUT_FILENO, A68_FP, k, &printed);
1750      } else if (k == 0) {
1751        stack_trace (STDOUT_FILENO, A68_FP, 3, &printed);
1752      }
1753      return A68_FALSE;
1754    } else if (match_string (cmd, "Continue", NULL_CHAR) || match_string (cmd, "Resume", NULL_CHAR)) {
1755      A68 (do_confirm_exit) = A68_TRUE;
1756      return A68_TRUE;
1757    } else if (match_string (cmd, "DO", BLANK_CHAR) || match_string (cmd, "EXEC", BLANK_CHAR)) {
1758      char *sym = cmd;
1759      SKIP_ONE_SYMBOL (sym);
1760      if (sym[0] != NULL_CHAR) {
1761        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "return code %d", system (sym)) >= 0);
1762        WRITELN (STDOUT_FILENO, A68 (output_line));
1763      }
1764      return A68_FALSE;
1765    } else if (match_string (cmd, "ELems", BLANK_CHAR)) {
1766      int k = get_num_arg (cmd, NO_VAR);
1767      if (k > 0) {
1768        A68_MON (max_row_elems) = k;
1769      }
1770      return A68_FALSE;
1771    } else if (match_string (cmd, "Evaluate", BLANK_CHAR) || match_string (cmd, "X", BLANK_CHAR)) {
1772      char *sym = cmd;
1773      SKIP_ONE_SYMBOL (sym);
1774      if (sym[0] != NULL_CHAR) {
1775        ADDR_T old_sp = A68_SP;
1776        evaluate (STDOUT_FILENO, p, sym);
1777        if (A68_MON (mon_errors) == 0 && A68_MON (_m_sp) > 0) {
1778          MOID_T *res;
1779          BOOL_T cont = A68_TRUE;
1780          while (cont) {
1781            res = A68_MON (_m_stack)[0];
1782            WRITELN (STDOUT_FILENO, "(");
1783            WRITE (STDOUT_FILENO, moid_to_string (res, MOID_WIDTH, NO_NODE));
1784            WRITE (STDOUT_FILENO, ")");
1785            show_item (STDOUT_FILENO, p, STACK_ADDRESS (old_sp), res);
1786            cont = (BOOL_T) (IS_REF (res) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (old_sp)));
1787            if (cont) {
1788              A68_REF z;
1789              POP_REF (p, &z);
1790              A68_MON (_m_stack)[0] = SUB (A68_MON (_m_stack)[0]);
1791              PUSH (p, ADDRESS (&z), SIZE (A68_MON (_m_stack)[0]));
1792            }
1793          }
1794        } else {
1795          monitor_error (CANNOT_SHOW, NO_TEXT);
1796        }
1797        A68_SP = old_sp;
1798        A68_MON (_m_sp) = 0;
1799      }
1800      return A68_FALSE;
1801    } else if (match_string (cmd, "EXamine", BLANK_CHAR)) {
1802      char *sym = cmd;
1803      SKIP_ONE_SYMBOL (sym);
1804      if (sym[0] != NULL_CHAR && (IS_LOWER (sym[0]) || IS_UPPER (sym[0]))) {
1805        int printed = 0;
1806        examine_stack (STDOUT_FILENO, A68_FP, sym, &printed);
1807        if (printed == 0) {
1808          monitor_error ("tag not found", sym);
1809        }
1810      } else {
1811        monitor_error ("tag expected", NO_TEXT);
1812      }
1813      return A68_FALSE;
1814    } else if (match_string (cmd, "EXIt", NULL_CHAR) || match_string (cmd, "HX", NULL_CHAR) || match_string (cmd, "Quit", NULL_CHAR) || strcmp (cmd, LOGOUT_STRING) == 0) {
1815      if (confirm_exit ()) {
1816        exit_genie (p, A68_RUNTIME_ERROR + A68_FORCE_QUIT);
1817      }
1818      return A68_FALSE;
1819    } else if (match_string (cmd, "Frame", NULL_CHAR)) {
1820      if (A68_MON (current_frame) == 0) {
1821        int printed = 0;
1822        stack_dump (STDOUT_FILENO, A68_FP, 1, &printed);
1823      } else {
1824        stack_dump_current (STDOUT_FILENO, A68_FP);
1825      }
1826      return A68_FALSE;
1827    } else if (match_string (cmd, "Frame", BLANK_CHAR)) {
1828      int n = get_num_arg (cmd, NO_VAR);
1829      A68_MON (current_frame) = (n > 0 ? n : 0);
1830      stack_dump_current (STDOUT_FILENO, A68_FP);
1831      return A68_FALSE;
1832    } else if (match_string (cmd, "HEAp", BLANK_CHAR)) {
1833      int top = get_num_arg (cmd, NO_VAR);
1834      if (top <= 0) {
1835        top = A68 (heap_size);
1836      }
1837      show_heap (STDOUT_FILENO, p, A68_GC (busy_handles), top, A68 (term_heigth) - 4);
1838      return A68_FALSE;
1839    } else if (match_string (cmd, "APropos", NULL_CHAR) || match_string (cmd, "Help", NULL_CHAR) || match_string (cmd, "INfo", NULL_CHAR)) {
1840      apropos (STDOUT_FILENO, NO_TEXT, "monitor");
1841      return A68_FALSE;
1842    } else if (match_string (cmd, "APropos", BLANK_CHAR) || match_string (cmd, "Help", BLANK_CHAR) || match_string (cmd, "INfo", BLANK_CHAR)) {
1843      char *sym = cmd;
1844      SKIP_ONE_SYMBOL (sym);
1845      apropos (STDOUT_FILENO, NO_TEXT, sym);
1846      return A68_FALSE;
1847    } else if (match_string (cmd, "HT", NULL_CHAR)) {
1848      A68 (halt_typing) = A68_TRUE;
1849      A68 (do_confirm_exit) = A68_TRUE;
1850      return A68_TRUE;
1851    } else if (match_string (cmd, "RT", NULL_CHAR)) {
1852      A68 (halt_typing) = A68_FALSE;
1853      A68 (do_confirm_exit) = A68_TRUE;
1854      return A68_TRUE;
1855    } else if (match_string (cmd, "Breakpoint", BLANK_CHAR)) {
1856      char *sym = cmd;
1857      SKIP_ONE_SYMBOL (sym);
1858      if (sym[0] == NULL_CHAR) {
1859        int listed = 0;
1860        list_breakpoints (TOP_NODE (&A68_JOB), &listed);
1861        if (listed == 0) {
1862          WRITELN (STDOUT_FILENO, "No breakpoints set");
1863        }
1864        if (A68_MON (watchpoint_expression) != NO_TEXT) {
1865          WRITELN (STDOUT_FILENO, "Watchpoint condition \"");
1866          WRITE (STDOUT_FILENO, A68_MON (watchpoint_expression));
1867          WRITE (STDOUT_FILENO, "\"");
1868        } else {
1869          WRITELN (STDOUT_FILENO, "No watchpoint expression set");
1870        }
1871      } else if (IS_DIGIT (sym[0])) {
1872        char *mod;
1873        int k = get_num_arg (cmd, &mod);
1874        SKIP_SPACE (mod);
1875        if (mod[0] == NULL_CHAR) {
1876          BOOL_T set = A68_FALSE;
1877          change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_MASK, k, &set, NULL);
1878          if (set == A68_FALSE) {
1879            monitor_error ("cannot set breakpoint in that line", NO_TEXT);
1880          }
1881        } else if (match_string (mod, "IF", BLANK_CHAR)) {
1882          char *cexpr = mod;
1883          BOOL_T set = A68_FALSE;
1884          SKIP_ONE_SYMBOL (cexpr);
1885          change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_MASK, k, &set, new_string (cexpr, NO_TEXT));
1886          if (set == A68_FALSE) {
1887            monitor_error ("cannot set breakpoint in that line", NO_TEXT);
1888          }
1889        } else if (match_string (mod, "Clear", NULL_CHAR)) {
1890          change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, k, NULL, NULL);
1891        } else {
1892          monitor_error ("invalid breakpoint command", NO_TEXT);
1893        }
1894      } else if (match_string (sym, "List", NULL_CHAR)) {
1895        int listed = 0;
1896        list_breakpoints (TOP_NODE (&A68_JOB), &listed);
1897        if (listed == 0) {
1898          WRITELN (STDOUT_FILENO, "No breakpoints set");
1899        }
1900        if (A68_MON (watchpoint_expression) != NO_TEXT) {
1901          WRITELN (STDOUT_FILENO, "Watchpoint condition \"");
1902          WRITE (STDOUT_FILENO, A68_MON (watchpoint_expression));
1903          WRITE (STDOUT_FILENO, "\"");
1904        } else {
1905          WRITELN (STDOUT_FILENO, "No watchpoint expression set");
1906        }
1907      } else if (match_string (sym, "Watch", BLANK_CHAR)) {
1908        char *cexpr = sym;
1909        SKIP_ONE_SYMBOL (cexpr);
1910        if (A68_MON (watchpoint_expression) != NO_TEXT) {
1911          a68_free (A68_MON (watchpoint_expression));
1912          A68_MON (watchpoint_expression) = NO_TEXT;
1913        }
1914        A68_MON (watchpoint_expression) = new_string (cexpr, NO_TEXT);
1915        change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_TRUE);
1916      } else if (match_string (sym, "Clear", BLANK_CHAR)) {
1917        char *mod = sym;
1918        SKIP_ONE_SYMBOL (mod);
1919        if (mod[0] == NULL_CHAR) {
1920          change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1921          if (A68_MON (watchpoint_expression) != NO_TEXT) {
1922            a68_free (A68_MON (watchpoint_expression));
1923            A68_MON (watchpoint_expression) = NO_TEXT;
1924          }
1925          change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1926        } else if (match_string (mod, "ALL", NULL_CHAR)) {
1927          change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1928          if (A68_MON (watchpoint_expression) != NO_TEXT) {
1929            a68_free (A68_MON (watchpoint_expression));
1930            A68_MON (watchpoint_expression) = NO_TEXT;
1931          }
1932          change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1933        } else if (match_string (mod, "Breakpoints", NULL_CHAR)) {
1934          change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1935        } else if (match_string (mod, "Watchpoint", NULL_CHAR)) {
1936          if (A68_MON (watchpoint_expression) != NO_TEXT) {
1937            a68_free (A68_MON (watchpoint_expression));
1938            A68_MON (watchpoint_expression) = NO_TEXT;
1939          }
1940          change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1941        } else {
1942          monitor_error ("invalid breakpoint command", NO_TEXT);
1943        }
1944      } else {
1945        monitor_error ("invalid breakpoint command", NO_TEXT);
1946      }
1947      return A68_FALSE;
1948    } else if (match_string (cmd, "List", BLANK_CHAR)) {
1949      char *cwhere;
1950      int n = get_num_arg (cmd, &cwhere);
1951      int m = get_num_arg (cwhere, NO_VAR);
1952      if (m == NOT_A_NUM) {
1953        if (n > 0) {
1954          list (STDOUT_FILENO, p, n, 0);
1955        } else if (n == NOT_A_NUM) {
1956          list (STDOUT_FILENO, p, 10, 0);
1957        }
1958      } else if (n > 0 && m > 0 && n <= m) {
1959        list (STDOUT_FILENO, p, n, m);
1960      }
1961      return A68_FALSE;
1962    } else if (match_string (cmd, "PROmpt", BLANK_CHAR)) {
1963      char *sym = cmd;
1964      SKIP_ONE_SYMBOL (sym);
1965      if (sym[0] != NULL_CHAR) {
1966        if (sym[0] == QUOTE_CHAR) {
1967          sym++;
1968        }
1969        if (sym[strlen (sym) - 1] == QUOTE_CHAR) {
1970          sym[strlen (sym) - 1] = NULL_CHAR;
1971        }
1972        bufcpy (A68_MON (prompt), sym, BUFFER_SIZE);
1973      }
1974      return A68_FALSE;
1975    } else if (match_string (cmd, "RERun", NULL_CHAR) || match_string (cmd, "REStart", NULL_CHAR)) {
1976      if (confirm_exit ()) {
1977        exit_genie (p, A68_RERUN);
1978      }
1979      return A68_FALSE;
1980    } else if (match_string (cmd, "RESET", NULL_CHAR)) {
1981      if (confirm_exit ()) {
1982        change_breakpoints (TOP_NODE (&A68_JOB), NULL_MASK, 0, NULL, NULL);
1983        if (A68_MON (watchpoint_expression) != NO_TEXT) {
1984          a68_free (A68_MON (watchpoint_expression));
1985          A68_MON (watchpoint_expression) = NO_TEXT;
1986        }
1987        change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_WATCH_MASK, A68_FALSE);
1988        exit_genie (p, A68_RERUN);
1989      }
1990      return A68_FALSE;
1991    } else if (match_string (cmd, "LINk", BLANK_CHAR)) {
1992      int k = get_num_arg (cmd, NO_VAR);
1993      int printed = 0;
1994      if (k > 0) {
1995        stack_a68_link_dump (STDOUT_FILENO, A68_FP, k, &printed);
1996      } else if (k == NOT_A_NUM) {
1997        stack_a68_link_dump (STDOUT_FILENO, A68_FP, 3, &printed);
1998      }
1999      return A68_FALSE;
2000    } else if (match_string (cmd, "STAck", BLANK_CHAR) || match_string (cmd, "BT", BLANK_CHAR)) {
2001      int k = get_num_arg (cmd, NO_VAR);
2002      int printed = 0;
2003      if (k > 0) {
2004        stack_dump (STDOUT_FILENO, A68_FP, k, &printed);
2005      } else if (k == NOT_A_NUM) {
2006        stack_dump (STDOUT_FILENO, A68_FP, 3, &printed);
2007      }
2008      return A68_FALSE;
2009    } else if (match_string (cmd, "Next", NULL_CHAR)) {
2010      change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
2011      A68 (do_confirm_exit) = A68_FALSE;
2012      A68_MON (break_proc_level) = PROCEDURE_LEVEL (INFO (p));
2013      return A68_TRUE;
2014    } else if (match_string (cmd, "STEp", NULL_CHAR)) {
2015      change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
2016      A68 (do_confirm_exit) = A68_FALSE;
2017      return A68_TRUE;
2018    } else if (match_string (cmd, "FINish", NULL_CHAR) || match_string (cmd, "OUT", NULL_CHAR)) {
2019      A68_MON (finish_frame_pointer) = FRAME_PARAMETERS (A68_FP);
2020      A68 (do_confirm_exit) = A68_FALSE;
2021      return A68_TRUE;
2022    } else if (match_string (cmd, "Until", BLANK_CHAR)) {
2023      int k = get_num_arg (cmd, NO_VAR);
2024      if (k > 0) {
2025        BOOL_T set = A68_FALSE;
2026        change_breakpoints (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, k, &set, NULL);
2027        if (set == A68_FALSE) {
2028          monitor_error ("cannot set breakpoint in that line", NO_TEXT);
2029          return A68_FALSE;
2030        }
2031        A68 (do_confirm_exit) = A68_FALSE;
2032        return A68_TRUE;
2033      } else {
2034        monitor_error ("line number expected", NO_TEXT);
2035        return A68_FALSE;
2036      }
2037    } else if (match_string (cmd, "Where", NULL_CHAR)) {
2038      WIS (p);
2039      return A68_FALSE;
2040    } else if (strcmp (cmd, "?") == 0) {
2041      apropos (STDOUT_FILENO, A68_MON (prompt), "monitor");
2042      return A68_FALSE;
2043    } else if (match_string (cmd, "Sizes", NULL_CHAR)) {
2044      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Frame stack pointer=" A68_LU " available=" A68_LU, A68_FP, A68 (frame_stack_size) - A68_FP) >= 0);
2045      WRITELN (STDOUT_FILENO, A68 (output_line));
2046      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Expression stack pointer=" A68_LU " available=" A68_LU, A68_SP, (UNSIGNED_T) (A68 (expr_stack_size) - A68_SP)) >= 0);
2047      WRITELN (STDOUT_FILENO, A68 (output_line));
2048      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Heap size=%u available=%u", A68 (heap_size), heap_available ()) >= 0);
2049      WRITELN (STDOUT_FILENO, A68 (output_line));
2050      ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Garbage collections=" A68_LD, A68_GC (sweeps)) >= 0);
2051      WRITELN (STDOUT_FILENO, A68 (output_line));
2052      return A68_FALSE;
2053    } else if (match_string (cmd, "XRef", NULL_CHAR)) {
2054      int k = LINE_NUMBER (p);
2055      LINE_T *line = TOP_LINE (&A68_JOB);
2056      for (; line != NO_LINE; FORWARD (line)) {
2057        if (NUMBER (line) > 0 && NUMBER (line) == k) {
2058          list_source_line (STDOUT_FILENO, line, A68_TRUE);
2059        }
2060      }
2061      return A68_FALSE;
2062    } else if (match_string (cmd, "XRef", BLANK_CHAR)) {
2063      LINE_T *line = TOP_LINE (&A68_JOB);
2064      int k = get_num_arg (cmd, NO_VAR);
2065      if (k == NOT_A_NUM) {
2066        monitor_error ("line number expected", NO_TEXT);
2067      } else {
2068        for (; line != NO_LINE; FORWARD (line)) {
2069          if (NUMBER (line) > 0 && NUMBER (line) == k) {
2070            list_source_line (STDOUT_FILENO, line, A68_TRUE);
2071          }
2072        }
2073      }
2074      return A68_FALSE;
2075    } else if (strlen (cmd) == 0) {
2076      return A68_FALSE;
2077    } else {
2078      monitor_error ("unrecognised command", NO_TEXT);
2079      return A68_FALSE;
2080    }
2081  }
2082  
2083  //! @brief Evaluate conditional breakpoint expression.
2084  
2085  BOOL_T evaluate_breakpoint_expression (NODE_T * p)
2086  {
2087    ADDR_T top_sp = A68_SP;
2088    volatile BOOL_T res = A68_FALSE;
2089    A68_MON (mon_errors) = 0;
2090    if (EXPR (INFO (p)) != NO_TEXT) {
2091      evaluate (STDOUT_FILENO, p, EXPR (INFO (p)));
2092      if (A68_MON (_m_sp) != 1 || A68_MON (mon_errors) != 0) {
2093        A68_MON (mon_errors) = 0;
2094        monitor_error ("deleted invalid breakpoint expression", NO_TEXT);
2095        if (EXPR (INFO (p)) != NO_TEXT) {
2096          a68_free (EXPR (INFO (p)));
2097        }
2098        EXPR (INFO (p)) = A68_MON (expr);
2099        res = A68_TRUE;
2100      } else if (TOP_MODE == M_BOOL) {
2101        A68_BOOL z;
2102        POP_OBJECT (p, &z, A68_BOOL);
2103        res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE);
2104      } else {
2105        monitor_error ("deleted invalid breakpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
2106        if (EXPR (INFO (p)) != NO_TEXT) {
2107          a68_free (EXPR (INFO (p)));
2108        }
2109        EXPR (INFO (p)) = A68_MON (expr);
2110        res = A68_TRUE;
2111      }
2112    }
2113    A68_SP = top_sp;
2114    return res;
2115  }
2116  
2117  //! @brief Evaluate conditional watchpoint expression.
2118  
2119  BOOL_T evaluate_watchpoint_expression (NODE_T * p)
2120  {
2121    ADDR_T top_sp = A68_SP;
2122    volatile BOOL_T res = A68_FALSE;
2123    A68_MON (mon_errors) = 0;
2124    if (A68_MON (watchpoint_expression) != NO_TEXT) {
2125      evaluate (STDOUT_FILENO, p, A68_MON (watchpoint_expression));
2126      if (A68_MON (_m_sp) != 1 || A68_MON (mon_errors) != 0) {
2127        A68_MON (mon_errors) = 0;
2128        monitor_error ("deleted invalid watchpoint expression", NO_TEXT);
2129        if (A68_MON (watchpoint_expression) != NO_TEXT) {
2130          a68_free (A68_MON (watchpoint_expression));
2131          A68_MON (watchpoint_expression) = NO_TEXT;
2132        }
2133        res = A68_TRUE;
2134      }
2135      if (TOP_MODE == M_BOOL) {
2136        A68_BOOL z;
2137        POP_OBJECT (p, &z, A68_BOOL);
2138        res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE);
2139      } else {
2140        monitor_error ("deleted invalid watchpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
2141        if (A68_MON (watchpoint_expression) != NO_TEXT) {
2142          a68_free (A68_MON (watchpoint_expression));
2143          A68_MON (watchpoint_expression) = NO_TEXT;
2144        }
2145        res = A68_TRUE;
2146      }
2147    }
2148    A68_SP = top_sp;
2149    return res;
2150  }
2151  
2152  //! @brief Execute monitor.
2153  
2154  void single_step (NODE_T * p, unt mask)
2155  {
2156    volatile BOOL_T do_cmd = A68_TRUE;
2157    ADDR_T top_sp = A68_SP;
2158    A68_MON (current_frame) = 0;
2159    A68_MON (max_row_elems) = MAX_ROW_ELEMS;
2160    A68_MON (mon_errors) = 0;
2161    A68_MON (tabs) = 0;
2162    A68_MON (prompt_set) = A68_FALSE;
2163    if (LINE_NUMBER (p) == 0) {
2164      return;
2165    }
2166  #if defined (HAVE_CURSES)
2167    genie_curses_end (NO_NODE);
2168  #endif
2169    if (mask == (unt) BREAKPOINT_ERROR_MASK) {
2170      WRITELN (STDOUT_FILENO, "Monitor entered after an error");
2171      WIS ((p));
2172    } else if ((mask & BREAKPOINT_INTERRUPT_MASK) != 0) {
2173      WRITELN (STDOUT_FILENO, NEWLINE_STRING);
2174      WIS ((p));
2175      if (A68 (do_confirm_exit) && confirm_exit ()) {
2176        exit_genie ((p), A68_RUNTIME_ERROR + A68_FORCE_QUIT);
2177      }
2178    } else if ((mask & BREAKPOINT_MASK) != 0) {
2179      if (EXPR (INFO (p)) != NO_TEXT) {
2180        if (!evaluate_breakpoint_expression (p)) {
2181          return;
2182        }
2183        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Breakpoint (%s)", EXPR (INFO (p))) >= 0);
2184      } else {
2185        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Breakpoint") >= 0);
2186      }
2187      WRITELN (STDOUT_FILENO, A68 (output_line));
2188      WIS (p);
2189    } else if ((mask & BREAKPOINT_TEMPORARY_MASK) != 0) {
2190      if (A68_MON (break_proc_level) != 0 && PROCEDURE_LEVEL (INFO (p)) > A68_MON (break_proc_level)) {
2191        return;
2192      }
2193      change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_FALSE);
2194      WRITELN (STDOUT_FILENO, "Temporary breakpoint (now removed)");
2195      WIS (p);
2196    } else if ((mask & BREAKPOINT_WATCH_MASK) != 0) {
2197      if (!evaluate_watchpoint_expression (p)) {
2198        return;
2199      }
2200      if (A68_MON (watchpoint_expression) != NO_TEXT) {
2201        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Watchpoint (%s)", A68_MON (watchpoint_expression)) >= 0);
2202      } else {
2203        ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "Watchpoint (now removed)") >= 0);
2204      }
2205      WRITELN (STDOUT_FILENO, A68 (output_line));
2206      WIS (p);
2207    } else if ((mask & BREAKPOINT_TRACE_MASK) != 0) {
2208      PROP_T *prop = &GPROP (p);
2209      WIS ((p));
2210      if (propagator_name (UNIT (prop)) != NO_TEXT) {
2211        WRITELN (STDOUT_FILENO, propagator_name (UNIT (prop)));
2212      }
2213      return;
2214    } else {
2215      WRITELN (STDOUT_FILENO, "Monitor entered with no valid reason (continuing execution)");
2216      WIS ((p));
2217      return;
2218    }
2219  #if defined (BUILD_PARALLEL_CLAUSE)
2220    if (is_main_thread ()) {
2221      WRITELN (STDOUT_FILENO, "This is the main thread");
2222    } else {
2223      WRITELN (STDOUT_FILENO, "This is not the main thread");
2224    }
2225  #endif
2226  // Entry into the monitor.
2227    if (A68_MON (prompt_set) == A68_FALSE) {
2228      bufcpy (A68_MON (prompt), "(a68g) ", BUFFER_SIZE);
2229      A68_MON (prompt_set) = A68_TRUE;
2230    }
2231    A68_MON (in_monitor) = A68_TRUE;
2232    A68_MON (break_proc_level) = 0;
2233    change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE);
2234    STATUS_CLEAR (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK);
2235    while (do_cmd) {
2236      char *cmd;
2237      A68_SP = top_sp;
2238      io_close_tty_line ();
2239      while (strlen (cmd = read_string_from_tty (A68_MON (prompt))) == 0) {;
2240      }
2241      if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) {
2242        bufcpy (cmd, LOGOUT_STRING, BUFFER_SIZE);
2243        WRITE (STDOUT_FILENO, LOGOUT_STRING);
2244        WRITE (STDOUT_FILENO, NEWLINE_STRING);
2245      }
2246      A68_MON (_m_sp) = 0;
2247      do_cmd = (BOOL_T) (!single_stepper (p, cmd));
2248    }
2249    A68_SP = top_sp;
2250    A68_MON (in_monitor) = A68_FALSE;
2251    if (mask == (unt) BREAKPOINT_ERROR_MASK) {
2252      WRITELN (STDOUT_FILENO, "Continuing from an error might corrupt things");
2253      single_step (p, (unt) BREAKPOINT_ERROR_MASK);
2254    } else {
2255      WRITELN (STDOUT_FILENO, "Continuing ...");
2256      WRITELN (STDOUT_FILENO, "");
2257    }
2258  }
2259  
2260  //! @brief PROC debug = VOID
2261  
2262  void genie_debug (NODE_T * p)
2263  {
2264    single_step (p, BREAKPOINT_INTERRUPT_MASK);
2265  }
2266  
2267  //! @brief PROC break = VOID
2268  
2269  void genie_break (NODE_T * p)
2270  {
2271    (void) p;
2272    change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
2273  }
2274  
2275  //! @brief PROC evaluate = (STRING) STRING
2276  
2277  void genie_evaluate (NODE_T * p)
2278  {
2279    A68_REF u, v;
2280    v = empty_string (p);
2281  // Pop argument.
2282    POP_REF (p, (A68_REF *) & u);
2283    volatile ADDR_T top_sp = A68_SP;
2284    CHECK_MON_REF (p, u, M_STRING);
2285    reset_transput_buffer (UNFORMATTED_BUFFER);
2286    add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u);
2287    v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
2288  // Evaluate in the monitor.
2289    A68_MON (in_monitor) = A68_TRUE;
2290    A68_MON (mon_errors) = 0;
2291    evaluate (STDOUT_FILENO, p, get_transput_buffer (UNFORMATTED_BUFFER));
2292    A68_MON (in_monitor) = A68_FALSE;
2293    if (A68_MON (_m_sp) != 1) {
2294      monitor_error ("invalid expression", NO_TEXT);
2295    }
2296    if (A68_MON (mon_errors) == 0) {
2297      MOID_T *res;
2298      BOOL_T cont = A68_TRUE;
2299      while (cont) {
2300        res = TOP_MODE;
2301        cont = (BOOL_T) (IS_REF (res) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (top_sp)));
2302        if (cont) {
2303          A68_REF w;
2304          POP_REF (p, &w);
2305          TOP_MODE = SUB (TOP_MODE);
2306          PUSH (p, ADDRESS (&w), SIZE (TOP_MODE));
2307        }
2308      }
2309      reset_transput_buffer (UNFORMATTED_BUFFER);
2310      genie_write_standard (p, TOP_MODE, STACK_ADDRESS (top_sp), nil_ref);
2311      v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
2312    }
2313    A68_SP = top_sp;
2314    PUSH_REF (p, v);
2315  }
2316  
2317  //! @brief PROC abend = (STRING) VOID
2318  
2319  void genie_abend (NODE_T * p)
2320  {
2321    A68_REF u;
2322    POP_REF (p, (A68_REF *) & u);
2323    reset_transput_buffer (UNFORMATTED_BUFFER);
2324    add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u);
2325    diagnostic (A68_RUNTIME_ERROR | A68_NO_SYNTHESIS, p, get_transput_buffer (UNFORMATTED_BUFFER), NO_TEXT);
2326    exit_genie (p, A68_RUNTIME_ERROR);
2327  }