//! @file monitor.c
//! @author J. Marcel van der Veer

//! @section Copyright
//!
//! This file is part of Algol68G - an Algol 68 compiler-interpreter.
//! Copyright 2001-2026 J. Marcel van der Veer [algol68g@algol68genie.nl].

//! @section License
//!
//! This program is free software; you can redistribute it and/or modify it 
//! under the terms of the GNU General Public License as published by the 
//! Free Software Foundation; either version 3 of the License, or 
//! (at your option) any later version.
//!
//! This program is distributed in the hope that it will be useful, but 
//! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
//! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
//! more details. You should have received a copy of the GNU General Public 
//! License along with this program. If not, see [http://www.gnu.org/licenses/].

//! @section Synopsis
//!
//! GDB-style monitor for the interpreter.

// This is a basic monitor for Algol68G. It activates when the interpreter
// receives SIGINT (CTRL-C, for instance) or when PROC VOID break, debug or
// evaluate is called, or when a runtime error occurs and --debug is selected.
// The monitor allows single stepping (unit-wise through serial/enquiry
// clauses) and has basic means for inspecting call-frame stack and heap. 

// breakpoint clear [all], clear breakpoints and watchpoint expression.
// breakpoint clear breakpoints, clear breakpoints.
// breakpoint clear watchpoint, clear watchpoint expression.
// breakpoint [list], list breakpoints.
// breakpoint 'n' clear, clear breakpoints in line 'n'.
// breakpoint 'n' if 'expression', break in line 'n' when expression evaluates to true.
// breakpoint 'n', set breakpoints in line 'n'.
// breakpoint watch 'expression', break on watchpoint expression when it evaluates to true.
// calls [n], print 'n' frames in the call stack (default n=3).
// continue, resume, continue execution.
// do 'command', exec 'command', pass 'command' to the shell and print return code.
// elems [n], print first 'n' elements of rows (default n=24).
// evaluate 'expression', x 'expression', print result of 'expression'.
// examine 'n', print value of symbols named 'n' in the call stack.
// exit, hx, quit, terminates the program.
// finish, out, continue execution until current procedure incarnation is finished.
// frame 0, set current stack frame to top of frame stack.
// frame 'n', set current stack frame to 'n'.
// frame, print contents of the current stack frame.
// heap 'n', print contents of the heap with address not greater than 'n'.
// help [expression], print brief help text.
// ht, halts typing to standard output.
// list [n], show 'n' lines around the interrupted line (default n=10).
// next, continue execution to next interruptable unit (do not enter routine-texts).
// prompt 's', set prompt to 's'.
// rerun, restart, restarts a program without resetting breakpoints.
// reset, restarts a program and resets breakpoints.
// rt, resumes typing to standard output.
// sizes, print size of memory segments.
// stack [n], print 'n' frames in the stack (default n=3).
// step, continue execution to next interruptable unit.
// until 'n', continue execution until line number 'n' is reached.
// where, print the interrupted line.
// xref 'n', give detailed information on source line 'n'.

#include "a68g.h"
#include "a68g-genie.h"
#include "a68g-frames.h"
#include "a68g-prelude.h"
#include "a68g-mp.h"
#include "a68g-transput.h"
#include "a68g-parser.h"
#include "a68g-listing.h"

#define CANNOT_SHOW " unprintable or uninitialised value"
#define MAX_ROW_ELEMS 24
#define NOT_A_NUM (-1)
#define NO_VALUE " uninitialised value"
#define TOP_MODE (A68G_MON (_m_stack)[A68G_MON (_m_sp) - 1])
#define LOGOUT_STRING "exit"

void parse (FILE_T, NODE_T *, int);

BOOL_T check_initialisation (NODE_T *, BYTE_T *, MOID_T *, BOOL_T *);

#define SKIP_ONE_SYMBOL(sym) {\
  while (!IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
    (sym)++;\
  }\
  while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
    (sym)++;\
  }}

#define SKIP_SPACE(sym) {\
  while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\
    (sym)++;\
  }}

#define CHECK_MON_REF(p, z, m)\
  if (! INITIALISED (&z)) {\
    ASSERT (a68g_bufprt (A68G (edit_line), SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\
    monitor_error (NO_VALUE, A68G (edit_line));\
    QUIT_ON_ERROR;\
  } else if (IS_NIL (z)) {\
    ASSERT (a68g_bufprt (A68G (edit_line), SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\
    monitor_error ("accessing NIL name", A68G (edit_line));\
    QUIT_ON_ERROR;\
  }

#define QUIT_ON_ERROR\
  if (A68G_MON (mon_errors) > 0) {\
    return;\
  }

#define PARSE_CHECK(f, p, d)\
  parse ((f), (p), (d));\
  QUIT_ON_ERROR;

#define SCAN_CHECK(f, p)\
  scan_sym((f), (p));\
  QUIT_ON_ERROR;

//! @brief Confirm that we really want to quit.

BOOL_T confirm_exit (void)
{
  peek_char (A68G_PEEK_RESET);
  ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Terminate %s (yes|no): ", A68G (a68g_cmd_name)) >= 0);
  WRITELN (A68G_STDOUT, A68G (output_line));
  char *cmd = read_string_from_tty (NULL);
  if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) {
    return confirm_exit ();
  }
  for (int k = 0; cmd[k] != NULL_CHAR; k++) {
    cmd[k] = (char) TO_LOWER (cmd[k]);
  }
  if (strcmp (cmd, "y") == 0) {
    return A68G_TRUE;
  }
  if (strcmp (cmd, "yes") == 0) {
    return A68G_TRUE;
  }
  if (strcmp (cmd, "n") == 0) {
    return A68G_FALSE;
  }
  if (strcmp (cmd, "no") == 0) {
    return A68G_FALSE;
  }
  return confirm_exit ();
}

//! @brief Give a monitor error message.

void monitor_error (char *msg, char *info)
{
  QUIT_ON_ERROR;
  A68G_MON (mon_errors)++;
  a68g_bufcpy (A68G_MON (error_text), msg, BUFFER_SIZE);
  WRITELN (A68G_STDOUT, A68G (a68g_cmd_name));
  WRITE (A68G_STDOUT, ": monitor error: ");
  WRITE (A68G_STDOUT, A68G_MON (error_text));
  if (info != NO_TEXT) {
    WRITE (A68G_STDOUT, " (");
    WRITE (A68G_STDOUT, info);
    WRITE (A68G_STDOUT, ")");
  }
  WRITE (A68G_STDOUT, ".");
}

//! @brief Scan symbol from input.

void scan_sym (FILE_T f, NODE_T * p)
{
  (void) f;
  (void) p;
  A68G_MON (symbol)[0] = NULL_CHAR;
  A68G_MON (attr) = 0;
  QUIT_ON_ERROR;
  while (IS_SPACE (A68G_MON (expr)[A68G_MON (pos)])) {
    A68G_MON (pos)++;
  }
  if (A68G_MON (expr)[A68G_MON (pos)] == NULL_CHAR) {
    A68G_MON (attr) = 0;
    A68G_MON (symbol)[0] = NULL_CHAR;
    return;
  } else if (A68G_MON (expr)[A68G_MON (pos)] == ':') {
    if (strncmp (&(A68G_MON (expr)[A68G_MON (pos)]), ":=:", 3) == 0) {
      A68G_MON (pos) += 3;
      a68g_bufcpy (A68G_MON (symbol), ":=:", BUFFER_SIZE);
      A68G_MON (attr) = IS_SYMBOL;
    } else if (strncmp (&(A68G_MON (expr)[A68G_MON (pos)]), ":/=:", 4) == 0) {
      A68G_MON (pos) += 4;
      a68g_bufcpy (A68G_MON (symbol), ":/=:", BUFFER_SIZE);
      A68G_MON (attr) = ISNT_SYMBOL;
    } else if (strncmp (&(A68G_MON (expr)[A68G_MON (pos)]), ":=", 2) == 0) {
      A68G_MON (pos) += 2;
      a68g_bufcpy (A68G_MON (symbol), ":=", BUFFER_SIZE);
      A68G_MON (attr) = ASSIGN_SYMBOL;
    } else {
      A68G_MON (pos)++;
      a68g_bufcpy (A68G_MON (symbol), ":", BUFFER_SIZE);
      A68G_MON (attr) = COLON_SYMBOL;
    }
    return;
  } else if (A68G_MON (expr)[A68G_MON (pos)] == QUOTE_CHAR) {
    A68G_MON (pos)++;
    BOOL_T cont = A68G_TRUE; int k = 0;
    while (cont) {
      while (A68G_MON (expr)[A68G_MON (pos)] != QUOTE_CHAR) {
        A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      }
      if (A68G_MON (expr)[++A68G_MON (pos)] == QUOTE_CHAR) {
        A68G_MON (symbol)[k++] = QUOTE_CHAR;
      } else {
        cont = A68G_FALSE;
      }
    }
    A68G_MON (symbol)[k] = NULL_CHAR;
    A68G_MON (attr) = ROW_CHAR_DENOTATION;
    return;
  } else if (IS_LOWER (A68G_MON (expr)[A68G_MON (pos)])) {
    int k = 0;
    while (IS_LOWER (A68G_MON (expr)[A68G_MON (pos)]) || IS_DIGIT (A68G_MON (expr)[A68G_MON (pos)]) || IS_SPACE (A68G_MON (expr)[A68G_MON (pos)])) {
      if (IS_SPACE (A68G_MON (expr)[A68G_MON (pos)])) {
        A68G_MON (pos)++;
      } else {
        A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      }
    }
    A68G_MON (symbol)[k] = NULL_CHAR;
    A68G_MON (attr) = IDENTIFIER;
    return;
  } else if (IS_UPPER (A68G_MON (expr)[A68G_MON (pos)])) {
    KEYWORD_T *kw; int k = 0;
    while (IS_UPPER (A68G_MON (expr)[A68G_MON (pos)])) {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
    }
    A68G_MON (symbol)[k] = NULL_CHAR;
    kw = find_keyword (A68G (top_keyword), A68G_MON (symbol));
    if (kw != NO_KEYWORD) {
      A68G_MON (attr) = ATTRIBUTE (kw);
    } else {
      A68G_MON (attr) = OPERATOR;
    }
    return;
  } else if (IS_DIGIT (A68G_MON (expr)[A68G_MON (pos)])) {
    int k = 0;
    while (IS_DIGIT (A68G_MON (expr)[A68G_MON (pos)])) {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
    }
    if (A68G_MON (expr)[A68G_MON (pos)] == 'r') {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      while (IS_XDIGIT (A68G_MON (expr)[A68G_MON (pos)])) {
        A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      }
      A68G_MON (symbol)[k] = NULL_CHAR;
      A68G_MON (attr) = BITS_DENOTATION;
      return;
    }
    if (A68G_MON (expr)[A68G_MON (pos)] != POINT_CHAR && A68G_MON (expr)[A68G_MON (pos)] != 'e' && A68G_MON (expr)[A68G_MON (pos)] != 'E') {
      A68G_MON (symbol)[k] = NULL_CHAR;
      A68G_MON (attr) = INT_DENOTATION;
      return;
    }
    if (A68G_MON (expr)[A68G_MON (pos)] == POINT_CHAR) {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      while (IS_DIGIT (A68G_MON (expr)[A68G_MON (pos)])) {
        A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      }
    }
    if (A68G_MON (expr)[A68G_MON (pos)] != 'e' && A68G_MON (expr)[A68G_MON (pos)] != 'E') {
      A68G_MON (symbol)[k] = NULL_CHAR;
      A68G_MON (attr) = REAL_DENOTATION;
      return;
    }
    A68G_MON (symbol)[k++] = (char) TO_UPPER (A68G_MON (expr)[A68G_MON (pos)++]);
    if (A68G_MON (expr)[A68G_MON (pos)] == '+' || A68G_MON (expr)[A68G_MON (pos)] == '-') {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
    }
    while (IS_DIGIT (A68G_MON (expr)[A68G_MON (pos)])) {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
    }
    A68G_MON (symbol)[k] = NULL_CHAR;
    A68G_MON (attr) = REAL_DENOTATION;
    return;
  } else if (strchr (MONADS, A68G_MON (expr)[A68G_MON (pos)]) != NO_TEXT || strchr (NOMADS, A68G_MON (expr)[A68G_MON (pos)]) != NO_TEXT) {
    int k = 0;
    A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
    if (strchr (NOMADS, A68G_MON (expr)[A68G_MON (pos)]) != NO_TEXT) {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
    }
    if (A68G_MON (expr)[A68G_MON (pos)] == ':') {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      if (A68G_MON (expr)[A68G_MON (pos)] == '=') {
        A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      } else {
        A68G_MON (symbol)[k] = NULL_CHAR;
        monitor_error ("invalid operator symbol", A68G_MON (symbol));
      }
    } else if (A68G_MON (expr)[A68G_MON (pos)] == '=') {
      A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      if (A68G_MON (expr)[A68G_MON (pos)] == ':') {
        A68G_MON (symbol)[k++] = A68G_MON (expr)[A68G_MON (pos)++];
      } else {
        A68G_MON (symbol)[k] = NULL_CHAR;
        monitor_error ("invalid operator symbol", A68G_MON (symbol));
      }
    }
    A68G_MON (symbol)[k] = NULL_CHAR;
    A68G_MON (attr) = OPERATOR;
    return;
  } else if (A68G_MON (expr)[A68G_MON (pos)] == '(') {
    A68G_MON (pos)++;
    A68G_MON (attr) = OPEN_SYMBOL;
    return;
  } else if (A68G_MON (expr)[A68G_MON (pos)] == ')') {
    A68G_MON (pos)++;
    A68G_MON (attr) = CLOSE_SYMBOL;
    return;
  } else if (A68G_MON (expr)[A68G_MON (pos)] == '[') {
    A68G_MON (pos)++;
    A68G_MON (attr) = SUB_SYMBOL;
    return;
  } else if (A68G_MON (expr)[A68G_MON (pos)] == ']') {
    A68G_MON (pos)++;
    A68G_MON (attr) = BUS_SYMBOL;
    return;
  } else if (A68G_MON (expr)[A68G_MON (pos)] == ',') {
    A68G_MON (pos)++;
    A68G_MON (attr) = COMMA_SYMBOL;
    return;
  } else if (A68G_MON (expr)[A68G_MON (pos)] == ';') {
    A68G_MON (pos)++;
    A68G_MON (attr) = SEMI_SYMBOL;
    return;
  }
}

//! @brief Find a tag, searching symbol tables towards the root.

TAG_T *find_tag (TABLE_T * table, int a, char *name)
{
  if (table != NO_TABLE) {
    TAG_T *s = NO_TAG;
    if (a == OP_SYMBOL) {
      s = OPERATORS (table);
    } else if (a == PRIO_SYMBOL) {
      s = PRIO (table);
    } else if (a == IDENTIFIER) {
      s = IDENTIFIERS (table);
    } else if (a == INDICANT) {
      s = INDICANTS (table);
    } else if (a == LABEL) {
      s = LABELS (table);
    } else {
      ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
    }
    for (; s != NO_TAG; FORWARD (s)) {
      if (strcmp (NSYMBOL (NODE (s)), name) == 0) {
        return s;
      }
    }
    return find_tag_global (PREVIOUS (table), a, name);
  } else {
    return NO_TAG;
  }
}

//! @brief Priority for symbol at input.

int prio (FILE_T f, NODE_T * p)
{
  (void) p;
  (void) f;
  TAG_T *s = find_tag (A68G_STANDENV, PRIO_SYMBOL, A68G_MON (symbol));
  if (s == NO_TAG) {
    monitor_error ("unknown operator, cannot set priority", A68G_MON (symbol));
    return 0;
  }
  return PRIO (s);
}

//! @brief Push a mode on the stack.

void push_mode (FILE_T f, MOID_T * m)
{
  (void) f;
  if (A68G_MON (_m_sp) < MON_STACK_SIZE) {
    A68G_MON (_m_stack)[A68G_MON (_m_sp)++] = m;
  } else {
    monitor_error ("expression too complex", NO_TEXT);
  }
}

//! @brief Dereference, WEAK or otherwise.

BOOL_T deref_condition (int k, int context)
{
  MOID_T *u = A68G_MON (_m_stack)[k];
  if (context == WEAK && SUB (u) != NO_MOID) {
    MOID_T *v = SUB (u);
    BOOL_T stowed = (BOOL_T) (IS_FLEX (v) || IS_ROW (v) || IS_STRUCT (v));
    return (BOOL_T) (IS_REF (u) && !stowed);
  } else {
    return (BOOL_T) (IS_REF (u));
  }
}

//! @brief Weak dereferencing.

void deref (NODE_T * p, int k, int context)
{
  while (deref_condition (k, context)) {
    A68G_REF z;
    POP_REF (p, &z);
    CHECK_MON_REF (p, z, A68G_MON (_m_stack)[k]);
    A68G_MON (_m_stack)[k] = SUB (A68G_MON (_m_stack)[k]);
    PUSH (p, ADDRESS (&z), SIZE (A68G_MON (_m_stack)[k]));
  }
}

//! @brief Search moid that matches indicant.

MOID_T *search_mode (int refs, int leng, char *indy)
{
  MOID_T *z = NO_MOID;
  for (MOID_T *m = TOP_MOID (&A68G_JOB); m != NO_MOID; FORWARD (m)) {
    if (NODE (m) != NO_NODE) {
      if (indy == NSYMBOL (NODE (m)) && leng == DIM (m)) {
        z = m;
        while (EQUIVALENT (z) != NO_MOID) {
          z = EQUIVALENT (z);
        }
      }
    }
  }
  if (z == NO_MOID) {
    monitor_error ("unknown indicant", indy);
    return NO_MOID;
  }
  for (MOID_T *m = TOP_MOID (&A68G_JOB); m != NO_MOID; FORWARD (m)) {
    int k = 0;
    while (IS_REF (m)) {
      k++;
      m = SUB (m);
    }
    if (k == refs && m == z) {
      while (EQUIVALENT (z) != NO_MOID) {
        z = EQUIVALENT (z);
      }
      return z;
    }
  }
  return NO_MOID;
}

//! @brief Search operator X SYM Y.

TAG_T *search_operator (char *sym, MOID_T * x, MOID_T * y)
{
  for (TAG_T *t = OPERATORS (A68G_STANDENV); t != NO_TAG; FORWARD (t)) {
    if (strcmp (NSYMBOL (NODE (t)), sym) == 0) {
      PACK_T *p = PACK (MOID (t));
      if (x == MOID (p)) {
        FORWARD (p);
        if (p == NO_PACK && y == NO_MOID) {
// Matched in case of a monad.
          return t;
        } else if (p != NO_PACK && y != NO_MOID && y == MOID (p)) {
// Matched in case of a nomad.
          return t;
        }
      }
    }
  }
// Not found yet, try dereferencing.
  if (IS_REF (x)) {
    return search_operator (sym, SUB (x), y);
  }
  if (y != NO_MOID && IS_REF (y)) {
    return search_operator (sym, x, SUB (y));
  }
// Not found. Grrrr. Give a message.
  if (y == NO_MOID) {
    ASSERT (a68g_bufprt (A68G (edit_line), SNPRINTF_SIZE, "%s %s", sym, moid_to_string (x, MOID_WIDTH, NO_NODE)) >= 0);
  } else {
    ASSERT (a68g_bufprt (A68G (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);
  }
  monitor_error ("cannot find operator in standard environ", A68G (edit_line));
  return NO_TAG;
}

//! @brief Search identifier in frame stack and push value.

void search_identifier (FILE_T f, NODE_T * p, ADDR_T a68g_link, char *sym)
{
  if (a68g_link > 0) {
    int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link);
    if (A68G_MON (current_frame) == 0 || (A68G_MON (current_frame) == FRAME_NUMBER (a68g_link))) {
      NODE_T *u = FRAME_TREE (a68g_link);
      if (u != NO_NODE) {
        TABLE_T *q = TABLE (u);
        for (TAG_T *i = IDENTIFIERS (q); i != NO_TAG; FORWARD (i)) {
          if (strcmp (NSYMBOL (NODE (i)), sym) == 0) {
            ADDR_T posit = a68g_link + FRAME_INFO_SIZE + OFFSET (i);
            MOID_T *m = MOID (i);
            PUSH (p, FRAME_ADDRESS (posit), SIZE (m));
            push_mode (f, m);
            return;
          }
        }
      }
    }
    search_identifier (f, p, dynamic_a68g_link, sym);
  } else {
    TABLE_T *q = A68G_STANDENV;
    for (TAG_T *i = IDENTIFIERS (q); i != NO_TAG; FORWARD (i)) {
      if (strcmp (NSYMBOL (NODE (i)), sym) == 0) {
        if (IS (MOID (i), PROC_SYMBOL)) {
          static A68G_PROCEDURE z;
          STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | STANDENV_PROC_MASK);
          PROCEDURE (&(BODY (&z))) = PROCEDURE (i);
          ENVIRON (&z) = 0;
          LOCALE (&z) = NO_HANDLE;
          MOID (&z) = MOID (i);
          PUSH_PROCEDURE (p, z);
        } else {
          NODE_T tmp = *p;
          MOID (&tmp) = MOID (i); // MP routines consult mode from node.
          (*(PROCEDURE (i))) (&tmp);
        }
        push_mode (f, MOID (i));
        return;
      }
    }
    monitor_error ("cannot find identifier", sym);
  }
}

//! @brief Coerce arguments in a call.

void coerce_arguments (FILE_T f, NODE_T * p, MOID_T * proc, int bot, int top, int top_sp)
{
  (void) f;
  if ((top - bot) != DIM (proc)) {
    monitor_error ("invalid procedure argument count", NO_TEXT);
  }
  QUIT_ON_ERROR;
  ADDR_T pop_sp = top_sp;
  PACK_T *u = PACK (proc);
  for (int k = bot; k < top; k++, FORWARD (u)) {
    if (A68G_MON (_m_stack)[k] == MOID (u)) {
      PUSH (p, STACK_ADDRESS (pop_sp), SIZE (MOID (u)));
      pop_sp += SIZE (MOID (u));
    } else if (IS_REF (A68G_MON (_m_stack)[k])) {
      A68G_REF *v = (A68G_REF *) STACK_ADDRESS (pop_sp);
      PUSH_REF (p, *v);
      pop_sp += A68G_REF_SIZE;
      deref (p, k, STRONG);
      if (A68G_MON (_m_stack)[k] != MOID (u)) {
        ASSERT (a68g_bufprt (A68G (edit_line), SNPRINTF_SIZE, "%s to %s", moid_to_string (A68G_MON (_m_stack)[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0);
        monitor_error ("invalid argument mode", A68G (edit_line));
      }
    } else {
      ASSERT (a68g_bufprt (A68G (edit_line), SNPRINTF_SIZE, "%s to %s", moid_to_string (A68G_MON (_m_stack)[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0);
      monitor_error ("cannot coerce argument", A68G (edit_line));
    }
    QUIT_ON_ERROR;
  }
  MOVE (STACK_ADDRESS (top_sp), STACK_ADDRESS (pop_sp), A68G_SP - pop_sp);
  A68G_SP = top_sp + (A68G_SP - pop_sp);
}

//! @brief Perform a selection.

void selection (FILE_T f, NODE_T * p, char *field)
{
  SCAN_CHECK (f, p);
  if (A68G_MON (attr) != IDENTIFIER && A68G_MON (attr) != OPEN_SYMBOL) {
    monitor_error ("invalid selection syntax", NO_TEXT);
  }
  QUIT_ON_ERROR;
  PARSE_CHECK (f, p, MAX_PRIORITY + 1);
  deref (p, A68G_MON (_m_sp) - 1, WEAK);
  BOOL_T name; MOID_T *moid; PACK_T *u, *v;
  if (IS_REF (TOP_MODE)) {
    name = A68G_TRUE;
    u = PACK (NAME (TOP_MODE));
    moid = SUB (A68G_MON (_m_stack)[--A68G_MON (_m_sp)]);
    v = PACK (moid);
  } else {
    name = A68G_FALSE;
    moid = A68G_MON (_m_stack)[--A68G_MON (_m_sp)];
    u = PACK (moid);
    v = PACK (moid);
  }
  if (!IS (moid, STRUCT_SYMBOL)) {
    monitor_error ("invalid selection mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
  }
  QUIT_ON_ERROR;
  for (; u != NO_PACK; FORWARD (u), FORWARD (v)) {
    if (strcmp (field, TEXT (u)) == 0) {
      if (name) {
        A68G_REF *z = (A68G_REF *) (STACK_OFFSET (-A68G_REF_SIZE));
        CHECK_MON_REF (p, *z, moid);
        OFFSET (z) += OFFSET (v);
      } else {
        DECREMENT_STACK_POINTER (p, SIZE (moid));
        MOVE (STACK_TOP, STACK_OFFSET (OFFSET (v)), (unt) SIZE (MOID (u)));
        INCREMENT_STACK_POINTER (p, SIZE (MOID (u)));
      }
      push_mode (f, MOID (u));
      return;
    }
  }
  monitor_error ("invalid field name", field);
}

//! @brief Perform a call.

void call (FILE_T f, NODE_T * p, int depth)
{
  (void) depth;
  QUIT_ON_ERROR;
  deref (p, A68G_MON (_m_sp) - 1, STRONG);
  MOID_T *proc = A68G_MON (_m_stack)[--A68G_MON (_m_sp)];
  if (!IS (proc, PROC_SYMBOL)) {
    monitor_error ("invalid procedure mode", moid_to_string (proc, MOID_WIDTH, NO_NODE));
  }
  QUIT_ON_ERROR;
  ADDR_T old_m_sp = A68G_MON (_m_sp);
  A68G_PROCEDURE z;
  POP_PROCEDURE (p, &z);
  int args = A68G_MON (_m_sp);
  ADDR_T top_sp = A68G_SP;
  if (A68G_MON (attr) == OPEN_SYMBOL) {
    do {
      SCAN_CHECK (f, p);
      PARSE_CHECK (f, p, 0);
    } while (A68G_MON (attr) == COMMA_SYMBOL);
    if (A68G_MON (attr) != CLOSE_SYMBOL) {
      monitor_error ("unmatched parenthesis", NO_TEXT);
    }
    SCAN_CHECK (f, p);
  }
  coerce_arguments (f, p, proc, args, A68G_MON (_m_sp), top_sp);
  NODE_T q;
  if (STATUS (&z) & STANDENV_PROC_MASK) {
    MOID (&q) = A68G_MON (_m_stack)[--A68G_MON (_m_sp)];
    INFO (&q) = INFO (p);
    NSYMBOL (&q) = NSYMBOL (p);
    (void) ((*PROCEDURE (&(BODY (&z)))) (&q));
    A68G_MON (_m_sp) = old_m_sp;
    push_mode (f, SUB_MOID (&z));
  } else {
    monitor_error ("can only call standard environ routines", NO_TEXT);
  }
}

//! @brief Perform a slice.

void slice (FILE_T f, NODE_T * p, int depth)
{
  (void) depth;
  QUIT_ON_ERROR;
  deref (p, A68G_MON (_m_sp) - 1, WEAK);
  BOOL_T name; MOID_T *moid, *res;
  if (IS_REF (TOP_MODE)) {
    name = A68G_TRUE;
    res = NAME (TOP_MODE);
    deref (p, A68G_MON (_m_sp) - 1, STRONG);
    moid = A68G_MON (_m_stack)[--A68G_MON (_m_sp)];
  } else {
    name = A68G_FALSE;
    moid = A68G_MON (_m_stack)[--A68G_MON (_m_sp)];
    res = SUB (moid);
  }
  if (!IS_ROW (moid) && !IS_FLEX (moid)) {
    monitor_error ("invalid row mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
  }
  QUIT_ON_ERROR;
// Get descriptor.
  A68G_REF z;
  POP_REF (p, &z);
  CHECK_MON_REF (p, z, moid);
  A68G_ARRAY *arr; A68G_TUPLE *tup;
  GET_DESCRIPTOR (arr, tup, &z);
  int dim;
  if (IS_FLEX (moid)) {
    dim = DIM (SUB (moid));
  } else {
    dim = DIM (moid);
  }
// Get indexer.
  int args = A68G_MON (_m_sp);
  if (A68G_MON (attr) == SUB_SYMBOL) {
    do {
      SCAN_CHECK (f, p);
      PARSE_CHECK (f, p, 0);
    } while (A68G_MON (attr) == COMMA_SYMBOL);
    if (A68G_MON (attr) != BUS_SYMBOL) {
      monitor_error ("unmatched parenthesis", NO_TEXT);
    }
    SCAN_CHECK (f, p);
  }
  if ((A68G_MON (_m_sp) - args) != dim) {
    monitor_error ("invalid slice index count", NO_TEXT);
  }
  QUIT_ON_ERROR;
  int index = 0;
  for (int k = 0; k < dim; k++, A68G_MON (_m_sp)--) {
    A68G_TUPLE *t = &(tup[dim - k - 1]);
    deref (p, A68G_MON (_m_sp) - 1, MEEK);
    if (TOP_MODE != M_INT) {
      monitor_error ("invalid indexer mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
    }
    QUIT_ON_ERROR;
    A68G_INT i;
    POP_OBJECT (p, &i, A68G_INT);
    if (VALUE (&i) < LOWER_BOUND (t) || VALUE (&i) > UPPER_BOUND (t)) {
      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
      exit_genie (p, A68G_RUNTIME_ERROR);
    }
    QUIT_ON_ERROR;
    index += SPAN (t) * VALUE (&i) - SHIFT (t);
  }
  ADDR_T address = ROW_ELEMENT (arr, index);
  if (name) {
    z = ARRAY (arr);
    OFFSET (&z) += address;
    REF_SCOPE (&z) = PRIMAL_SCOPE;
    PUSH_REF (p, z);
  } else {
    PUSH (p, ADDRESS (&(ARRAY (arr))) + address, SIZE (res));
  }
  push_mode (f, res);
}

//! @brief Perform a call or a slice.

void call_or_slice (FILE_T f, NODE_T * p, int depth)
{
  while (A68G_MON (attr) == OPEN_SYMBOL || A68G_MON (attr) == SUB_SYMBOL) {
    QUIT_ON_ERROR;
    if (A68G_MON (attr) == OPEN_SYMBOL) {
      call (f, p, depth);
    } else if (A68G_MON (attr) == SUB_SYMBOL) {
      slice (f, p, depth);
    }
  }
}

//! @brief Parse expression on input.

void parse (FILE_T f, NODE_T * p, int depth)
{
  LOW_STACK_ALERT (p);
  QUIT_ON_ERROR;
  if (depth <= MAX_PRIORITY) {
    if (depth == 0) {
// Identity relations.
      PARSE_CHECK (f, p, 1);
      while (A68G_MON (attr) == IS_SYMBOL || A68G_MON (attr) == ISNT_SYMBOL) {
        A68G_REF x, y;
        BOOL_T res;
        int op = A68G_MON (attr);
        if (TOP_MODE != M_HIP && !IS_REF (TOP_MODE)) {
          monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
        }
        SCAN_CHECK (f, p);
        PARSE_CHECK (f, p, 1);
        if (TOP_MODE != M_HIP && !IS_REF (TOP_MODE)) {
          monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
        }
        QUIT_ON_ERROR;
        if (TOP_MODE != M_HIP && A68G_MON (_m_stack)[A68G_MON (_m_sp) - 2] != M_HIP) {
          if (TOP_MODE != A68G_MON (_m_stack)[A68G_MON (_m_sp) - 2]) {
            monitor_error ("invalid identity relation operand mode", NO_TEXT);
          }
        }
        QUIT_ON_ERROR;
        A68G_MON (_m_sp) -= 2;
        POP_REF (p, &y);
        POP_REF (p, &x);
        res = (BOOL_T) (ADDRESS (&x) == ADDRESS (&y));
        PUSH_VALUE (p, (BOOL_T) (op == IS_SYMBOL ? res : !res), A68G_BOOL);
        push_mode (f, M_BOOL);
      }
    } else {
// Dyadic expressions.
      PARSE_CHECK (f, p, depth + 1);
      while (A68G_MON (attr) == OPERATOR && prio (f, p) == depth) {
        BUFFER name;
        a68g_bufcpy (name, A68G_MON (symbol), BUFFER_SIZE);
        int args = A68G_MON (_m_sp) - 1;
        ADDR_T top_sp = A68G_SP - SIZE (A68G_MON (_m_stack)[args]);
        SCAN_CHECK (f, p);
        PARSE_CHECK (f, p, depth + 1);
        TAG_T *opt = search_operator (name, A68G_MON (_m_stack)[A68G_MON (_m_sp) - 2], TOP_MODE);
        QUIT_ON_ERROR;
        coerce_arguments (f, p, MOID (opt), args, A68G_MON (_m_sp), top_sp);
        A68G_MON (_m_sp) -= 2;
        NODE_T q;
        MOID (&q) = MOID (opt);
        INFO (&q) = INFO (p);
        NSYMBOL (&q) = NSYMBOL (p);
        (void) ((*(PROCEDURE (opt)))) (&q);
        push_mode (f, SUB_MOID (opt));
      }
    }
  } else if (A68G_MON (attr) == OPERATOR) {
    BUFFER name;
    a68g_bufcpy (name, A68G_MON (symbol), BUFFER_SIZE);
    int args = A68G_MON (_m_sp);
    ADDR_T top_sp = A68G_SP;
    SCAN_CHECK (f, p);
    PARSE_CHECK (f, p, depth);
    TAG_T *opt = search_operator (name, TOP_MODE, NO_MOID);
    QUIT_ON_ERROR;
    coerce_arguments (f, p, MOID (opt), args, A68G_MON (_m_sp), top_sp);
    A68G_MON (_m_sp)--;
    NODE_T q;
    MOID (&q) = MOID (opt);
    INFO (&q) = INFO (p);
    NSYMBOL (&q) = NSYMBOL (p);
    (void) ((*(PROCEDURE (opt))) (&q));
    push_mode (f, SUB_MOID (opt));
  } else if (A68G_MON (attr) == REF_SYMBOL) {
    int refs = 0, length = 0;
    MOID_T *m = NO_MOID;
    while (A68G_MON (attr) == REF_SYMBOL) {
      refs++;
      SCAN_CHECK (f, p);
    }
    while (A68G_MON (attr) == LONG_SYMBOL) {
      length++;
      SCAN_CHECK (f, p);
    }
    m = search_mode (refs, length, A68G_MON (symbol));
    QUIT_ON_ERROR;
    if (m == NO_MOID) {
      monitor_error ("unknown reference to mode", NO_TEXT);
    }
    SCAN_CHECK (f, p);
    if (A68G_MON (attr) != OPEN_SYMBOL) {
      monitor_error ("cast expects open-symbol", NO_TEXT);
    }
    SCAN_CHECK (f, p);
    PARSE_CHECK (f, p, 0);
    if (A68G_MON (attr) != CLOSE_SYMBOL) {
      monitor_error ("cast expects close-symbol", NO_TEXT);
    }
    SCAN_CHECK (f, p);
    while (IS_REF (TOP_MODE) && TOP_MODE != m) {
      MOID_T *sub = SUB (TOP_MODE);
      A68G_REF z;
      POP_REF (p, &z);
      CHECK_MON_REF (p, z, TOP_MODE);
      PUSH (p, ADDRESS (&z), SIZE (sub));
      TOP_MODE = sub;
    }
    if (TOP_MODE != m) {
      monitor_error ("invalid cast mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
    }
  } else if (A68G_MON (attr) == LONG_SYMBOL) {
    int length = 0;
    while (A68G_MON (attr) == LONG_SYMBOL) {
      length++;
      SCAN_CHECK (f, p);
    }
// Cast L INT -> L REAL.
    if (A68G_MON (attr) == REAL_SYMBOL) {
      MOID_T *i = (length == 1 ? M_LONG_INT : M_LONG_LONG_INT);
      MOID_T *r = (length == 1 ? M_LONG_REAL : M_LONG_LONG_REAL);
      SCAN_CHECK (f, p);
      if (A68G_MON (attr) != OPEN_SYMBOL) {
        monitor_error ("cast expects open-symbol", NO_TEXT);
      }
      SCAN_CHECK (f, p);
      PARSE_CHECK (f, p, 0);
      if (A68G_MON (attr) != CLOSE_SYMBOL) {
        monitor_error ("cast expects close-symbol", NO_TEXT);
      }
      SCAN_CHECK (f, p);
      if (TOP_MODE != i) {
        monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
      }
      QUIT_ON_ERROR;
      TOP_MODE = r;
      return;
    }
// L INT or L REAL denotation.
    MOID_T *m;
    if (A68G_MON (attr) == INT_DENOTATION) {
      m = (length == 1 ? M_LONG_INT : M_LONG_LONG_INT);
    } else if (A68G_MON (attr) == REAL_DENOTATION) {
      m = (length == 1 ? M_LONG_REAL : M_LONG_LONG_REAL);
    } else if (A68G_MON (attr) == BITS_DENOTATION) {
      m = (length == 1 ? M_LONG_BITS : M_LONG_LONG_BITS);
    } else {
      m = NO_MOID;
    }
    if (m != NO_MOID) {
      int digits = DIGITS (m);
      MP_T *z = nil_mp (p, digits);
      if (genie_string_to_value_internal (p, m, A68G_MON (symbol), (BYTE_T *) z) == A68G_FALSE) {
        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m);
        exit_genie (p, A68G_RUNTIME_ERROR);
      }
      MP_STATUS (z) = (MP_T) (INIT_MASK | CONSTANT_MASK);
      push_mode (f, m);
      SCAN_CHECK (f, p);
    } else {
      monitor_error ("invalid mode", NO_TEXT);
    }
  } else if (A68G_MON (attr) == INT_DENOTATION) {
    A68G_INT z;
    if (genie_string_to_value_internal (p, M_INT, A68G_MON (symbol), (BYTE_T *) & z) == A68G_FALSE) {
      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_INT);
      exit_genie (p, A68G_RUNTIME_ERROR);
    }
    PUSH_VALUE (p, VALUE (&z), A68G_INT);
    push_mode (f, M_INT);
    SCAN_CHECK (f, p);
  } else if (A68G_MON (attr) == REAL_DENOTATION) {
    A68G_REAL z;
    if (genie_string_to_value_internal (p, M_REAL, A68G_MON (symbol), (BYTE_T *) & z) == A68G_FALSE) {
      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_REAL);
      exit_genie (p, A68G_RUNTIME_ERROR);
    }
    PUSH_VALUE (p, VALUE (&z), A68G_REAL);
    push_mode (f, M_REAL);
    SCAN_CHECK (f, p);
  } else if (A68G_MON (attr) == BITS_DENOTATION) {
    A68G_BITS z;
    if (genie_string_to_value_internal (p, M_BITS, A68G_MON (symbol), (BYTE_T *) & z) == A68G_FALSE) {
      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_BITS);
      exit_genie (p, A68G_RUNTIME_ERROR);
    }
    PUSH_VALUE (p, VALUE (&z), A68G_BITS);
    push_mode (f, M_BITS);
    SCAN_CHECK (f, p);
  } else if (A68G_MON (attr) == ROW_CHAR_DENOTATION) {
    if (strlen (A68G_MON (symbol)) == 1) {
      PUSH_VALUE (p, A68G_MON (symbol)[0], A68G_CHAR);
      push_mode (f, M_CHAR);
    } else {
      A68G_REF z = c_to_a_string (p, A68G_MON (symbol), DEFAULT_WIDTH);
      A68G_ARRAY *arr; A68G_TUPLE *tup;
      GET_DESCRIPTOR (arr, tup, &z);
      BLOCK_GC_HANDLE (&z);
      BLOCK_GC_HANDLE (&(ARRAY (arr)));
      PUSH_REF (p, z);
      push_mode (f, M_STRING);
      (void) tup;
    }
    SCAN_CHECK (f, p);
  } else if (A68G_MON (attr) == TRUE_SYMBOL) {
    PUSH_VALUE (p, A68G_TRUE, A68G_BOOL);
    push_mode (f, M_BOOL);
    SCAN_CHECK (f, p);
  } else if (A68G_MON (attr) == FALSE_SYMBOL) {
    PUSH_VALUE (p, A68G_FALSE, A68G_BOOL);
    push_mode (f, M_BOOL);
    SCAN_CHECK (f, p);
  } else if (A68G_MON (attr) == NIL_SYMBOL) {
    PUSH_REF (p, nil_ref);
    push_mode (f, M_HIP);
    SCAN_CHECK (f, p);
  } else if (A68G_MON (attr) == REAL_SYMBOL) {
    SCAN_CHECK (f, p);
    if (A68G_MON (attr) != OPEN_SYMBOL) {
      monitor_error ("cast expects open-symbol", NO_TEXT);
    }
    SCAN_CHECK (f, p);
    PARSE_CHECK (f, p, 0);
    if (A68G_MON (attr) != CLOSE_SYMBOL) {
      monitor_error ("cast expects close-symbol", NO_TEXT);
    }
    SCAN_CHECK (f, p);
    if (TOP_MODE != M_INT) {
      monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
    }
    QUIT_ON_ERROR;
    A68G_INT k;
    POP_OBJECT (p, &k, A68G_INT);
    PUSH_VALUE (p, (REAL_T) VALUE (&k), A68G_REAL);
    TOP_MODE = M_REAL;
  } else if (A68G_MON (attr) == IDENTIFIER) {
    ADDR_T old_sp = A68G_SP;
    BUFFER name;
    a68g_bufcpy (name, A68G_MON (symbol), BUFFER_SIZE);
    SCAN_CHECK (f, p);
    if (A68G_MON (attr) == OF_SYMBOL) {
      selection (f, p, name);
    } else {
      search_identifier (f, p, A68G_FP, name);
      QUIT_ON_ERROR;
      call_or_slice (f, p, depth);
    }
    QUIT_ON_ERROR;
    MOID_T *moid = TOP_MODE;
    BOOL_T init;
    if (check_initialisation (p, STACK_ADDRESS (old_sp), moid, &init)) {
      if (init == A68G_FALSE) {
        monitor_error (NO_VALUE, name);
      }
    } else {
      monitor_error ("cannot process value of mode", moid_to_string (moid, MOID_WIDTH, NO_NODE));
    }
  } else if (A68G_MON (attr) == OPEN_SYMBOL) {
    do {
      SCAN_CHECK (f, p);
      PARSE_CHECK (f, p, 0);
    } while (A68G_MON (attr) == COMMA_SYMBOL);
    if (A68G_MON (attr) != CLOSE_SYMBOL) {
      monitor_error ("unmatched parenthesis", NO_TEXT);
    }
    SCAN_CHECK (f, p);
    call_or_slice (f, p, depth);
  } else {
    monitor_error ("invalid expression syntax", NO_TEXT);
  }
}

//! @brief Perform assignment.

void assign (FILE_T f, NODE_T * p)
{
  LOW_STACK_ALERT (p);
  PARSE_CHECK (f, p, 0);
  if (A68G_MON (attr) == ASSIGN_SYMBOL) {
    MOID_T *m = A68G_MON (_m_stack)[--A68G_MON (_m_sp)];
    A68G_REF z;
    if (!IS_REF (m)) {
      monitor_error ("invalid destination mode", moid_to_string (m, MOID_WIDTH, NO_NODE));
    }
    QUIT_ON_ERROR;
    POP_REF (p, &z);
    CHECK_MON_REF (p, z, m);
    SCAN_CHECK (f, p);
    assign (f, p);
    QUIT_ON_ERROR;
    while (IS_REF (TOP_MODE) && TOP_MODE != SUB (m)) {
      MOID_T *sub = SUB (TOP_MODE);
      A68G_REF y;
      POP_REF (p, &y);
      CHECK_MON_REF (p, y, TOP_MODE);
      PUSH (p, ADDRESS (&y), SIZE (sub));
      TOP_MODE = sub;
    }
    if (TOP_MODE != SUB (m) && TOP_MODE != M_HIP) {
      monitor_error ("invalid source mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
    }
    QUIT_ON_ERROR;
    POP (p, ADDRESS (&z), SIZE (TOP_MODE));
    PUSH_REF (p, z);
    TOP_MODE = m;
  }
}

//! @brief Evaluate expression on input.

void evaluate (FILE_T f, NODE_T * p, char *str)
{
  LOW_STACK_ALERT (p);
  A68G_MON (_m_sp) = 0;
  A68G_MON (_m_stack)[0] = NO_MOID;
  A68G_MON (pos) = 0;
  a68g_bufcpy (A68G_MON (expr), str, BUFFER_SIZE);
  SCAN_CHECK (f, p);
  QUIT_ON_ERROR;
  assign (f, p);
  if (A68G_MON (attr) != 0) {
    monitor_error ("trailing character in expression", A68G_MON (symbol));
  }
}

//! @brief Convert string to int.

int get_num_arg (char *num, char **rest)
{
  if (rest != NO_REF) {
    *rest = NO_TEXT;
  }
  if (num == NO_TEXT) {
    return NOT_A_NUM;
  }
  SKIP_ONE_SYMBOL (num);
  if (IS_DIGIT (num[0])) {
    errno = 0;
    char *end;
    int k = (int) a68g_strtou (num, &end, 10);
    if (end != num && errno == 0) {
      if (rest != NO_REF) {
        *rest = end;
      }
      return k;
    } else {
      monitor_error ("invalid numerical argument", error_specification ());
      return NOT_A_NUM;
    }
  } else {
    if (num[0] != NULL_CHAR) {
      monitor_error ("invalid numerical argument", num);
    }
    return NOT_A_NUM;
  }
}

//! @brief Whether item at "w" of mode "q" is initialised.

BOOL_T check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q, BOOL_T * result)
{
  BOOL_T initialised = A68G_FALSE, recognised = A68G_FALSE;
  (void) p;
  switch (SHORT_ID (q)) {
  case MODE_NO_CHECK:
  case UNION_SYMBOL: {
      initialised = A68G_TRUE;
      recognised = A68G_TRUE;
      break;
    }
  case REF_SYMBOL: {
      A68G_REF *z = (A68G_REF *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case PROC_SYMBOL: {
      A68G_PROCEDURE *z = (A68G_PROCEDURE *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_INT: {
      A68G_INT *z = (A68G_INT *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_REAL: {
      A68G_REAL *z = (A68G_REAL *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_COMPLEX: {
      A68G_REAL *r = (A68G_REAL *) w;
      A68G_REAL *i = (A68G_REAL *) (w + SIZE_ALIGNED (A68G_REAL));
      initialised = (BOOL_T) (INITIALISED (r) && INITIALISED (i));
      recognised = A68G_TRUE;
      break;
    }
  case MODE_LONG_LONG_INT:
  case MODE_LONG_LONG_REAL:
  case MODE_LONG_LONG_BITS: {
      MP_T *z = (MP_T *) w;
      initialised = (BOOL_T) ((unt) MP_STATUS (z) & INIT_MASK);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_LONG_COMPLEX: {
      MP_T *r = (MP_T *) w;
      MP_T *i = (MP_T *) (w + size_mp ());
      initialised = (BOOL_T) (((unt) MP_STATUS (r) & INIT_MASK) && ((unt) MP_STATUS (i) & INIT_MASK));
      recognised = A68G_TRUE;
      break;
    }
  case MODE_LONG_LONG_COMPLEX: {
      MP_T *r = (MP_T *) w;
      MP_T *i = (MP_T *) (w + size_mp ());
      initialised = (BOOL_T) (((unt) MP_STATUS (r) & INIT_MASK) && ((unt) MP_STATUS (i) & INIT_MASK));
      recognised = A68G_TRUE;
      break;
    }
  case MODE_BOOL: {
      A68G_BOOL *z = (A68G_BOOL *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_CHAR: {
      A68G_CHAR *z = (A68G_CHAR *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_BITS: {
      A68G_BITS *z = (A68G_BITS *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_BYTES: {
      A68G_BYTES *z = (A68G_BYTES *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_LONG_BYTES: {
      A68G_LONG_BYTES *z = (A68G_LONG_BYTES *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_FILE: {
      A68G_FILE *z = (A68G_FILE *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_FORMAT: {
      A68G_FORMAT *z = (A68G_FORMAT *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
      break;
    }
  case MODE_PIPE: {
      A68G_REF *pipe_read = (A68G_REF *) w;
      A68G_REF *pipe_write = (A68G_REF *) (w + A68G_REF_SIZE);
      A68G_INT *pid = (A68G_INT *) (w + 2 * A68G_REF_SIZE);
      initialised = (BOOL_T) (INITIALISED (pipe_read) && INITIALISED (pipe_write) && INITIALISED (pid));
      recognised = A68G_TRUE;
      break;
    }
  case MODE_SOUND: {
      A68G_SOUND *z = (A68G_SOUND *) w;
      initialised = INITIALISED (z);
      recognised = A68G_TRUE;
    }
  #if (A68G_LEVEL >= 3)
    case MODE_LONG_INT:
    case MODE_LONG_BITS: {
        A68G_LONG_INT *z = (A68G_LONG_INT *) w;
        initialised = INITIALISED (z);
        recognised = A68G_TRUE;
        break;
      }
    case MODE_LONG_REAL: {
        A68G_LONG_REAL *z = (A68G_LONG_REAL *) w;
        initialised = INITIALISED (z);
        recognised = A68G_TRUE;
        break;
      }
  #else
    case MODE_LONG_INT:
    case MODE_LONG_REAL:
    case MODE_LONG_BITS: {
        MP_T *z = (MP_T *) w;
        initialised = (BOOL_T) ((unt) MP_STATUS (z) & INIT_MASK);
        recognised = A68G_TRUE;
        break;
      }
  #endif
  }
  if (result != NO_BOOL) {
    *result = initialised;
  }
  return recognised;
}

//! @brief Show value of object.

void print_item (NODE_T * p, FILE_T f, BYTE_T * item, MOID_T * mode)
{
  A68G_REF nil_file = nil_ref;
  reset_transput_buffer (UNFORMATTED_BUFFER);
  genie_write_standard (p, mode, item, nil_file);
  if (get_transput_buffer_index (UNFORMATTED_BUFFER) > 0) {
    if (mode == M_CHAR || mode == M_ROW_CHAR || mode == M_STRING) {
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " \"%s\"", get_transput_buffer (UNFORMATTED_BUFFER)) >= 0);
      WRITE (f, A68G (output_line));
    } else {
      char *str = get_transput_buffer (UNFORMATTED_BUFFER);
      while (IS_SPACE (str[0])) {
        str++;
      }
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " %s", str) >= 0);
      WRITE (f, A68G (output_line));
    }
  } else {
    WRITE (f, CANNOT_SHOW);
  }
}

//! @brief Indented indent_crlf.

void indent_crlf (FILE_T f)
{
  if (f == A68G_STDOUT) {
    io_close_tty_line ();
  }
  for (int k = 0; k < A68G_MON (tabs); k++) {
    WRITE (f, "  ");
  }
}

//! @brief Show value of object.

void show_item (FILE_T f, NODE_T * p, BYTE_T * item, MOID_T * mode)
{
  if (item == NO_BYTE || mode == NO_MOID) {
    return;
  }
  if (IS_REF (mode)) {
    A68G_REF *z = (A68G_REF *) item;
    if (IS_NIL (*z)) {
      if (INITIALISED (z)) {
        WRITE (A68G_STDOUT, " = NIL");
      } else {
        WRITE (A68G_STDOUT, NO_VALUE);
      }
    } else {
      if (INITIALISED (z)) {
        WRITE (A68G_STDOUT, " refers to ");
        if (IS_IN_HEAP (z)) {
          ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "heap(%p)", (void *) ADDRESS (z)) >= 0);
          WRITE (A68G_STDOUT, A68G (output_line));
          A68G_MON (tabs)++;
          show_item (f, p, ADDRESS (z), SUB (mode));
          A68G_MON (tabs)--;
        } else if (IS_IN_FRAME (z)) {
          ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "frame(" A68G_LU ")", REF_OFFSET (z)) >= 0);
          WRITE (A68G_STDOUT, A68G (output_line));
        } else if (IS_IN_STACK (z)) {
          ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "stack(" A68G_LU ")", REF_OFFSET (z)) >= 0);
          WRITE (A68G_STDOUT, A68G (output_line));
        }
      } else {
        WRITE (A68G_STDOUT, NO_VALUE);
      }
    }
  } else if (mode == M_STRING) {
    if (!INITIALISED ((A68G_REF *) item)) {
      WRITE (A68G_STDOUT, NO_VALUE);
    } else {
      print_item (p, f, item, mode);
    }
  } else if ((IS_ROW (mode) || IS_FLEX (mode)) && mode != M_STRING) {
    MOID_T *deflexed = DEFLEX (mode);
    int old_tabs = A68G_MON (tabs);
    A68G_MON (tabs) += 2;
    if (!INITIALISED ((A68G_REF *) item)) {
      WRITE (A68G_STDOUT, NO_VALUE);
    } else {
      A68G_ARRAY *arr; A68G_TUPLE *tup;
      GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
      size_t elems = get_row_size (tup, DIM (arr));
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, ", %d element(s)", elems) >= 0);
      WRITE (f, A68G (output_line));
      if (get_row_size (tup, DIM (arr)) != 0) {
        BYTE_T *base_addr = ADDRESS (&ARRAY (arr));
        BOOL_T done = A68G_FALSE;
        initialise_internal_index (tup, DIM (arr));
        int count = 0, act_count = 0;
        while (!done && ++count <= (A68G_MON (max_row_elems) + 1)) {
          if (count <= A68G_MON (max_row_elems)) {
            ADDR_T row_index = calculate_internal_index (tup, DIM (arr));
            ADDR_T elem_addr = ROW_ELEMENT (arr, row_index);
            BYTE_T *elem = &base_addr[elem_addr];
            indent_crlf (f);
            WRITE (f, "[");
            print_internal_index (f, tup, DIM (arr));
            WRITE (f, "]");
            show_item (f, p, elem, SUB (deflexed));
            act_count++;
            done = increment_internal_index (tup, DIM (arr));
          }
        }
        indent_crlf (f);
        ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " %d element(s) written (%d%%)", act_count, (int) ((100.0 * act_count) / elems)) >= 0);
        WRITE (f, A68G (output_line));
      }
    }
    A68G_MON (tabs) = old_tabs;
  } else if (IS_STRUCT (mode)) {
    A68G_MON (tabs)++;
    for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
      BYTE_T *elem = &item[OFFSET (q)];
      indent_crlf (f);
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "     %s \"%s\"", moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), TEXT (q)) >= 0);
      WRITE (A68G_STDOUT, A68G (output_line));
      show_item (f, p, elem, MOID (q));
    }
    A68G_MON (tabs)--;
  } else if (IS (mode, UNION_SYMBOL)) {
    A68G_UNION *z = (A68G_UNION *) item;
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
    WRITE (A68G_STDOUT, A68G (output_line));
    show_item (f, p, &item[SIZE_ALIGNED (A68G_UNION)], (MOID_T *) (VALUE (z)));
  } else if (mode == M_SIMPLIN) {
    A68G_UNION *z = (A68G_UNION *) item;
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
    WRITE (A68G_STDOUT, A68G (output_line));
  } else if (mode == M_SIMPLOUT) {
    A68G_UNION *z = (A68G_UNION *) item;
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0);
    WRITE (A68G_STDOUT, A68G (output_line));
  } else {
    BOOL_T init;
    if (check_initialisation (p, item, mode, &init)) {
      if (init) {
        if (IS (mode, PROC_SYMBOL)) {
          A68G_PROCEDURE *z = (A68G_PROCEDURE *) item;
          if (z != NO_PROCEDURE && STATUS (z) & STANDENV_PROC_MASK) {
            char *fname = standard_environ_proc_name (*(PROCEDURE (&BODY (z))));
            WRITE (A68G_STDOUT, " standenv procedure");
            if (fname != NO_TEXT) {
              WRITE (A68G_STDOUT, " (");
              WRITE (A68G_STDOUT, fname);
              WRITE (A68G_STDOUT, ")");
            }
          } else if (z != NO_PROCEDURE && STATUS (z) & SKIP_PROCEDURE_MASK) {
            WRITE (A68G_STDOUT, " skip procedure");
          } else if (z != NO_PROCEDURE && (PROCEDURE (&BODY (z))) != NO_GPROC) {
            ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68G_LU "), locale %p", LINE_NUMBER ((NODE_T *) NODE (&BODY (z))), ENVIRON (z), (void *) LOCALE (z)) >= 0);
            WRITE (A68G_STDOUT, A68G (output_line));
          } else {
            WRITE (A68G_STDOUT, " cannot show value");
          }
        } else if (mode == M_FORMAT) {
          A68G_FORMAT *z = (A68G_FORMAT *) item;
          if (z != NO_FORMAT && BODY (z) != NO_NODE) {
            ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " line %d, environ at frame(" A68G_LU ")", LINE_NUMBER (BODY (z)), ENVIRON (z)) >= 0);
            WRITE (A68G_STDOUT, A68G (output_line));
          } else {
            monitor_error (CANNOT_SHOW, NO_TEXT);
          }
        } else if (mode == M_SOUND) {
          A68G_SOUND *z = (A68G_SOUND *) item;
          if (z != NO_SOUND) {
            ASSERT (a68g_bufprt (A68G (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);
            WRITE (A68G_STDOUT, A68G (output_line));

          } else {
            monitor_error (CANNOT_SHOW, NO_TEXT);
          }
        } else {
          print_item (p, f, item, mode);
        }
      } else {
        WRITE (A68G_STDOUT, NO_VALUE);
      }
    } else {
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, " mode %s, %s", moid_to_string (mode, MOID_WIDTH, NO_NODE), CANNOT_SHOW) >= 0);
      WRITE (A68G_STDOUT, A68G (output_line));
    }
  }
}

//! @brief Overview of frame item.

void show_frame_item (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, int modif)
{
  (void) p;
  ADDR_T addr = a68g_link + FRAME_INFO_SIZE + OFFSET (q);
  ADDR_T loc = FRAME_INFO_SIZE + OFFSET (q);
  indent_crlf (A68G_STDOUT);
  if (modif != ANONYMOUS) {
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "     frame(" A68G_LU "=" A68G_LU "+" A68G_LU ") %s \"%s\"", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), NSYMBOL (NODE (q))) >= 0);
    WRITE (A68G_STDOUT, A68G (output_line));
    show_item (f, p, FRAME_ADDRESS (addr), MOID (q));
  } else {
    switch (PRIO (q)) {
    case GENERATOR: {
        ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "     frame(" A68G_LU "=" A68G_LU "+" A68G_LU ") LOC %s", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0);
        WRITE (A68G_STDOUT, A68G (output_line));
        break;
      }
    default: {
        ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "     frame(" A68G_LU "=" A68G_LU "+" A68G_LU ") internal %s", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0);
        WRITE (A68G_STDOUT, A68G (output_line));
        break;
      }
    }
    show_item (f, p, FRAME_ADDRESS (addr), MOID (q));
  }
}

//! @brief Overview of frame items.

void show_frame_items (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, int modif)
{
  (void) p;
  for (; q != NO_TAG; FORWARD (q)) {
    show_frame_item (f, p, a68g_link, q, modif);
  }
}

//! @brief Introduce stack frame.

void intro_frame (FILE_T f, NODE_T * p, ADDR_T a68g_link, int *printed)
{
  if (*printed > 0) {
    WRITELN (f, "");
  }
  (*printed)++;
  TABLE_T *q = TABLE (p);
  where_in_source (f, p);
  ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Stack frame %d at frame(" A68G_LU "), level=%d, size=" A68G_LU " bytes", FRAME_NUMBER (a68g_link), a68g_link, LEVEL (q), (UNSIGNED_T) (FRAME_INCREMENT (a68g_link) + FRAME_INFO_SIZE)) >= 0);
  WRITELN (f, A68G (output_line));
}

//! @brief View contents of stack frame.

void show_stack_frame (FILE_T f, NODE_T * p, ADDR_T a68g_link, int *printed)
{
// show the frame starting at frame pointer 'a68g_link', using symbol table from p as a map.
  if (p != NO_NODE) {
    TABLE_T *q = TABLE (p);
    intro_frame (f, p, a68g_link, printed);
    #if (A68G_LEVEL >= 3)
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Dynamic link=frame(%llu), static link=frame(%llu), parameters=frame(%llu)", FRAME_DYNAMIC_LINK (a68g_link), FRAME_STATIC_LINK (a68g_link), FRAME_PARAMETERS (a68g_link)) >= 0);
      WRITELN (A68G_STDOUT, A68G (output_line));
#else
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Dynamic link=frame(%u), static link=frame(%u), parameters=frame(%u)", FRAME_DYNAMIC_LINK (a68g_link), FRAME_STATIC_LINK (a68g_link), FRAME_PARAMETERS (a68g_link)) >= 0);
      WRITELN (A68G_STDOUT, A68G (output_line));
    #endif
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Procedure frame=%s", (FRAME_PROC_FRAME (a68g_link) ? "yes" : "no")) >= 0);
    WRITELN (A68G_STDOUT, A68G (output_line));
    #if defined (BUILD_PARALLEL_CLAUSE)
      if (pthread_equal (FRAME_THREAD_ID (a68g_link), A68G_PAR (main_thread_id)) != 0) {
        ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "In main thread") >= 0);
      } else {
        ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Not in main thread") >= 0);
      }
      WRITELN (A68G_STDOUT, A68G (output_line));
    #endif
    show_frame_items (f, p, a68g_link, IDENTIFIERS (q), IDENTIFIER);
    show_frame_items (f, p, a68g_link, OPERATORS (q), OPERATOR);
    show_frame_items (f, p, a68g_link, ANONYMOUS (q), ANONYMOUS);
  }
}

//! @brief Shows lines around the line where 'p' is at.

void list (FILE_T f, NODE_T * p, int n, int m)
{
  if (p != NO_NODE) {
    if (m == 0) {
      LINE_T *r = LINE (INFO (p));
      for (LINE_T *l = TOP_LINE (&A68G_JOB); l != NO_LINE; FORWARD (l)) {
        if (NUMBER (l) > 0 && abs (NUMBER (r) - NUMBER (l)) <= n) {
          write_source_line (f, l, NO_NODE, A68G_TRUE);
        }
      }
    } else {
      for (LINE_T *l = TOP_LINE (&A68G_JOB); l != NO_LINE; FORWARD (l)) {
        if (NUMBER (l) > 0 && NUMBER (l) >= n && NUMBER (l) <= m) {
          write_source_line (f, l, NO_NODE, A68G_TRUE);
        }
      }
    }
  }
}

//! @brief Overview of the heap.

void show_heap (FILE_T f, NODE_T * p, A68G_HANDLE * z, int top, int n)
{
  int k = 0, m = n, sum = 0;
  (void) p;
  ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "size=%u available=%d garbage collections=" A68G_LD, A68G (heap_size), heap_available (), A68G_GC (sweeps)) >= 0);
  WRITELN (f, A68G (output_line));
  for (; z != NO_HANDLE; FORWARD (z), k++) {
    if (n > 0 && sum <= top) {
      n--;
      indent_crlf (f);
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "heap(%p+%d) %s", (void *) POINTER (z), SIZE (z), moid_to_string (MOID (z), MOID_WIDTH, NO_NODE)) >= 0);
      WRITE (f, A68G (output_line));
      sum += SIZE (z);
    }
  }
  ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "printed %d out of %d handles", m, k) >= 0);
  WRITELN (f, A68G (output_line));
}

//! @brief Search current frame and print it.

void stack_dump_current (FILE_T f, ADDR_T a68g_link)
{
  if (a68g_link > 0) {
    int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link);
    NODE_T *p = FRAME_TREE (a68g_link);
    if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
      if (FRAME_NUMBER (a68g_link) == A68G_MON (current_frame)) {
        int printed = 0;
        show_stack_frame (f, p, a68g_link, &printed);
      } else {
        stack_dump_current (f, dynamic_a68g_link);
      }
    }
  }
}

//! @brief Overview of the stack.

void stack_a68g_link_dump (FILE_T f, ADDR_T a68g_link, int depth, int *printed)
{
  if (depth > 0 && a68g_link > 0) {
    NODE_T *p = FRAME_TREE (a68g_link);
    if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
      show_stack_frame (f, p, a68g_link, printed);
      stack_a68g_link_dump (f, FRAME_STATIC_LINK (a68g_link), depth - 1, printed);
    }
  }
}

//! @brief Overview of the stack.

void stack_dump (FILE_T f, ADDR_T a68g_link, int depth, int *printed)
{
  if (depth > 0 && a68g_link > 0) {
    NODE_T *p = FRAME_TREE (a68g_link);
    if (p != NO_NODE && LEVEL (TABLE (p)) > 3) {
      show_stack_frame (f, p, a68g_link, printed);
      stack_dump (f, FRAME_DYNAMIC_LINK (a68g_link), depth - 1, printed);
    }
  }
}

//! @brief Overview of the stack.

void stack_trace (FILE_T f, ADDR_T a68g_link, int depth, int *printed)
{
  if (depth > 0 && a68g_link > 0) {
    int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link);
    if (FRAME_PROC_FRAME (a68g_link)) {
      NODE_T *p = FRAME_TREE (a68g_link);
      show_stack_frame (f, p, a68g_link, printed);
      stack_trace (f, dynamic_a68g_link, depth - 1, printed);
    } else {
      stack_trace (f, dynamic_a68g_link, depth, printed);
    }
  }
}

//! @brief Examine tags.

void examine_tags (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, char *sym, int *printed)
{
  for (; q != NO_TAG; FORWARD (q)) {
    if (NODE (q) != NO_NODE && strcmp (NSYMBOL (NODE (q)), sym) == 0) {
      intro_frame (f, p, a68g_link, printed);
      show_frame_item (f, p, a68g_link, q, PRIO (q));
    }
  }
}

//! @brief Search symbol in stack.

void examine_stack (FILE_T f, ADDR_T a68g_link, char *sym, int *printed)
{
  if (a68g_link > 0) {
    int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link);
    NODE_T *p = FRAME_TREE (a68g_link);
    if (p != NO_NODE) {
      TABLE_T *q = TABLE (p);
      examine_tags (f, p, a68g_link, IDENTIFIERS (q), sym, printed);
      examine_tags (f, p, a68g_link, OPERATORS (q), sym, printed);
    }
    examine_stack (f, dynamic_a68g_link, sym, printed);
  }
}

//! @brief Set or reset breakpoints.

void change_breakpoints (NODE_T * p, unt set, int num, BOOL_T * is_set, char *loc_expr)
{
  for (; p != NO_NODE; FORWARD (p)) {
    change_breakpoints (SUB (p), set, num, is_set, loc_expr);
    if (set == BREAKPOINT_MASK) {
      if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) {
        STATUS_SET (p, BREAKPOINT_MASK);
        a68g_free (EXPR (INFO (p)));
        EXPR (INFO (p)) = loc_expr;
        *is_set = A68G_TRUE;
      }
    } else if (set == BREAKPOINT_TEMPORARY_MASK) {
      if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) {
        STATUS_SET (p, BREAKPOINT_TEMPORARY_MASK);
        a68g_free (EXPR (INFO (p)));
        EXPR (INFO (p)) = loc_expr;
        *is_set = A68G_TRUE;
      }
    } else if (set == NULL_MASK) {
      if (LINE_NUMBER (p) != num) {
        STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK));
        a68g_free (EXPR (INFO (p)));
        EXPR (INFO (p)) = NO_TEXT;
      } else if (num == 0) {
        STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK));
        a68g_free (EXPR (INFO (p)));
        EXPR (INFO (p)) = NO_TEXT;
      }
    }
  }
}

//! @brief List breakpoints.

void list_breakpoints (NODE_T * p, int *listed)
{
  for (; p != NO_NODE; FORWARD (p)) {
    list_breakpoints (SUB (p), listed);
    if (STATUS_TEST (p, BREAKPOINT_MASK)) {
      (*listed)++;
      WIS (p);
      if (EXPR (INFO (p)) != NO_TEXT) {
        WRITELN (A68G_STDOUT, "breakpoint condition \"");
        WRITE (A68G_STDOUT, EXPR (INFO (p)));
        WRITE (A68G_STDOUT, "\"");
      }
    }
  }
}

//! @brief Execute monitor command.

BOOL_T single_stepper (NODE_T * p, char *cmd)
{
  A68G_MON (mon_errors) = 0;
  errno = 0;
  if (strlen (cmd) == 0) {
    return A68G_FALSE;
  }
  while (IS_SPACE (cmd[strlen (cmd) - 1])) {
    cmd[strlen (cmd) - 1] = NULL_CHAR;
  }
  if (match_string (cmd, "CAlls", BLANK_CHAR)) {
    int k = get_num_arg (cmd, NO_REF);
    int printed = 0;
    if (k > 0) {
      stack_trace (A68G_STDOUT, A68G_FP, k, &printed);
    } else if (k == 0) {
      stack_trace (A68G_STDOUT, A68G_FP, 3, &printed);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "Continue", NULL_CHAR) || match_string (cmd, "Resume", NULL_CHAR)) {
    A68G (do_confirm_exit) = A68G_TRUE;
    return A68G_TRUE;
  } else if (match_string (cmd, "DO", BLANK_CHAR) || match_string (cmd, "EXEC", BLANK_CHAR)) {
    char *sym = cmd;
    SKIP_ONE_SYMBOL (sym);
    if (sym[0] != NULL_CHAR) {
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "return code %d", system (sym)) >= 0);
      WRITELN (A68G_STDOUT, A68G (output_line));
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "ELems", BLANK_CHAR)) {
    int k = get_num_arg (cmd, NO_REF);
    if (k > 0) {
      A68G_MON (max_row_elems) = k;
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "Evaluate", BLANK_CHAR) || match_string (cmd, "X", BLANK_CHAR)) {
    char *sym = cmd;
    SKIP_ONE_SYMBOL (sym);
    if (sym[0] != NULL_CHAR) {
      ADDR_T old_sp = A68G_SP;
      evaluate (A68G_STDOUT, p, sym);
      if (A68G_MON (mon_errors) == 0 && A68G_MON (_m_sp) > 0) {
        BOOL_T cont = A68G_TRUE;
        while (cont) {
          MOID_T *res = A68G_MON (_m_stack)[0];
          WRITELN (A68G_STDOUT, "(");
          WRITE (A68G_STDOUT, moid_to_string (res, MOID_WIDTH, NO_NODE));
          WRITE (A68G_STDOUT, ")");
          show_item (A68G_STDOUT, p, STACK_ADDRESS (old_sp), res);
          cont = (BOOL_T) (IS_REF (res) && !IS_NIL (*(A68G_REF *) STACK_ADDRESS (old_sp)));
          if (cont) {
            A68G_REF z;
            POP_REF (p, &z);
            A68G_MON (_m_stack)[0] = SUB (A68G_MON (_m_stack)[0]);
            PUSH (p, ADDRESS (&z), SIZE (A68G_MON (_m_stack)[0]));
          }
        }
      } else {
        monitor_error (CANNOT_SHOW, NO_TEXT);
      }
      A68G_SP = old_sp;
      A68G_MON (_m_sp) = 0;
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "EXamine", BLANK_CHAR)) {
    char *sym = cmd;
    SKIP_ONE_SYMBOL (sym);
    if (sym[0] != NULL_CHAR && (IS_LOWER (sym[0]) || IS_UPPER (sym[0]))) {
      int printed = 0;
      examine_stack (A68G_STDOUT, A68G_FP, sym, &printed);
      if (printed == 0) {
        monitor_error ("tag not found", sym);
      }
    } else {
      monitor_error ("tag expected", NO_TEXT);
    }
    return A68G_FALSE;
  } 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) {
    if (confirm_exit ()) {
      exit_genie (p, A68G_RUNTIME_ERROR + A68G_FORCE_QUIT);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "Frame", NULL_CHAR)) {
    if (A68G_MON (current_frame) == 0) {
      int printed = 0;
      stack_dump (A68G_STDOUT, A68G_FP, 1, &printed);
    } else {
      stack_dump_current (A68G_STDOUT, A68G_FP);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "Frame", BLANK_CHAR)) {
    int n = get_num_arg (cmd, NO_REF);
    A68G_MON (current_frame) = (n > 0 ? n : 0);
    stack_dump_current (A68G_STDOUT, A68G_FP);
    return A68G_FALSE;
  } else if (match_string (cmd, "HEAp", BLANK_CHAR)) {
    int top = get_num_arg (cmd, NO_REF);
    if (top <= 0) {
      top = A68G (heap_size);
    }
    show_heap (A68G_STDOUT, p, A68G_GC (busy_handles), top, A68G (term_heigth) - 4);
    return A68G_FALSE;
  } else if (match_string (cmd, "APropos", NULL_CHAR) || match_string (cmd, "Help", NULL_CHAR) || match_string (cmd, "INfo", NULL_CHAR)) {
    apropos (A68G_STDOUT, NO_TEXT, "monitor");
    return A68G_FALSE;
  } else if (match_string (cmd, "APropos", BLANK_CHAR) || match_string (cmd, "Help", BLANK_CHAR) || match_string (cmd, "INfo", BLANK_CHAR)) {
    char *sym = cmd;
    SKIP_ONE_SYMBOL (sym);
    apropos (A68G_STDOUT, NO_TEXT, sym);
    return A68G_FALSE;
  } else if (match_string (cmd, "HT", NULL_CHAR)) {
    A68G (halt_typing) = A68G_TRUE;
    A68G (do_confirm_exit) = A68G_TRUE;
    return A68G_TRUE;
  } else if (match_string (cmd, "RT", NULL_CHAR)) {
    A68G (halt_typing) = A68G_FALSE;
    A68G (do_confirm_exit) = A68G_TRUE;
    return A68G_TRUE;
  } else if (match_string (cmd, "Breakpoint", BLANK_CHAR)) {
    char *sym = cmd;
    SKIP_ONE_SYMBOL (sym);
    if (sym[0] == NULL_CHAR) {
      int listed = 0;
      list_breakpoints (TOP_NODE (&A68G_JOB), &listed);
      if (listed == 0) {
        WRITELN (A68G_STDOUT, "No breakpoints set");
      }
      if (A68G_MON (watchpoint_expression) != NO_TEXT) {
        WRITELN (A68G_STDOUT, "Watchpoint condition \"");
        WRITE (A68G_STDOUT, A68G_MON (watchpoint_expression));
        WRITE (A68G_STDOUT, "\"");
      } else {
        WRITELN (A68G_STDOUT, "No watchpoint expression set");
      }
    } else if (IS_DIGIT (sym[0])) {
      char *mod;
      int k = get_num_arg (cmd, &mod);
      SKIP_SPACE (mod);
      if (mod[0] == NULL_CHAR) {
        BOOL_T set = A68G_FALSE;
        change_breakpoints (TOP_NODE (&A68G_JOB), BREAKPOINT_MASK, k, &set, NULL);
        if (set == A68G_FALSE) {
          monitor_error ("cannot set breakpoint in that line", NO_TEXT);
        }
      } else if (match_string (mod, "IF", BLANK_CHAR)) {
        char *cexpr = mod;
        BOOL_T set = A68G_FALSE;
        SKIP_ONE_SYMBOL (cexpr);
        change_breakpoints (TOP_NODE (&A68G_JOB), BREAKPOINT_MASK, k, &set, new_string (cexpr, NO_TEXT));
        if (set == A68G_FALSE) {
          monitor_error ("cannot set breakpoint in that line", NO_TEXT);
        }
      } else if (match_string (mod, "Clear", NULL_CHAR)) {
        change_breakpoints (TOP_NODE (&A68G_JOB), NULL_MASK, k, NULL, NULL);
      } else {
        monitor_error ("invalid breakpoint command", NO_TEXT);
      }
    } else if (match_string (sym, "List", NULL_CHAR)) {
      int listed = 0;
      list_breakpoints (TOP_NODE (&A68G_JOB), &listed);
      if (listed == 0) {
        WRITELN (A68G_STDOUT, "No breakpoints set");
      }
      if (A68G_MON (watchpoint_expression) != NO_TEXT) {
        WRITELN (A68G_STDOUT, "Watchpoint condition \"");
        WRITE (A68G_STDOUT, A68G_MON (watchpoint_expression));
        WRITE (A68G_STDOUT, "\"");
      } else {
        WRITELN (A68G_STDOUT, "No watchpoint expression set");
      }
    } else if (match_string (sym, "Watch", BLANK_CHAR)) {
      char *cexpr = sym;
      SKIP_ONE_SYMBOL (cexpr);
      a68g_free (A68G_MON (watchpoint_expression));
      A68G_MON (watchpoint_expression) = NO_TEXT;
      A68G_MON (watchpoint_expression) = new_string (cexpr, NO_TEXT);
      change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_WATCH_MASK, A68G_TRUE);
    } else if (match_string (sym, "Clear", BLANK_CHAR)) {
      char *mod = sym;
      SKIP_ONE_SYMBOL (mod);
      if (mod[0] == NULL_CHAR) {
        change_breakpoints (TOP_NODE (&A68G_JOB), NULL_MASK, 0, NULL, NULL);
        a68g_free (A68G_MON (watchpoint_expression));
        A68G_MON (watchpoint_expression) = NO_TEXT;
        change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_WATCH_MASK, A68G_FALSE);
      } else if (match_string (mod, "ALL", NULL_CHAR)) {
        change_breakpoints (TOP_NODE (&A68G_JOB), NULL_MASK, 0, NULL, NULL);
        a68g_free (A68G_MON (watchpoint_expression));
        A68G_MON (watchpoint_expression) = NO_TEXT;
        change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_WATCH_MASK, A68G_FALSE);
      } else if (match_string (mod, "Breakpoints", NULL_CHAR)) {
        change_breakpoints (TOP_NODE (&A68G_JOB), NULL_MASK, 0, NULL, NULL);
      } else if (match_string (mod, "Watchpoint", NULL_CHAR)) {
        a68g_free (A68G_MON (watchpoint_expression));
        A68G_MON (watchpoint_expression) = NO_TEXT;
        change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_WATCH_MASK, A68G_FALSE);
      } else {
        monitor_error ("invalid breakpoint command", NO_TEXT);
      }
    } else {
      monitor_error ("invalid breakpoint command", NO_TEXT);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "List", BLANK_CHAR)) {
    char *cwhere;
    int n = get_num_arg (cmd, &cwhere);
    int m = get_num_arg (cwhere, NO_REF);
    if (m == NOT_A_NUM) {
      if (n > 0) {
        list (A68G_STDOUT, p, n, 0);
      } else if (n == NOT_A_NUM) {
        list (A68G_STDOUT, p, 10, 0);
      }
    } else if (n > 0 && m > 0 && n <= m) {
      list (A68G_STDOUT, p, n, m);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "PROmpt", BLANK_CHAR)) {
    char *sym = cmd;
    SKIP_ONE_SYMBOL (sym);
    if (sym[0] != NULL_CHAR) {
      if (sym[0] == QUOTE_CHAR) {
        sym++;
      }
      size_t len = strlen (sym);
      if (len > 0 && sym[len - 1] == QUOTE_CHAR) {
        sym[len - 1] = NULL_CHAR;
      }
      a68g_bufcpy (A68G_MON (prompt), sym, BUFFER_SIZE);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "RERun", NULL_CHAR) || match_string (cmd, "REStart", NULL_CHAR)) {
    if (confirm_exit ()) {
      exit_genie (p, A68G_RERUN);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "RESET", NULL_CHAR)) {
    if (confirm_exit ()) {
      change_breakpoints (TOP_NODE (&A68G_JOB), NULL_MASK, 0, NULL, NULL);
      a68g_free (A68G_MON (watchpoint_expression));
      A68G_MON (watchpoint_expression) = NO_TEXT;
      change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_WATCH_MASK, A68G_FALSE);
      exit_genie (p, A68G_RERUN);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "LINk", BLANK_CHAR)) {
    int k = get_num_arg (cmd, NO_REF), printed = 0;
    if (k > 0) {
      stack_a68g_link_dump (A68G_STDOUT, A68G_FP, k, &printed);
    } else if (k == NOT_A_NUM) {
      stack_a68g_link_dump (A68G_STDOUT, A68G_FP, 3, &printed);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "STAck", BLANK_CHAR) || match_string (cmd, "BT", BLANK_CHAR)) {
    int k = get_num_arg (cmd, NO_REF), printed = 0;
    if (k > 0) {
      stack_dump (A68G_STDOUT, A68G_FP, k, &printed);
    } else if (k == NOT_A_NUM) {
      stack_dump (A68G_STDOUT, A68G_FP, 3, &printed);
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "Next", NULL_CHAR)) {
    change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_TEMPORARY_MASK, A68G_TRUE);
    A68G (do_confirm_exit) = A68G_FALSE;
    A68G_MON (break_proc_level) = PROCEDURE_LEVEL (INFO (p));
    return A68G_TRUE;
  } else if (match_string (cmd, "STEp", NULL_CHAR)) {
    change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_TEMPORARY_MASK, A68G_TRUE);
    A68G (do_confirm_exit) = A68G_FALSE;
    return A68G_TRUE;
  } else if (match_string (cmd, "FINish", NULL_CHAR) || match_string (cmd, "OUT", NULL_CHAR)) {
    A68G_MON (finish_frame_pointer) = FRAME_PARAMETERS (A68G_FP);
    A68G (do_confirm_exit) = A68G_FALSE;
    return A68G_TRUE;
  } else if (match_string (cmd, "Until", BLANK_CHAR)) {
    int k = get_num_arg (cmd, NO_REF);
    if (k > 0) {
      BOOL_T set = A68G_FALSE;
      change_breakpoints (TOP_NODE (&A68G_JOB), BREAKPOINT_TEMPORARY_MASK, k, &set, NULL);
      if (set == A68G_FALSE) {
        monitor_error ("cannot set breakpoint in that line", NO_TEXT);
        return A68G_FALSE;
      }
      A68G (do_confirm_exit) = A68G_FALSE;
      return A68G_TRUE;
    } else {
      monitor_error ("line number expected", NO_TEXT);
      return A68G_FALSE;
    }
  } else if (match_string (cmd, "Where", NULL_CHAR)) {
    WIS (p);
    return A68G_FALSE;
  } else if (strcmp (cmd, "?") == 0) {
    apropos (A68G_STDOUT, A68G_MON (prompt), "monitor");
    return A68G_FALSE;
  } else if (match_string (cmd, "Sizes", NULL_CHAR)) {
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Frame stack pointer=" A68G_LU " available=" A68G_LU, A68G_FP, A68G (frame_stack_size) - A68G_FP) >= 0);
    WRITELN (A68G_STDOUT, A68G (output_line));
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Expression stack pointer=" A68G_LU " available=" A68G_LU, A68G_SP, (UNSIGNED_T) (A68G (expr_stack_size) - A68G_SP)) >= 0);
    WRITELN (A68G_STDOUT, A68G (output_line));
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Heap size=%u available=%u", A68G (heap_size), heap_available ()) >= 0);
    WRITELN (A68G_STDOUT, A68G (output_line));
    ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Garbage collections=" A68G_LD, A68G_GC (sweeps)) >= 0);
    WRITELN (A68G_STDOUT, A68G (output_line));
    return A68G_FALSE;
  } else if (match_string (cmd, "XRef", NULL_CHAR)) {
    int k = LINE_NUMBER (p);
    for (LINE_T *line = TOP_LINE (&A68G_JOB); line != NO_LINE; FORWARD (line)) {
      if (NUMBER (line) > 0 && NUMBER (line) == k) {
        list_source_line (A68G_STDOUT, line, A68G_TRUE);
      }
    }
    return A68G_FALSE;
  } else if (match_string (cmd, "XRef", BLANK_CHAR)) {
    int k = get_num_arg (cmd, NO_REF);
    if (k == NOT_A_NUM) {
      monitor_error ("line number expected", NO_TEXT);
    } else {
      for (LINE_T *line = TOP_LINE (&A68G_JOB); line != NO_LINE; FORWARD (line)) {
        if (NUMBER (line) > 0 && NUMBER (line) == k) {
          list_source_line (A68G_STDOUT, line, A68G_TRUE);
        }
      }
    }
    return A68G_FALSE;
  } else if (strlen (cmd) == 0) {
    return A68G_FALSE;
  } else {
    monitor_error ("unrecognised command", NO_TEXT);
    return A68G_FALSE;
  }
}

//! @brief Evaluate conditional breakpoint expression.

BOOL_T evaluate_breakpoint_expression (NODE_T * p)
{
  ADDR_T top_sp = A68G_SP;
  volatile BOOL_T res = A68G_FALSE;
  A68G_MON (mon_errors) = 0;
  if (EXPR (INFO (p)) != NO_TEXT) {
    evaluate (A68G_STDOUT, p, EXPR (INFO (p)));
    if (A68G_MON (_m_sp) != 1 || A68G_MON (mon_errors) != 0) {
      A68G_MON (mon_errors) = 0;
      monitor_error ("deleted invalid breakpoint expression", NO_TEXT);
      a68g_free (EXPR (INFO (p)));
      EXPR (INFO (p)) = A68G_MON (expr);
      res = A68G_TRUE;
    } else if (TOP_MODE == M_BOOL) {
      A68G_BOOL z;
      POP_OBJECT (p, &z, A68G_BOOL);
      res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68G_TRUE);
    } else {
      monitor_error ("deleted invalid breakpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
      a68g_free (EXPR (INFO (p)));
      EXPR (INFO (p)) = A68G_MON (expr);
      res = A68G_TRUE;
    }
  }
  A68G_SP = top_sp;
  return res;
}

//! @brief Evaluate conditional watchpoint expression.

BOOL_T evaluate_watchpoint_expression (NODE_T * p)
{
  ADDR_T top_sp = A68G_SP;
  volatile BOOL_T res = A68G_FALSE;
  A68G_MON (mon_errors) = 0;
  if (A68G_MON (watchpoint_expression) != NO_TEXT) {
    evaluate (A68G_STDOUT, p, A68G_MON (watchpoint_expression));
    if (A68G_MON (_m_sp) != 1 || A68G_MON (mon_errors) != 0) {
      A68G_MON (mon_errors) = 0;
      monitor_error ("deleted invalid watchpoint expression", NO_TEXT);
      a68g_free (A68G_MON (watchpoint_expression));
      A68G_MON (watchpoint_expression) = NO_TEXT;
      res = A68G_TRUE;
    }
    if (TOP_MODE == M_BOOL) {
      A68G_BOOL z;
      POP_OBJECT (p, &z, A68G_BOOL);
      res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68G_TRUE);
    } else {
      monitor_error ("deleted invalid watchpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE));
      a68g_free (A68G_MON (watchpoint_expression));
      A68G_MON (watchpoint_expression) = NO_TEXT;
      res = A68G_TRUE;
    }
  }
  A68G_SP = top_sp;
  return res;
}

//! @brief Execute monitor.

void single_step (NODE_T * p, unt mask)
{
  volatile BOOL_T do_cmd = A68G_TRUE;
  ADDR_T top_sp = A68G_SP;
  A68G_MON (current_frame) = 0;
  A68G_MON (max_row_elems) = MAX_ROW_ELEMS;
  A68G_MON (mon_errors) = 0;
  A68G_MON (tabs) = 0;
  A68G_MON (prompt_set) = A68G_FALSE;
  if (LINE_NUMBER (p) == 0) {
    return;
  }
#if defined (HAVE_CURSES)
  genie_curses_end (NO_NODE);
#endif
  if (mask == (unt) BREAKPOINT_ERROR_MASK) {
    WRITELN (A68G_STDOUT, "Monitor entered after an error");
    WIS ((p));
  } else if ((mask & BREAKPOINT_INTERRUPT_MASK) != 0) {
    WRITELN (A68G_STDOUT, NEWLINE_STRING);
    WIS ((p));
    if (A68G (do_confirm_exit) && confirm_exit ()) {
      exit_genie ((p), A68G_RUNTIME_ERROR + A68G_FORCE_QUIT);
    }
  } else if ((mask & BREAKPOINT_MASK) != 0) {
    if (EXPR (INFO (p)) != NO_TEXT) {
      if (!evaluate_breakpoint_expression (p)) {
        return;
      }
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Breakpoint (%s)", EXPR (INFO (p))) >= 0);
    } else {
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Breakpoint") >= 0);
    }
    WRITELN (A68G_STDOUT, A68G (output_line));
    WIS (p);
  } else if ((mask & BREAKPOINT_TEMPORARY_MASK) != 0) {
    if (A68G_MON (break_proc_level) != 0 && PROCEDURE_LEVEL (INFO (p)) > A68G_MON (break_proc_level)) {
      return;
    }
    change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_TEMPORARY_MASK, A68G_FALSE);
    WRITELN (A68G_STDOUT, "Temporary breakpoint (now removed)");
    WIS (p);
  } else if ((mask & BREAKPOINT_WATCH_MASK) != 0) {
    if (!evaluate_watchpoint_expression (p)) {
      return;
    }
    if (A68G_MON (watchpoint_expression) != NO_TEXT) {
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Watchpoint (%s)", A68G_MON (watchpoint_expression)) >= 0);
    } else {
      ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "Watchpoint (now removed)") >= 0);
    }
    WRITELN (A68G_STDOUT, A68G (output_line));
    WIS (p);
  } else if ((mask & BREAKPOINT_TRACE_MASK) != 0) {
    PROP_T *prop = &GPROP (p);
    WIS ((p));
    if (propagator_name ((PROP_PROC *) UNIT (prop)) != NO_TEXT) {
      WRITELN (A68G_STDOUT, propagator_name ((PROP_PROC *) UNIT (prop)));
    }
    return;
  } else {
    WRITELN (A68G_STDOUT, "Monitor entered with no valid reason (continuing execution)");
    WIS ((p));
    return;
  }
#if defined (BUILD_PARALLEL_CLAUSE)
  if (is_main_thread ()) {
    WRITELN (A68G_STDOUT, "This is the main thread");
  } else {
    WRITELN (A68G_STDOUT, "This is not the main thread");
  }
#endif
// Entry into the monitor.
  if (A68G_MON (prompt_set) == A68G_FALSE) {
    a68g_bufcpy (A68G_MON (prompt), "(a68g) ", BUFFER_SIZE);
    A68G_MON (prompt_set) = A68G_TRUE;
  }
  A68G_MON (in_monitor) = A68G_TRUE;
  A68G_MON (break_proc_level) = 0;
  change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_INTERRUPT_MASK, A68G_FALSE);
  STATUS_CLEAR (TOP_NODE (&A68G_JOB), BREAKPOINT_INTERRUPT_MASK);
  while (do_cmd) {
    char *cmd;
    A68G_SP = top_sp;
    io_close_tty_line ();
    while (strlen (cmd = read_string_from_tty (A68G_MON (prompt))) == 0) {;
    }
    if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) {
      a68g_bufcpy (cmd, LOGOUT_STRING, BUFFER_SIZE);
      WRITE (A68G_STDOUT, LOGOUT_STRING);
      WRITE (A68G_STDOUT, NEWLINE_STRING);
    }
    A68G_MON (_m_sp) = 0;
    do_cmd = (BOOL_T) (!single_stepper (p, cmd));
  }
  A68G_SP = top_sp;
  A68G_MON (in_monitor) = A68G_FALSE;
  if (mask == (unt) BREAKPOINT_ERROR_MASK) {
    WRITELN (A68G_STDOUT, "Continuing from an error might corrupt things");
    single_step (p, (unt) BREAKPOINT_ERROR_MASK);
  } else {
    WRITELN (A68G_STDOUT, "Continuing ...");
    WRITELN (A68G_STDOUT, "");
  }
}

//! @brief PROC debug = VOID

void genie_debug (NODE_T * p)
{
  single_step (p, BREAKPOINT_INTERRUPT_MASK);
}

//! @brief PROC break = VOID

void genie_break (NODE_T * p)
{
  (void) p;
  change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_INTERRUPT_MASK, A68G_TRUE);
}

//! @brief PROC evaluate = (STRING) STRING

void genie_evaluate (NODE_T * p)
{
// Pop argument.
  A68G_REF u;
  POP_REF (p, (A68G_REF *) & u);
  volatile ADDR_T top_sp = A68G_SP;
  CHECK_MON_REF (p, u, M_STRING);
  reset_transput_buffer (UNFORMATTED_BUFFER);
  add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u);
  A68G_REF v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
// Evaluate in the monitor.
  A68G_MON (in_monitor) = A68G_TRUE;
  A68G_MON (mon_errors) = 0;
  evaluate (A68G_STDOUT, p, get_transput_buffer (UNFORMATTED_BUFFER));
  A68G_MON (in_monitor) = A68G_FALSE;
  if (A68G_MON (_m_sp) != 1) {
    monitor_error ("invalid expression", NO_TEXT);
  }
  if (A68G_MON (mon_errors) == 0) {
    BOOL_T cont = A68G_TRUE;
    while (cont) {
      MOID_T *res = TOP_MODE;
      cont = (BOOL_T) (IS_REF (res) && !IS_NIL (*(A68G_REF *) STACK_ADDRESS (top_sp)));
      if (cont) {
        A68G_REF w;
        POP_REF (p, &w);
        TOP_MODE = SUB (TOP_MODE);
        PUSH (p, ADDRESS (&w), SIZE (TOP_MODE));
      }
    }
    reset_transput_buffer (UNFORMATTED_BUFFER);
    genie_write_standard (p, TOP_MODE, STACK_ADDRESS (top_sp), nil_ref);
    v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
  }
  A68G_SP = top_sp;
  PUSH_REF (p, v);
}

//! @brief PROC abend = (STRING) VOID

void genie_abend (NODE_T * p)
{
  A68G_REF u;
  POP_REF (p, (A68G_REF *) & u);
  reset_transput_buffer (UNFORMATTED_BUFFER);
  add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u);
  diagnostic (A68G_RUNTIME_ERROR | A68G_NO_SYNTHESIS, p, get_transput_buffer (UNFORMATTED_BUFFER), NO_TEXT);
  exit_genie (p, A68G_RUNTIME_ERROR);
}
