//! @file rts-formatted.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@xs4all.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 
//!
//! Formatted transput.

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

// Transput - Formatted transput.
// In Algol68G, a value of mode FORMAT looks like a routine text. The value
// comprises a pointer to its environment in the stack, and a pointer where the
// format text is at in the syntax tree.

#define INT_DIGITS "0123456789"
#define BITS_DIGITS "0123456789abcdefABCDEF"
#define INT_DIGITS_BLANK " 0123456789"
#define BITS_DIGITS_BLANK " 0123456789abcdefABCDEF"
#define SIGN_DIGITS " +-"

//! @brief Convert to other radix, binary up to hexadecimal.

BOOL_T convert_radix (NODE_T * p, UNSIGNED_T z, int radix, int width)
{
  reset_transput_buffer (EDIT_BUFFER);
  if (radix < 2 || radix > 16) {
    radix = 16;
  }
  if (width > 0) {
    while (width > 0) {
      int digit = (int) (z % (UNSIGNED_T) radix);
      plusto_transput_buffer (p, digchar (digit), EDIT_BUFFER);
      width--;
      z /= (UNSIGNED_T) radix;
    }
    return z == 0;
  } else if (width == 0) {
    do {
      int digit = (int) (z % (UNSIGNED_T) radix);
      plusto_transput_buffer (p, digchar (digit), EDIT_BUFFER);
      z /= (UNSIGNED_T) radix;
    } while (z > 0);
    return A68G_TRUE;
  } else {
    return A68G_FALSE;
  }
}

//! @brief Handle format error event.

void format_error (NODE_T * p, A68G_REF ref_file, char *diag)
{
  A68G_FILE *f = FILE_DEREF (&ref_file);
  on_event_handler (p, FORMAT_ERROR_MENDED (f), ref_file);
  A68G_BOOL z;
  POP_OBJECT (p, &z, A68G_BOOL);
  if (VALUE (&z) == A68G_FALSE) {
    diagnostic (A68G_RUNTIME_ERROR, p, diag);
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
}

//! @brief Initialise processing of pictures.

void initialise_collitems (NODE_T * p)
{
// Every picture has a counter that says whether it has not been used OR the number
// of times it can still be used.
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, PICTURE)) {
      A68G_COLLITEM *z = (A68G_COLLITEM *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (p)));
      STATUS (z) = INIT_MASK;
      COUNT (z) = ITEM_NOT_USED;
    }
// Don't dive into f, g, n frames and collections.
    if (!(IS (p, ENCLOSED_CLAUSE) || IS (p, COLLECTION))) {
      initialise_collitems (SUB (p));
    }
  }
}

//! @brief Initialise processing of format text.

void open_format_frame (NODE_T * p, A68G_REF ref_file, A68G_FORMAT * fmt, BOOL_T embedded, BOOL_T init)
{
// Open a new frame for the format text and save for return to embedding one.
  A68G_FILE *file = FILE_DEREF (&ref_file);
// Integrity check.
  if ((STATUS (fmt) & SKIP_FORMAT_MASK) || (BODY (fmt) == NO_NODE)) {
    format_error (p, ref_file, ERROR_FORMAT_UNDEFINED);
  }
// Ok, seems usable.
  NODE_T *dollar = SUB (BODY (fmt));
  OPEN_PROC_FRAME (dollar, ENVIRON (fmt));
  INIT_STATIC_FRAME (dollar);
// Save old format.
  A68G_FORMAT *save = (A68G_FORMAT *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (dollar)));
  *save = (embedded == EMBEDDED_FORMAT ? FORMAT (file) : nil_format);
  FORMAT (file) = *fmt;
// Reset all collitems.
  if (init) {
    initialise_collitems (dollar);
  }
}

//! @brief Handle end-of-format event.

int end_of_format (NODE_T * p, A68G_REF ref_file)
{
// Format-items return immediately to the embedding format text. The outermost
//format text calls "on format end".
  A68G_FILE *file = FILE_DEREF (&ref_file);
  NODE_T *dollar = SUB (BODY (&FORMAT (file)));
  A68G_FORMAT *save = (A68G_FORMAT *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (dollar)));
  if (IS_NIL_FORMAT (save)) {
// Not embedded, outermost format: execute event routine.
    on_event_handler (p, FORMAT_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
    A68G_BOOL z;
    POP_OBJECT (p, &z, A68G_BOOL);
    if (VALUE (&z) == A68G_FALSE) {
// Restart format.
      A68G_FP = FRAME_POINTER (file);
      A68G_SP = STACK_POINTER (file);
      open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68G_TRUE);
    }
    return NOT_EMBEDDED_FORMAT;
  } else {
// Embedded format, return to embedding format, cf. RR.
    CLOSE_FRAME;
    FORMAT (file) = *save;
    return EMBEDDED_FORMAT;
  }
}

//! @brief Return integral value of replicator.

int get_replicator_value (NODE_T * p, BOOL_T check)
{
  int z = 0;
  if (IS (p, STATIC_REPLICATOR)) {
    A68G_INT u;
    if (genie_string_to_value_internal (p, M_INT, NSYMBOL (p), (BYTE_T *) & u) == A68G_FALSE) {
      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_INT);
      exit_genie (p, A68G_RUNTIME_ERROR);
    }
    z = VALUE (&u);
  } else if (IS (p, DYNAMIC_REPLICATOR)) {
    A68G_INT u;
    GENIE_UNIT (NEXT_SUB (p));
    POP_OBJECT (p, &u, A68G_INT);
    z = VALUE (&u);
  } else if (IS (p, REPLICATOR)) {
    z = get_replicator_value (SUB (p), check);
  }
// Not conform RR as Andrew Herbert rightfully pointed out.
//  if (check && z < 0) {
//    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_INVALID_REPLICATOR);
//    exit_genie (p, A68G_RUNTIME_ERROR);
//  }
  if (z < 0) {
    z = 0;
  }
  return z;
}

//! @brief Return first available pattern.

NODE_T *scan_format_pattern (NODE_T * p, A68G_REF ref_file)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, PICTURE_LIST)) {
      NODE_T *prio = scan_format_pattern (SUB (p), ref_file);
      if (prio != NO_NODE) {
        return prio;
      }
    }
    if (IS (p, PICTURE)) {
      NODE_T *picture = SUB (p);
      A68G_COLLITEM *collitem = (A68G_COLLITEM *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (p)));
      if (COUNT (collitem) != 0) {
        if (IS (picture, A68G_PATTERN)) {
          COUNT (collitem) = 0; // This pattern is now done
          picture = SUB (picture);
          if (ATTRIBUTE (picture) != FORMAT_PATTERN) {
            return picture;
          } else {
            NODE_T *pat;
            A68G_FORMAT z;
            A68G_FILE *file = FILE_DEREF (&ref_file);
            GENIE_UNIT (NEXT_SUB (picture));
            POP_OBJECT (p, &z, A68G_FORMAT);
            open_format_frame (p, ref_file, &z, EMBEDDED_FORMAT, A68G_TRUE);
            pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
            if (pat != NO_NODE) {
              return pat;
            } else {
              (void) end_of_format (p, ref_file);
            }
          }
        } else if (IS (picture, INSERTION)) {
          A68G_FILE *file = FILE_DEREF (&ref_file);
          if (READ_MOOD (file)) {
            read_insertion (picture, ref_file);
          } else if (WRITE_MOOD (file)) {
            write_insertion (picture, ref_file, INSERTION_NORMAL);
          } else {
            ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
          }
          COUNT (collitem) = 0; // This insertion is now done
        } else if (IS (picture, REPLICATOR) || IS (picture, COLLECTION)) {
          BOOL_T siga = A68G_TRUE;
          NODE_T *a68g_select = NO_NODE;
          if (COUNT (collitem) == ITEM_NOT_USED) {
            if (IS (picture, REPLICATOR)) {
              COUNT (collitem) = get_replicator_value (SUB (p), A68G_TRUE);
              siga = (BOOL_T) (COUNT (collitem) > 0);
              FORWARD (picture);
            } else {
              COUNT (collitem) = 1;
            }
            initialise_collitems (NEXT_SUB (picture));
          } else if (IS (picture, REPLICATOR)) {
            FORWARD (picture);
          }
          while (siga) {
// Get format item from collection. If collection is done, but repitition is not,
// then re-initialise the collection and repeat.
            a68g_select = scan_format_pattern (NEXT_SUB (picture), ref_file);
            if (a68g_select != NO_NODE) {
              return a68g_select;
            } else {
              COUNT (collitem)--;
              siga = (BOOL_T) (COUNT (collitem) > 0);
              if (siga) {
                initialise_collitems (NEXT_SUB (picture));
              }
            }
          }
        }
      }
    }
  }
  return NO_NODE;
}

//! @brief Return first available pattern.

NODE_T *get_next_format_pattern (NODE_T * p, A68G_REF ref_file, BOOL_T mood)
{
// "mood" can be WANT_PATTERN: pattern needed by caller, so perform end-of-format
// if needed or SKIP_PATTERN: just emptying current pattern/collection/format.
  A68G_FILE *file = FILE_DEREF (&ref_file);
  if (BODY (&FORMAT (file)) == NO_NODE) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
    exit_genie (p, A68G_RUNTIME_ERROR);
    return NO_NODE;
  } else {
    NODE_T *pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
    if (pat == NO_NODE) {
      if (mood == WANT_PATTERN) {
        int z;
        do {
          z = end_of_format (p, ref_file);
          pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
        } while (z == EMBEDDED_FORMAT && pat == NO_NODE);
        if (pat == NO_NODE) {
          diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
          exit_genie (p, A68G_RUNTIME_ERROR);
        }
      }
    }
    return pat;
  }
}

//! @brief Diagnostic_node in case mode does not match picture.

void pattern_error (NODE_T * p, MOID_T * mode, int att)
{
  diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_CANNOT_TRANSPUT, mode, att);
  exit_genie (p, A68G_RUNTIME_ERROR);
}

//! @brief Unite value at top of stack to NUMBER.

void unite_to_number (NODE_T * p, MOID_T * mode, BYTE_T * item)
{
  ADDR_T pop_sp = A68G_SP;
  PUSH_UNION (p, mode);
  PUSH (p, item, (int) SIZE (mode));
  A68G_SP = pop_sp + SIZE (M_NUMBER);
}

//! @brief Write a group of insertions.

void write_insertion (NODE_T * p, A68G_REF ref_file, MOOD_T mood)
{
  for (; p != NO_NODE; FORWARD (p)) {
    write_insertion (SUB (p), ref_file, mood);
    if (IS (p, FORMAT_ITEM_L)) {
      plusab_transput_buffer (p, FORMATTED_BUFFER, NEWLINE_CHAR);
      write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
    } else if (IS (p, FORMAT_ITEM_P)) {
      plusab_transput_buffer (p, FORMATTED_BUFFER, FORMFEED_CHAR);
      write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
    } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
      plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
    } else if (IS (p, FORMAT_ITEM_Y)) {
      PUSH_REF (p, ref_file);
      PUSH_VALUE (p, -1, A68G_INT);
      genie_set (p);
    } else if (IS (p, LITERAL)) {
      if (mood & INSERTION_NORMAL) {
        add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
      } else if (mood & INSERTION_BLANK) {
        size_t k = strlen (NSYMBOL (p));
        for (size_t j = 1; j <= k; j++) {
          plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
        }
      }
    } else if (IS (p, REPLICATOR)) {
      int k = get_replicator_value (SUB (p), A68G_TRUE);
      if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
        for (int j = 1; j <= k; j++) {
          write_insertion (NEXT (p), ref_file, mood);
        }
      } else {
        int pos = get_transput_buffer_index (FORMATTED_BUFFER);
        for (int j = 1; j < (k - pos); j++) {
          plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
        }
      }
      return;
    }
  }
}

//! @brief Write string to file following current format.

void write_string_pattern (NODE_T * p, MOID_T * mode, A68G_REF ref_file, char **str)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, INSERTION)) {
      write_insertion (SUB (p), ref_file, INSERTION_NORMAL);
    } else if (IS (p, FORMAT_ITEM_A)) {
      if ((*str)[0] != NULL_CHAR) {
        plusab_transput_buffer (p, FORMATTED_BUFFER, (*str)[0]);
        (*str)++;
      } else {
        value_error (p, mode, ref_file);
      }
    } else if (IS (p, FORMAT_ITEM_S)) {
      if ((*str)[0] != NULL_CHAR) {
        (*str)++;
      } else {
        value_error (p, mode, ref_file);
      }
      return;
    } else if (IS (p, REPLICATOR)) {
      int k = get_replicator_value (SUB (p), A68G_TRUE);
      for (int j = 1; j <= k; j++) {
        write_string_pattern (NEXT (p), mode, ref_file, str);
      }
      return;
    } else {
      write_string_pattern (SUB (p), mode, ref_file, str);
    }
  }
}

//! @brief Scan c_pattern.

void scan_c_pattern (NODE_T * p, BOOL_T * right_align, BOOL_T * sign, int *width, int *after, int *letter)
{
  if (IS (p, FORMAT_ITEM_ESCAPE)) {
    FORWARD (p);
  }
  if (IS (p, FORMAT_ITEM_MINUS)) {
    *right_align = A68G_TRUE;
    FORWARD (p);
  } else {
    *right_align = A68G_FALSE;
  }
  if (IS (p, FORMAT_ITEM_PLUS)) {
    *sign = A68G_TRUE;
    FORWARD (p);
  } else {
    *sign = A68G_FALSE;
  }
  if (IS (p, REPLICATOR)) {
    *width = get_replicator_value (SUB (p), A68G_TRUE);
    FORWARD (p);
  }
  if (IS (p, FORMAT_ITEM_POINT)) {
    FORWARD (p);
  }
  if (IS (p, REPLICATOR)) {
    *after = get_replicator_value (SUB (p), A68G_TRUE);
    FORWARD (p);
  }
  *letter = ATTRIBUTE (p);
}

//! @brief Write appropriate insertion from a choice pattern.

void write_choice_pattern (NODE_T * p, A68G_REF ref_file, int *count)
{
  for (; p != NO_NODE; FORWARD (p)) {
    write_choice_pattern (SUB (p), ref_file, count);
    if (IS (p, PICTURE)) {
      (*count)--;
      if (*count == 0) {
        write_insertion (SUB (p), ref_file, INSERTION_NORMAL);
      }
    }
  }
}

//! @brief Write appropriate insertion from a boolean pattern.

void write_boolean_pattern (NODE_T * p, A68G_REF ref_file, BOOL_T z)
{
  int k = (z ? 1 : 2);
  write_choice_pattern (p, ref_file, &k);
}

//! @brief Write value according to a general pattern.

void write_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, int mod)
{
// Push arguments.
  unite_to_number (p, mode, item);
  GENIE_UNIT (NEXT_SUB (p));
  A68G_REF row;
  POP_REF (p, &row);
  A68G_ARRAY *arr; A68G_TUPLE *tup;
  GET_DESCRIPTOR (arr, tup, &row);
  size_t size = ROW_SIZE (tup);
  if (size > 0) {
    BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
    for (int i = LWB (tup); i <= UPB (tup); i++) {
      int addr = INDEX_1_DIM (arr, tup, i);
      int arg = VALUE ((A68G_INT *) & (base_address[addr]));
      PUSH_VALUE (p, arg, A68G_INT);
    }
  }
// Make a string.
  if (mod == FORMAT_ITEM_G) {
    switch (size) {
    case 1: {
        genie_whole (p);
        break;
      }
    case 2: {
        genie_fixed (p);
        break;
      }
    case 3: {
        genie_float (p);
        break;
      }
    default: {
        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
        exit_genie (p, A68G_RUNTIME_ERROR);
        break;
      }
    }
  } else if (mod == FORMAT_ITEM_H) {
    A68G_INT a_width, a_after, a_expo, a_mult;
    STATUS (&a_width) = INIT_MASK;
    VALUE (&a_width) = 0;
    STATUS (&a_after) = INIT_MASK;
    VALUE (&a_after) = 0;
    STATUS (&a_expo) = INIT_MASK;
    VALUE (&a_expo) = 0;
    STATUS (&a_mult) = INIT_MASK;
    VALUE (&a_mult) = 0;
// Set default values 
    int def_expo = 0, def_mult = 3;
    if (mode == M_REAL || mode == M_INT) {
      def_expo = A68G_EXP_WIDTH + 1;
    } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
      def_expo = A68G_LONG_EXP_WIDTH + 1;
    } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
      def_expo = A68G_LONG_LONG_EXP_WIDTH + 1;
    }
// Pop user values 
    switch (size) {
    case 1: {
        POP_OBJECT (p, &a_after, A68G_INT);
        VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
        VALUE (&a_expo) = def_expo;
        VALUE (&a_mult) = def_mult;
        break;
      }
    case 2: {
        POP_OBJECT (p, &a_mult, A68G_INT);
        POP_OBJECT (p, &a_after, A68G_INT);
        VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
        VALUE (&a_expo) = def_expo;
        break;
      }
    case 3: {
        POP_OBJECT (p, &a_mult, A68G_INT);
        POP_OBJECT (p, &a_after, A68G_INT);
        POP_OBJECT (p, &a_width, A68G_INT);
        VALUE (&a_expo) = def_expo;
        break;
      }
    case 4: {
        POP_OBJECT (p, &a_mult, A68G_INT);
        POP_OBJECT (p, &a_expo, A68G_INT);
        POP_OBJECT (p, &a_after, A68G_INT);
        POP_OBJECT (p, &a_width, A68G_INT);
        break;
      }
    default: {
        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
        exit_genie (p, A68G_RUNTIME_ERROR);
        break;
      }
    }
    PUSH_VALUE (p, VALUE (&a_width), A68G_INT);
    PUSH_VALUE (p, VALUE (&a_after), A68G_INT);
    PUSH_VALUE (p, VALUE (&a_expo), A68G_INT);
    PUSH_VALUE (p, VALUE (&a_mult), A68G_INT);
    genie_real (p);
  }
  add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
}

//! @brief Write %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.

void write_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
{
  ADDR_T pop_sp = A68G_SP;
  BOOL_T right_align, sign, invalid;
  int width = 0, after = 0, letter;
  char *str = NO_TEXT;
  char tmp[2]; // In same scope as str!
  if (IS (p, CHAR_C_PATTERN)) {
    A68G_CHAR *z = (A68G_CHAR *) item;
    tmp[0] = (char) VALUE (z);
    tmp[1] = NULL_CHAR;
    str = (char *) &tmp;
    width = (int) strlen (str);
    scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
  } else if (IS (p, STRING_C_PATTERN)) {
    str = (char *) item;
    width = (int) strlen (str);
    scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
  } else if (IS (p, INTEGRAL_C_PATTERN)) {
    width = 0;
    scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
    unite_to_number (p, mode, item);
    PUSH_VALUE (p, (sign ? width : -width), A68G_INT);
    str = whole (p);
  } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
    int att = ATTRIBUTE (p), expval = 0, expo = 0;
    if (att == FLOAT_C_PATTERN || att == GENERAL_C_PATTERN) {
      int digits = 0;
      if (mode == M_REAL || mode == M_INT) {
        width = A68G_REAL_WIDTH + A68G_EXP_WIDTH + 4;
        after = A68G_REAL_WIDTH - 1;
        expo = A68G_EXP_WIDTH + 1;
      } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
        width = A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4;
        after = A68G_LONG_REAL_WIDTH - 1;
        expo = A68G_LONG_EXP_WIDTH + 1;
      } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
        width = A68G_LONG_LONG_REAL_WIDTH + A68G_LONG_LONG_EXP_WIDTH + 4;
        after = A68G_LONG_LONG_REAL_WIDTH - 1;
        expo = A68G_LONG_LONG_EXP_WIDTH + 1;
      }
      scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
      if (digits == 0 && after > 0) {
        width = after + expo + 4;
      } else if (digits > 0) {
        width = digits;
      }
      unite_to_number (p, mode, item);
      PUSH_VALUE (p, (sign ? width : -width), A68G_INT);
      PUSH_VALUE (p, after, A68G_INT);
      PUSH_VALUE (p, expo, A68G_INT);
      PUSH_VALUE (p, 1, A68G_INT);
      str = real (p);
      A68G_SP = pop_sp;
    }
    if (att == GENERAL_C_PATTERN) {
      char *expch = strchr (str, EXPONENT_CHAR);
      if (expch != NO_TEXT) {
        expval = (int) strtol (&(expch[1]), NO_REF, 10);
      }
    }
    if ((att == FIXED_C_PATTERN) || (att == GENERAL_C_PATTERN && (expval > -4 && expval <= after))) {
      int digits = 0;
      if (mode == M_REAL || mode == M_INT) {
        width = A68G_REAL_WIDTH + 2;
        after = A68G_REAL_WIDTH - 1;
      } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
        width = A68G_LONG_REAL_WIDTH + 2;
        after = A68G_LONG_REAL_WIDTH - 1;
      } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
        width = A68G_LONG_LONG_REAL_WIDTH + 2;
        after = A68G_LONG_LONG_REAL_WIDTH - 1;
      }
      scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
      if (digits == 0) {
        width = 0;
      } else if (digits > 0) {
        width = digits + after + 2;
      }
      unite_to_number (p, mode, item);
      PUSH_VALUE (p, (sign ? width : -width), A68G_INT);
      PUSH_VALUE (p, after, A68G_INT);
      str = fixed (p);
      A68G_SP = pop_sp;
    }
  } else if (IS (p, BITS_C_PATTERN)) {
    int radix = 10, nibble = 1;
    width = 0;
    scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
    if (letter == FORMAT_ITEM_B) {
      radix = 2;
      nibble = 1;
    } else if (letter == FORMAT_ITEM_O) {
      radix = 8;
      nibble = 3;
    } else if (letter == FORMAT_ITEM_X) {
      radix = 16;
      nibble = 4;
    }
    if (width == 0) {
      if (mode == M_BITS) {
        width = (int) ceil ((REAL_T) A68G_BITS_WIDTH / (REAL_T) nibble);
      } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
        #if (A68G_LEVEL <= 2)
          width = (int) ceil ((REAL_T) get_mp_bits_width (mode) / (REAL_T) nibble);
        #else
          width = (int) ceil ((REAL_T) A68G_LONG_BITS_WIDTH / (REAL_T) nibble);
        #endif
      }
    }
    if (mode == M_BITS) {
      A68G_BITS *z = (A68G_BITS *) item;
      reset_transput_buffer (EDIT_BUFFER);
      if (!convert_radix (p, VALUE (z), radix, width)) {
        errno = EDOM;
        value_error (p, mode, ref_file);
      }
      str = get_transput_buffer (EDIT_BUFFER);
    } else if (mode == M_LONG_BITS) {
      #if (A68G_LEVEL >= 3)
        A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
        reset_transput_buffer (EDIT_BUFFER);
        if (!convert_radix_double (p, VALUE (z), radix, width)) {
          errno = EDOM;
          value_error (p, mode, ref_file);
        }
        str = get_transput_buffer (EDIT_BUFFER);
      #else
        int digits = DIGITS (mode);
        MP_T *u = (MP_T *) item;
        MP_T *v = nil_mp (p, digits);
        MP_T *w = nil_mp (p, digits);
        reset_transput_buffer (EDIT_BUFFER);
        if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
          errno = EDOM;
          value_error (p, mode, ref_file);
        }
        str = get_transput_buffer (EDIT_BUFFER);
      #endif
    } else if (mode == M_LONG_LONG_BITS) {
      #if (A68G_LEVEL <= 2)
        int digits = DIGITS (mode);
        MP_T *u = (MP_T *) item;
        MP_T *v = nil_mp (p, digits);
        MP_T *w = nil_mp (p, digits);
        reset_transput_buffer (EDIT_BUFFER);
        if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
          errno = EDOM;
          value_error (p, mode, ref_file);
        }
        str = get_transput_buffer (EDIT_BUFFER);
      #endif
    }
  }
// Did the conversion succeed?.
  if (IS (p, CHAR_C_PATTERN) || IS (p, STRING_C_PATTERN)) {
    invalid = A68G_FALSE;
  } else {
    invalid = (strchr (str, ERROR_CHAR) != NO_TEXT);
  }
  if (invalid) {
    value_error (p, mode, ref_file);
    (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
  } else {
// Align and output.
    if (width == 0) {
      add_string_transput_buffer (p, FORMATTED_BUFFER, str);
    } else {
      if (right_align == A68G_TRUE) {
        while (str[0] == BLANK_CHAR) {
          str++;
        }
        int blanks = width - strlen (str);
        if (blanks >= 0) {
          add_string_transput_buffer (p, FORMATTED_BUFFER, str);
          while (blanks--) {
            plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
          }
        } else {
          value_error (p, mode, ref_file);
          (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
        }
      } else {
        while (str[0] == BLANK_CHAR) {
          str++;
        }
        int blanks = width - strlen (str);
        if (blanks >= 0) {
          while (blanks--) {
            plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
          }
          add_string_transput_buffer (p, FORMATTED_BUFFER, str);
        } else {
          value_error (p, mode, ref_file);
          (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
        }
      }
    }
  }
}

//! @brief Read one char from file.

char read_single_char (NODE_T * p, A68G_REF ref_file)
{
  A68G_FILE *file = FILE_DEREF (&ref_file);
  int ch = char_scanner (file);
  if (ch == EOF_CHAR) {
    end_of_file_error (p, ref_file);
  }
  return (char) ch;
}

//! @brief Scan n chars from file to input buffer.

void scan_n_chars (NODE_T * p, int n, MOID_T * m, A68G_REF ref_file)
{
  (void) m;
  for (int k = 0; k < n; k++) {
    int ch = read_single_char (p, ref_file);
    plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
  }
}

//! @brief Read %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.

void read_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
{
  ADDR_T pop_sp = A68G_SP;
  BOOL_T right_align, sign;
  int width, after, letter;
  reset_transput_buffer (INPUT_BUFFER);
  if (IS (p, CHAR_C_PATTERN)) {
    width = 0;
    scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
    if (width == 0) {
      genie_read_standard (p, mode, item, ref_file);
    } else {
      scan_n_chars (p, width, mode, ref_file);
      if (width > 1 && right_align == A68G_FALSE) {
        for (; width > 1; width--) {
          (void) pop_char_transput_buffer (INPUT_BUFFER);
        }
      }
      genie_string_to_value (p, mode, item, ref_file);
    }
  } else if (IS (p, STRING_C_PATTERN)) {
    width = 0;
    scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
    if (width == 0) {
      genie_read_standard (p, mode, item, ref_file);
    } else {
      scan_n_chars (p, width, mode, ref_file);
      genie_string_to_value (p, mode, item, ref_file);
    }
  } else if (IS (p, INTEGRAL_C_PATTERN)) {
    if (mode != M_INT && mode != M_LONG_INT && mode != M_LONG_LONG_INT) {
      pattern_error (p, mode, ATTRIBUTE (p));
    } else {
      width = 0;
      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
      if (width == 0) {
        genie_read_standard (p, mode, item, ref_file);
      } else {
        scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
        genie_string_to_value (p, mode, item, ref_file);
      }
    }
  } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
    if (mode != M_REAL && mode != M_LONG_REAL && mode != M_LONG_LONG_REAL) {
      pattern_error (p, mode, ATTRIBUTE (p));
    } else {
      width = 0;
      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
      if (width == 0) {
        genie_read_standard (p, mode, item, ref_file);
      } else {
        scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
        genie_string_to_value (p, mode, item, ref_file);
      }
    }
  } else if (IS (p, BITS_C_PATTERN)) {
    if (mode != M_BITS && mode != M_LONG_BITS && mode != M_LONG_LONG_BITS) {
      pattern_error (p, mode, ATTRIBUTE (p));
    } else {
      int radix = 10;
      char *str;
      width = 0;
      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
      if (letter == FORMAT_ITEM_B) {
        radix = 2;
      } else if (letter == FORMAT_ITEM_O) {
        radix = 8;
      } else if (letter == FORMAT_ITEM_X) {
        radix = 16;
      }
      str = get_transput_buffer (INPUT_BUFFER);
      if (width == 0) {
        A68G_FILE *file = FILE_DEREF (&ref_file);
        int ch;
        ASSERT (a68g_bufprt (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
        set_transput_buffer_index (INPUT_BUFFER, strlen (str));
        ch = char_scanner (file);
        while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
          if (IS_NL_FF (ch)) {
            skip_nl_ff (p, &ch, ref_file);
          } else {
            ch = char_scanner (file);
          }
        }
        while (ch != EOF_CHAR && IS_XDIGIT (ch)) {
          plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
          ch = char_scanner (file);
        }
        unchar_scanner (p, file, (char) ch);
      } else {
        ASSERT (a68g_bufprt (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
        set_transput_buffer_index (INPUT_BUFFER, strlen (str));
        scan_n_chars (p, width, mode, ref_file);
      }
      genie_string_to_value (p, mode, item, ref_file);
    }
  }
  A68G_SP = pop_sp;
}

// INTEGRAL, REAL, COMPLEX and BITS patterns.

//! @brief Count Z and D frames in a mould.

void count_zd_frames (NODE_T * p, int *z)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, FORMAT_ITEM_D) || IS (p, FORMAT_ITEM_Z)) {
      (*z)++;
    } else if (IS (p, REPLICATOR)) {
      int k = get_replicator_value (SUB (p), A68G_TRUE);
      for (int j = 1; j <= k; j++) {
        count_zd_frames (NEXT (p), z);
      }
      return;
    } else {
      count_zd_frames (SUB (p), z);
    }
  }
}

//! @brief Get sign from sign mould.

NODE_T *get_sign (NODE_T * p)
{
  for (; p != NO_NODE; FORWARD (p)) {
    NODE_T *q = get_sign (SUB (p));
    if (q != NO_NODE) {
      return q;
    } else if (IS (p, FORMAT_ITEM_PLUS) || IS (p, FORMAT_ITEM_MINUS)) {
      return p;
    }
  }
  return NO_NODE;
}

//! @brief Shift sign through Z frames until non-zero digit or D frame.

void shift_sign (NODE_T * p, char **q)
{
  for (; p != NO_NODE && (*q) != NO_TEXT; FORWARD (p)) {
    shift_sign (SUB (p), q);
    if (IS (p, FORMAT_ITEM_Z)) {
      if (((*q)[0] == '+' || (*q)[0] == '-') && (*q)[1] == '0') {
        char ch = (*q)[0];
        (*q)[0] = (*q)[1];
        (*q)[1] = ch;
        (*q)++;
      }
    } else if (IS (p, FORMAT_ITEM_D)) {
      (*q) = NO_TEXT;
    } else if (IS (p, REPLICATOR)) {
      int k = get_replicator_value (SUB (p), A68G_TRUE);
      for (int j = 1; j <= k; j++) {
        shift_sign (NEXT (p), q);
      }
      return;
    }
  }
}

//! @brief Pad trailing blanks to integral until desired width.

void put_zeroes_to_integral (NODE_T * p, int n)
{
  for (; n > 0; n--) {
    plusab_transput_buffer (p, EDIT_BUFFER, '0');
  }
}

//! @brief Pad a sign to integral representation.

void put_sign_to_integral (NODE_T * p, int sign)
{
  NODE_T *sign_node = get_sign (SUB (p));
  if (IS (sign_node, FORMAT_ITEM_PLUS)) {
    plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? '+' : '-'));
  } else {
    plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? BLANK_CHAR : '-'));
  }
}

//! @brief Write point, exponent or plus-i-times symbol.

void write_pie_frame (NODE_T * p, A68G_REF ref_file, int att, int sym)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, INSERTION)) {
      write_insertion (p, ref_file, INSERTION_NORMAL);
    } else if (IS (p, att)) {
      write_pie_frame (SUB (p), ref_file, att, sym);
      return;
    } else if (IS (p, sym)) {
      add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
    } else if (IS (p, FORMAT_ITEM_S)) {
      return;
    }
  }
}

//! @brief Write sign when appropriate.

void write_mould_put_sign (NODE_T * p, char **q)
{
  if ((*q)[0] == '+' || (*q)[0] == '-' || (*q)[0] == BLANK_CHAR) {
    plusab_transput_buffer (p, FORMATTED_BUFFER, (*q)[0]);
    (*q)++;
  }
}

//! @brief Write character according to a mould.

void add_char_mould (NODE_T * p, char ch, char **q)
{
  if (ch != NULL_CHAR) {
    plusab_transput_buffer (p, FORMATTED_BUFFER, ch);
    (*q)++;
  }
}

//! @brief Write string according to a mould.

void write_mould (NODE_T * p, A68G_REF ref_file, int type, char **q, MOOD_T * mood)
{
  for (; p != NO_NODE; FORWARD (p)) {
// Insertions are inserted straight away. Note that we can suppress them using "mood", which is not standard A68.
    if (IS (p, INSERTION)) {
      write_insertion (SUB (p), ref_file, *mood);
    } else {
      write_mould (SUB (p), ref_file, type, q, mood);
// Z frames print blanks until first non-zero digits comes.
      if (IS (p, FORMAT_ITEM_Z)) {
        write_mould_put_sign (p, q);
        if ((*q)[0] == '0') {
          if (*mood & DIGIT_BLANK) {
            add_char_mould (p, BLANK_CHAR, q);
            *mood = (*mood & ~INSERTION_NORMAL) | INSERTION_BLANK;
          } else if (*mood & DIGIT_NORMAL) {
            add_char_mould (p, '0', q);
            *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
          }
        } else {
          add_char_mould (p, (*q)[0], q);
          *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
        }
      }
// D frames print a digit.
      else if (IS (p, FORMAT_ITEM_D)) {
        write_mould_put_sign (p, q);
        add_char_mould (p, (*q)[0], q);
        *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
      }
// Suppressible frames.
      else if (IS (p, FORMAT_ITEM_S)) {
// Suppressible frames are ignored in a sign-mould.
        if (type == SIGN_MOULD) {
          write_mould (NEXT (p), ref_file, type, q, mood);
        } else if (type == INTEGRAL_MOULD) {
          if ((*q)[0] != NULL_CHAR) {
            (*q)++;
          }
        }
        return;
      }
// Replicator.
      else if (IS (p, REPLICATOR)) {
        int k = get_replicator_value (SUB (p), A68G_TRUE);
        for (int j = 1; j <= k; j++) {
          write_mould (NEXT (p), ref_file, type, q, mood);
        }
        return;
      }
    }
  }
}

//! @brief Write INT value using int pattern.

void write_integral_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68G_REF ref_file)
{
  errno = 0;
  if (!(mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT)) {
    pattern_error (p, root, ATTRIBUTE (p));
  } else {
    ADDR_T pop_sp = A68G_SP;
    char *str = "*";
    int width = 0, sign = 0;
    MOOD_T mood;
// Dive into the pattern if needed.
    if (IS (p, INTEGRAL_PATTERN)) {
      p = SUB (p);
    }
// Find width.
    count_zd_frames (p, &width);
// Make string.
    reset_transput_buffer (EDIT_BUFFER);
    int digits = DIGITS (M_LONG_LONG_INT);
    MP_T *z = nil_mp (p, digits);
    if (mode == M_INT) {
      int_to_mp (p, z, VALUE ((A68G_INT *) item), digits);
    } else if (mode == M_LONG_INT) {
      #if (A68G_LEVEL >= 3)
        DOUBLE_NUM_T w = VALUE ((A68G_LONG_INT *) item);
        double_int_to_mp (p, z, w, digits);
      #else
        (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_INT));
      #endif
    } else if (mode == M_LONG_LONG_INT) {
      (void) move_mp (z, (MP_T *) item, digits);
    }
    sign = MP_SIGN (z);
    MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
    str = sub_whole_mp (p, z, digits, width);
// Edit string and output.
    if (strchr (str, ERROR_CHAR) != NO_TEXT) {
      value_error (p, root, ref_file);
    }
    if (IS (p, SIGN_MOULD)) {
      put_sign_to_integral (p, sign);
    } else if (sign < 0) {
      value_sign_error (p, root, ref_file);
    }
    put_zeroes_to_integral (p, width - strlen (str));
    add_string_transput_buffer (p, EDIT_BUFFER, str);
    str = get_transput_buffer (EDIT_BUFFER);
    mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
    if (IS (p, SIGN_MOULD)) {
      if (str[0] == '+' || str[0] == '-') {
        shift_sign (SUB (p), &str);
      }
      str = get_transput_buffer (EDIT_BUFFER);
      write_mould (SUB (p), ref_file, SIGN_MOULD, &str, &mood);
      FORWARD (p);
    }
    if (IS (p, INTEGRAL_MOULD)) {       // This *should* be the case
      write_mould (SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
    }
    A68G_SP = pop_sp;
  }
}

//! @brief Write REAL value using real pattern.

void write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68G_REF ref_file)
{
  errno = 0;
  if (!(mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL || mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT)) {
    pattern_error (p, root, ATTRIBUTE (p));
  } else {
    ADDR_T pop_sp = A68G_SP;
    int stag_digits = 0, frac_digits = 0, expo_digits = 0;
    int mant_length, sign = 0, exp_value;
    NODE_T *q, *sign_mould = NO_NODE, *stag_mould = NO_NODE, *point_frame = NO_NODE, *frac_mould = NO_NODE, *e_frame = NO_NODE, *expo_mould = NO_NODE;
    char *str = NO_TEXT, *stag_str = NO_TEXT, *frac_str = NO_TEXT;
    MOOD_T mood;
// Dive into pattern.
    q = ((IS (p, REAL_PATTERN)) ? SUB (p) : p);
// Dissect pattern and establish widths.
    if (q != NO_NODE && IS (q, SIGN_MOULD)) {
      sign_mould = q;
      count_zd_frames (SUB (sign_mould), &stag_digits);
      FORWARD (q);
    }
    if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
      stag_mould = q;
      count_zd_frames (SUB (stag_mould), &stag_digits);
      FORWARD (q);
    }
    if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
      point_frame = q;
      FORWARD (q);
    }
    if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
      frac_mould = q;
      count_zd_frames (SUB (frac_mould), &frac_digits);
      FORWARD (q);
    }
    if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
      e_frame = SUB (q);
      expo_mould = NEXT_SUB (q);
      q = expo_mould;
      if (IS (q, SIGN_MOULD)) {
        count_zd_frames (SUB (q), &expo_digits);
        FORWARD (q);
      }
      if (IS (q, INTEGRAL_MOULD)) {
        count_zd_frames (SUB (q), &expo_digits);
      }
    }
// Make string representation.
    if (point_frame == NO_NODE) {
      mant_length = stag_digits;
    } else {
      mant_length = 1 + stag_digits + frac_digits;
    }
//
    ADDR_T pop_sp2 = A68G_SP;
    int digits = DIGITS (M_LONG_LONG_REAL);
    MP_T *z = nil_mp (p, digits);
    if (mode == M_INT) {
      INT_T x = VALUE ((A68G_INT *) item);
      (void) int_to_mp (p, z, x, digits);
    } else if (mode == M_REAL) {
      REAL_T x = VALUE ((A68G_REAL *) item);
      CHECK_REAL (p, x);
      #if (A68G_LEVEL >= 3)
        (void) double_to_mp (p, z, (DOUBLE_T) x, A68G_REAL_DIG + 1, A68G_TRUE, digits);
      #else
        (void) real_to_mp (p, z, x, digits);
      #endif
    } else if (mode == M_LONG_INT) {
      #if (A68G_LEVEL >= 3)
        DOUBLE_NUM_T x = VALUE ((A68G_DOUBLE *) item);
        (void) double_int_to_mp (p, z, x, digits);
      #else
        (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_INT));
      #endif
    } else if (mode == M_LONG_REAL) {
      #if (A68G_LEVEL >= 3)
        DOUBLE_T x = VALUE ((A68G_DOUBLE *) item).f;
        CHECK_DOUBLE_REAL (p, x);
        (void) double_to_mp (p, z, x, A68G_DOUBLE_DIG, A68G_TRUE, digits);
      #else
        (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_REAL));
      #endif
    } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
      (void) move_mp (z, (MP_T *) item, digits);
    }
    exp_value = 0;
    sign = SIGN (z[2]);
    if (sign_mould != NO_NODE) {
      put_sign_to_integral (sign_mould, sign);
    }
    z[2] = ABS (z[2]);
    if (expo_mould != NO_NODE) {
      standardize_mp (p, z, digits, stag_digits, frac_digits, &exp_value);
    }
    str = sub_fixed_mp (p, z, digits,  mant_length, frac_digits);
    A68G_SP = pop_sp2;
// Edit and output the string.
    if (strchr (str, ERROR_CHAR) != NO_TEXT) {
      value_error (p, root, ref_file);
    }
    reset_transput_buffer (STRING_BUFFER);
    add_string_transput_buffer (p, STRING_BUFFER, str);
    stag_str = get_transput_buffer (STRING_BUFFER);
    if (strchr (stag_str, ERROR_CHAR) != NO_TEXT) {
      value_error (p, root, ref_file);
    }
    str = strchr (stag_str, POINT_CHAR);
    if (str != NO_TEXT) {
      frac_str = &str[1];
      str[0] = NULL_CHAR;
    } else {
      frac_str = NO_TEXT;
    }
// Stagnant part.
    reset_transput_buffer (EDIT_BUFFER);
    if (sign_mould != NO_NODE) {
      put_sign_to_integral (sign_mould, sign);
    } else if (sign < 0) {
      value_sign_error (sign_mould, root, ref_file);
    }
    put_zeroes_to_integral (p, stag_digits - strlen (stag_str));
    add_string_transput_buffer (p, EDIT_BUFFER, stag_str);
    stag_str = get_transput_buffer (EDIT_BUFFER);
    mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
    if (sign_mould != NO_NODE) {
      if (stag_str[0] == '+' || stag_str[0] == '-') {
        shift_sign (SUB (p), &stag_str);
      }
      stag_str = get_transput_buffer (EDIT_BUFFER);
      write_mould (SUB (sign_mould), ref_file, SIGN_MOULD, &stag_str, &mood);
    }
    if (stag_mould != NO_NODE) {
      write_mould (SUB (stag_mould), ref_file, INTEGRAL_MOULD, &stag_str, &mood);
    }
// Point frame.
    if (point_frame != NO_NODE) {
      write_pie_frame (point_frame, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT);
    }
// Fraction.
    if (frac_mould != NO_NODE) {
      reset_transput_buffer (EDIT_BUFFER);
      add_string_transput_buffer (p, EDIT_BUFFER, frac_str);
      frac_str = get_transput_buffer (EDIT_BUFFER);
      mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
      write_mould (SUB (frac_mould), ref_file, INTEGRAL_MOULD, &frac_str, &mood);
    }
// Exponent.
    if (expo_mould != NO_NODE) {
      A68G_INT k;
      STATUS (&k) = INIT_MASK;
      VALUE (&k) = exp_value;
      if (e_frame != NO_NODE) {
        write_pie_frame (e_frame, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E);
      }
      write_integral_pattern (expo_mould, M_INT, root, (BYTE_T *) & k, ref_file);
    }
    A68G_SP = pop_sp;
  }
}

//! @brief Write COMPLEX value using complex pattern.

void write_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * root, BYTE_T * re, BYTE_T * im, A68G_REF ref_file)
{
  errno = 0;
// Dissect pattern.
  NODE_T *reel = SUB (p);
  NODE_T *plus_i_times = NEXT (reel);
  NODE_T *imag = NEXT (plus_i_times);
// Write pattern.
  write_real_pattern (reel, comp, root, re, ref_file);
  write_pie_frame (plus_i_times, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I);
  write_real_pattern (imag, comp, root, im, ref_file);
}

//! @brief Write BITS value using bits pattern.

void write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
{
  ADDR_T pop_sp = A68G_SP;
  int width = 0, radix;
  char *str;
  if (mode == M_BITS) {
    A68G_BITS *z = (A68G_BITS *) item;
// Establish width and radix.
    count_zd_frames (SUB (p), &width);
    radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
    if (radix < 2 || radix > 16) {
      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
      exit_genie (p, A68G_RUNTIME_ERROR);
    }
// Generate string of correct width.
    reset_transput_buffer (EDIT_BUFFER);
    if (!convert_radix (p, VALUE (z), radix, width)) {
      errno = EDOM;
      value_error (p, mode, ref_file);
    }
  } else if (mode == M_LONG_BITS) {
    #if (A68G_LEVEL >= 3)
      A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
// Establish width and radix.
      count_zd_frames (SUB (p), &width);
      radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
      if (radix < 2 || radix > 16) {
        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
        exit_genie (p, A68G_RUNTIME_ERROR);
      }
// Generate string of correct width.
      reset_transput_buffer (EDIT_BUFFER);
      if (!convert_radix_double (p, VALUE (z), radix, width)) {
        errno = EDOM;
        value_error (p, mode, ref_file);
      }
    #else
      int digits = DIGITS (mode);
      MP_T *u = (MP_T *) item;
      MP_T *v = nil_mp (p, digits);
      MP_T *w = nil_mp (p, digits);
// Establish width and radix.
      count_zd_frames (SUB (p), &width);
      radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
      if (radix < 2 || radix > 16) {
        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
        exit_genie (p, A68G_RUNTIME_ERROR);
      }
// Generate string of correct width.
      reset_transput_buffer (EDIT_BUFFER);
      if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
        errno = EDOM;
        value_error (p, mode, ref_file);
      }
    #endif
  } else if (mode == M_LONG_LONG_BITS) {
    #if (A68G_LEVEL <= 2)
      int digits = DIGITS (mode);
      MP_T *u = (MP_T *) item;
      MP_T *v = nil_mp (p, digits);
      MP_T *w = nil_mp (p, digits);
// Establish width and radix.
      count_zd_frames (SUB (p), &width);
      radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
      if (radix < 2 || radix > 16) {
        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
        exit_genie (p, A68G_RUNTIME_ERROR);
      }
// Generate string of correct width.
      reset_transput_buffer (EDIT_BUFFER);
      if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
        errno = EDOM;
        value_error (p, mode, ref_file);
      }
    #endif
  }
// Output the edited string.
  MOOD_T mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
  str = get_transput_buffer (EDIT_BUFFER);
  write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
  A68G_SP = pop_sp;
}

//! @brief Write value to file.

void genie_write_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
{
  if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
    genie_value_to_string (p, M_REAL, item, ATTRIBUTE (SUB (p)));
    add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
  } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
    write_number_generic (p, M_REAL, item, ATTRIBUTE (SUB (p)));
  } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
    write_c_pattern (p, M_REAL, item, ref_file);
  } else if (IS (p, REAL_PATTERN)) {
    write_real_pattern (p, M_REAL, M_REAL, item, ref_file);
  } else if (IS (p, COMPLEX_PATTERN)) {
    A68G_REAL im;
    STATUS (&im) = INIT_MASK;
    VALUE (&im) = 0.0;
    write_complex_pattern (p, M_REAL, M_COMPLEX, (BYTE_T *) item, (BYTE_T *) & im, ref_file);
  } else {
    pattern_error (p, M_REAL, ATTRIBUTE (p));
  }
}

//! @brief Write value to file.

void genie_write_long_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
{
  if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
    genie_value_to_string (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
    add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
  } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
    write_number_generic (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
  } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
    write_c_pattern (p, M_LONG_REAL, item, ref_file);
  } else if (IS (p, REAL_PATTERN)) {
    write_real_pattern (p, M_LONG_REAL, M_LONG_REAL, item, ref_file);
  } else if (IS (p, COMPLEX_PATTERN)) {
    #if (A68G_LEVEL >= 3)
      ADDR_T pop_sp = A68G_SP;
      A68G_LONG_REAL *z = (A68G_LONG_REAL *) STACK_TOP;
      DOUBLE_NUM_T im;
      im.f = 0.0q;
      PUSH_VALUE (p, im, A68G_LONG_REAL);
      write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
      A68G_SP = pop_sp;
    #else
      ADDR_T pop_sp = A68G_SP;
      MP_T *z = nil_mp (p, DIGITS (M_LONG_REAL));
      z[0] = (MP_T) INIT_MASK;
      write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
      A68G_SP = pop_sp;
    #endif
  } else {
    pattern_error (p, M_LONG_REAL, ATTRIBUTE (p));
  }
}

//! @brief Write value to file.

void genie_write_long_mp_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
{
  if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
    genie_value_to_string (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
    add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
  } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
    write_number_generic (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
  } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
    write_c_pattern (p, M_LONG_LONG_REAL, item, ref_file);
  } else if (IS (p, REAL_PATTERN)) {
    write_real_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_REAL, item, ref_file);
  } else if (IS (p, COMPLEX_PATTERN)) {
    ADDR_T pop_sp = A68G_SP;
    MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
    z[0] = (MP_T) INIT_MASK;
    write_complex_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
    A68G_SP = pop_sp;
  } else {
    pattern_error (p, M_LONG_LONG_REAL, ATTRIBUTE (p));
  }
}

//! @brief At end of write purge all insertions.

void purge_format_write (NODE_T * p, A68G_REF ref_file)
{
// Problem here is shutting down embedded formats.
  BOOL_T siga;
  do {
    A68G_FILE *file;
    NODE_T *dollar, *pat;
    A68G_FORMAT *old_fmt;
    while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
      format_error (p, ref_file, ERROR_FORMAT_PICTURES);
    }
    file = FILE_DEREF (&ref_file);
    dollar = SUB (BODY (&FORMAT (file)));
    old_fmt = (A68G_FORMAT *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (dollar)));
    siga = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
    if (siga) {
// Pop embedded format and proceed.
      (void) end_of_format (p, ref_file);
    }
  } while (siga);
}

//! @brief Write value to file.

void genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file, int *formats)
{
  errno = 0;
  ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
  if (mode == M_FORMAT) {
    A68G_FILE *file;
    CHECK_REF (p, ref_file, M_REF_FILE);
    file = FILE_DEREF (&ref_file);
// Forget about eventual active formats and set up new one.
    if (*formats > 0) {
      purge_format_write (p, ref_file);
    }
    (*formats)++;
    A68G_FP = FRAME_POINTER (file);
    A68G_SP = STACK_POINTER (file);
    open_format_frame (p, ref_file, (A68G_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68G_TRUE);
  } else if (mode == M_PROC_REF_FILE_VOID) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
    exit_genie (p, A68G_RUNTIME_ERROR);
  } else if (mode == M_SOUND) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_SOUND);
    exit_genie (p, A68G_RUNTIME_ERROR);
  } else if (mode == M_INT) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
      add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
    } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
      write_number_generic (pat, M_INT, item, ATTRIBUTE (SUB (pat)));
    } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
      write_c_pattern (pat, M_INT, item, ref_file);
    } else if (IS (pat, INTEGRAL_PATTERN)) {
      write_integral_pattern (pat, M_INT, M_INT, item, ref_file);
    } else if (IS (pat, REAL_PATTERN)) {
      write_real_pattern (pat, M_INT, M_INT, item, ref_file);
    } else if (IS (pat, COMPLEX_PATTERN)) {
      A68G_REAL re, im;
      STATUS (&re) = INIT_MASK;
      VALUE (&re) = (REAL_T) VALUE ((A68G_INT *) item);
      STATUS (&im) = INIT_MASK;
      VALUE (&im) = 0.0;
      write_complex_pattern (pat, M_REAL, M_COMPLEX, (BYTE_T *) & re, (BYTE_T *) & im, ref_file);
    } else if (IS (pat, CHOICE_PATTERN)) {
      int k = VALUE ((A68G_INT *) item);
      write_choice_pattern (NEXT_SUB (pat), ref_file, &k);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_LONG_INT) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
      add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
    } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
      write_number_generic (pat, M_LONG_INT, item, ATTRIBUTE (SUB (pat)));
    } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
      write_c_pattern (pat, M_LONG_INT, item, ref_file);
    } else if (IS (pat, INTEGRAL_PATTERN)) {
      write_integral_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
    } else if (IS (pat, REAL_PATTERN)) {
      write_real_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
    } else if (IS (pat, COMPLEX_PATTERN)) {
      #if (A68G_LEVEL >= 3)
        ADDR_T pop_sp = A68G_SP;
        A68G_LONG_REAL *z = (A68G_LONG_REAL *) STACK_TOP;
        DOUBLE_NUM_T im;
        im.f = 0.0q;
        PUSH_VALUE (p, im, A68G_LONG_REAL);
        write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
        A68G_SP = pop_sp;
      #else
        ADDR_T pop_sp = A68G_SP;
        MP_T *z = nil_mp (p, DIGITS (mode));
        z[0] = (MP_T) INIT_MASK;
        write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
        A68G_SP = pop_sp;
      #endif
    } else if (IS (pat, CHOICE_PATTERN)) {
      INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
      int sk;
      CHECK_INT_SHORTEN (p, k);
      sk = (int) k;
      write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_LONG_LONG_INT) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
      add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
    } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
      write_number_generic (pat, M_LONG_LONG_INT, item, ATTRIBUTE (SUB (pat)));
    } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
      write_c_pattern (pat, M_LONG_LONG_INT, item, ref_file);
    } else if (IS (pat, INTEGRAL_PATTERN)) {
      write_integral_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
    } else if (IS (pat, REAL_PATTERN)) {
      write_real_pattern (pat, M_INT, M_INT, item, ref_file);
    } else if (IS (pat, REAL_PATTERN)) {
      write_real_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
    } else if (IS (pat, COMPLEX_PATTERN)) {
      ADDR_T pop_sp = A68G_SP;
      MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
      z[0] = (MP_T) INIT_MASK;
      write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
      A68G_SP = pop_sp;
    } else if (IS (pat, CHOICE_PATTERN)) {
      INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
      int sk;
      CHECK_INT_SHORTEN (p, k);
      sk = (int) k;
      write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_REAL) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    genie_write_real_format (pat, item, ref_file);
  } else if (mode == M_LONG_REAL) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    genie_write_long_real_format (pat, item, ref_file);
  } else if (mode == M_LONG_LONG_REAL) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    genie_write_long_mp_real_format (pat, item, ref_file);
  } else if (mode == M_COMPLEX) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, COMPLEX_PATTERN)) {
      write_complex_pattern (pat, M_REAL, M_COMPLEX, &item[0], &item[SIZE (M_REAL)], ref_file);
    } else {
// Try writing as two REAL values.
      genie_write_real_format (pat, item, ref_file);
      genie_write_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
    }
  } else if (mode == M_LONG_COMPLEX) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, COMPLEX_PATTERN)) {
      write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_REAL)], ref_file);
    } else {
// Try writing as two LONG REAL values.
      genie_write_long_real_format (pat, item, ref_file);
      genie_write_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
    }
  } else if (mode == M_LONG_LONG_COMPLEX) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, COMPLEX_PATTERN)) {
      write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_LONG_REAL)], ref_file);
    } else {
// Try writing as two LONG LONG REAL values.
      genie_write_long_mp_real_format (pat, item, ref_file);
      genie_write_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
    }
  } else if (mode == M_BOOL) {
    A68G_BOOL *z = (A68G_BOOL *) item;
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68G_TRUE ? FLIP_CHAR : FLOP_CHAR));
    } else if (IS (pat, BOOLEAN_PATTERN)) {
      if (NEXT_SUB (pat) == NO_NODE) {
        plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68G_TRUE ? FLIP_CHAR : FLOP_CHAR));
      } else {
        write_boolean_pattern (pat, ref_file, (BOOL_T) (VALUE (z) == A68G_TRUE));
      }
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_BITS) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      char *str = (char *) STACK_TOP;
      genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
      add_string_transput_buffer (p, FORMATTED_BUFFER, str);
    } else if (IS (pat, BITS_PATTERN)) {
      write_bits_pattern (pat, M_BITS, item, ref_file);
    } else if (IS (pat, BITS_C_PATTERN)) {
      write_c_pattern (pat, M_BITS, item, ref_file);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      char *str = (char *) STACK_TOP;
      genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
      add_string_transput_buffer (p, FORMATTED_BUFFER, str);
    } else if (IS (pat, BITS_PATTERN)) {
      write_bits_pattern (pat, mode, item, ref_file);
    } else if (IS (pat, BITS_C_PATTERN)) {
      write_c_pattern (pat, mode, item, ref_file);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_CHAR) {
    A68G_CHAR *z = (A68G_CHAR *) item;
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      plusab_transput_buffer (p, FORMATTED_BUFFER, (char) VALUE (z));
    } else if (IS (pat, STRING_PATTERN)) {
      char *q = get_transput_buffer (EDIT_BUFFER);
      reset_transput_buffer (EDIT_BUFFER);
      plusab_transput_buffer (p, EDIT_BUFFER, (char) VALUE (z));
      write_string_pattern (pat, mode, ref_file, &q);
      if (q[0] != NULL_CHAR) {
        value_error (p, mode, ref_file);
      }
    } else if (IS (pat, STRING_C_PATTERN)) {
      char zz[2];
      zz[0] = VALUE (z);
      zz[1] = '\0';
      (void) c_to_a_string (pat, zz, 1);
      write_c_pattern (pat, mode, (BYTE_T *) zz, ref_file);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_ROW_CHAR || mode == M_STRING) {
// Handle these separately instead of printing [] CHAR.
    A68G_REF row = *(A68G_REF *) item;
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      PUSH_REF (p, row);
      add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
    } else if (IS (pat, STRING_PATTERN)) {
      char *q;
      PUSH_REF (p, row);
      reset_transput_buffer (EDIT_BUFFER);
      add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
      q = get_transput_buffer (EDIT_BUFFER);
      write_string_pattern (pat, mode, ref_file, &q);
      if (q[0] != NULL_CHAR) {
        value_error (p, mode, ref_file);
      }
    } else if (IS (pat, STRING_C_PATTERN)) {
      char *q;
      PUSH_REF (p, row);
      reset_transput_buffer (EDIT_BUFFER);
      add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
      q = get_transput_buffer (EDIT_BUFFER);
      write_c_pattern (pat, mode, (BYTE_T *) q, ref_file);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (IS_UNION (mode)) {
    A68G_UNION *z = (A68G_UNION *) item;
    MOID_T *um = (MOID_T *) (VALUE (z));
    BYTE_T *ui = &item[A68G_UNION_SIZE];
    if (um == NO_MOID) {
      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
      exit_genie (p, A68G_RUNTIME_ERROR);
    }
    genie_write_standard_format (p, um, ui, ref_file, formats);
  } else if (IS_STRUCT (mode)) {
    for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
      BYTE_T *elem = &item[OFFSET (q)];
      genie_check_initialisation (p, elem, MOID (q));
      genie_write_standard_format (p, MOID (q), elem, ref_file, formats);
    }
  } else if (IS_ROW (mode) || IS_FLEX (mode)) {
    MOID_T *deflexed = DEFLEX (mode);
    CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
    A68G_ARRAY *arr; A68G_TUPLE *tup;
    GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
    if (get_row_size (tup, DIM (arr)) > 0) {
      BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
      BOOL_T done = A68G_FALSE;
      initialise_internal_index (tup, DIM (arr));
      while (!done) {
        ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
        ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
        BYTE_T *elem = &base_addr[elem_addr];
        genie_check_initialisation (p, elem, SUB (deflexed));
        genie_write_standard_format (p, SUB (deflexed), elem, ref_file, formats);
        done = increment_internal_index (tup, DIM (arr));
      }
    }
  }
  if (errno != 0) {
    transput_error (p, ref_file, mode);
  }
}

//! @brief PROC ([] SIMPLOUT) VOID print f, write f

void genie_write_format (NODE_T * p)
{
  A68G_REF row;
  POP_REF (p, &row);
  genie_stand_out (p);
  PUSH_REF (p, row);
  genie_write_file_format (p);
}

//! @brief PROC (REF FILE, [] SIMPLOUT) VOID put f

void genie_write_file_format (NODE_T * p)
{
  A68G_REF row;
  POP_REF (p, &row);
  CHECK_REF (p, row, M_ROW_SIMPLOUT);
  A68G_ARRAY *arr; A68G_TUPLE *tup;
  GET_DESCRIPTOR (arr, tup, &row);
  INT_T elems = ROW_SIZE (tup);
  A68G_REF ref_file;
  POP_REF (p, &ref_file);
  CHECK_REF (p, ref_file, M_REF_FILE);
  A68G_FILE *file = FILE_DEREF (&ref_file);
  CHECK_INIT (p, INITIALISED (file), M_FILE);
  if (!OPENED (file)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  if (DRAW_MOOD (file)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  if (READ_MOOD (file)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  if (!PUT (&CHANNEL (file))) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
    if (IS_NIL (STRING (file))) {
      if ((FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, A68G_PROTECTION)) == A68G_NO_FILE) {
        open_error (p, ref_file, "putting");
      }
    } else {
      FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, 0);
    }
    DRAW_MOOD (file) = A68G_FALSE;
    READ_MOOD (file) = A68G_FALSE;
    WRITE_MOOD (file) = A68G_TRUE;
    CHAR_MOOD (file) = A68G_TRUE;
  }
  if (!CHAR_MOOD (file)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
// Save stack state since formats have frames.
  ADDR_T pop_fp = FRAME_POINTER (file), pop_sp = STACK_POINTER (file);
  FRAME_POINTER (file) = A68G_FP;
  STACK_POINTER (file) = A68G_SP;
// Process [] SIMPLOUT.
  if (BODY (&FORMAT (file)) != NO_NODE) {
    open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68G_FALSE);
  }
  if (elems <= 0) {
    return;
  }
  int formats = 0;
  BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
  INT_T elem_index = 0;
  for (INT_T k = 0; k < elems; k++) {
    A68G_UNION *z = (A68G_UNION *) & (base_address[elem_index]);
    MOID_T *mode = (MOID_T *) (VALUE (z));
    BYTE_T *item = &(base_address[elem_index + A68G_UNION_SIZE]);
    genie_write_standard_format (p, mode, item, ref_file, &formats);
    elem_index += SIZE (M_SIMPLOUT);
  }
// Empty the format to purge insertions.
  purge_format_write (p, ref_file);
  BODY (&FORMAT (file)) = NO_NODE;
// Dump the buffer.
  write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
// Forget about active formats.
  A68G_FP = FRAME_POINTER (file);
  A68G_SP = STACK_POINTER (file);
  FRAME_POINTER (file) = pop_fp;
  STACK_POINTER (file) = pop_sp;
}

//! @brief Give a value error in case a character is not among expected ones.

BOOL_T expect (NODE_T * p, MOID_T * m, A68G_REF ref_file, const char *items, char ch)
{
  if (strchr ((char *) items, ch) == NO_TEXT) {
    value_error (p, m, ref_file);
    return A68G_FALSE;
  } else {
    return A68G_TRUE;
  }
}

//! @brief Read a group of insertions.

void read_insertion (NODE_T * p, A68G_REF ref_file)
{

// Algol68G does not check whether the insertions are textually there. It just
// skips them. This because we blank literals in sign moulds before the sign is
// put, which is non-standard Algol68, but convenient.

  A68G_FILE *file = FILE_DEREF (&ref_file);
  for (; p != NO_NODE; FORWARD (p)) {
    read_insertion (SUB (p), ref_file);
    if (IS (p, FORMAT_ITEM_L)) {
      BOOL_T siga = (BOOL_T) ! END_OF_FILE (file);
      while (siga) {
        int ch = read_single_char (p, ref_file);
        siga = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
      }
    } else if (IS (p, FORMAT_ITEM_P)) {
      BOOL_T siga = (BOOL_T) ! END_OF_FILE (file);
      while (siga) {
        int ch = read_single_char (p, ref_file);
        siga = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
      }
    } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
      if (!END_OF_FILE (file)) {
        (void) read_single_char (p, ref_file);
      }
    } else if (IS (p, FORMAT_ITEM_Y)) {
      PUSH_REF (p, ref_file);
      PUSH_VALUE (p, -1, A68G_INT);
      genie_set (p);
    } else if (IS (p, LITERAL)) {
// Skip characters, but don't check the literal. 
      size_t len = strlen (NSYMBOL (p));
      while (len-- && !END_OF_FILE (file)) {
        (void) read_single_char (p, ref_file);
      }
    } else if (IS (p, REPLICATOR)) {
      int k = get_replicator_value (SUB (p), A68G_TRUE);
      if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
        for (int j = 1; j <= k; j++) {
          read_insertion (NEXT (p), ref_file);
        }
      } else {
        int pos = get_transput_buffer_index (INPUT_BUFFER);
        for (int j = 1; j < (k - pos); j++) {
          if (!END_OF_FILE (file)) {
            (void) read_single_char (p, ref_file);
          }
        }
      }
      return;  // From REPLICATOR, don't delete this!
    }
  }
}

//! @brief Read string from file according current format.

void read_string_pattern (NODE_T * p, MOID_T * m, A68G_REF ref_file)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, INSERTION)) {
      read_insertion (SUB (p), ref_file);
    } else if (IS (p, FORMAT_ITEM_A)) {
      scan_n_chars (p, 1, m, ref_file);
    } else if (IS (p, FORMAT_ITEM_S)) {
      plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
      return;
    } else if (IS (p, REPLICATOR)) {
      int k = get_replicator_value (SUB (p), A68G_TRUE);
      for (int j = 1; j <= k; j++) {
        read_string_pattern (NEXT (p), m, ref_file);
      }
      return;
    } else {
      read_string_pattern (SUB (p), m, ref_file);
    }
  }
}

//! @brief Traverse choice pattern.

void traverse_choice_pattern (NODE_T * p, char *str, int len, int *count, int *matches, int *first_match, BOOL_T * full_match)
{
  for (; p != NO_NODE; FORWARD (p)) {
    traverse_choice_pattern (SUB (p), str, len, count, matches, first_match, full_match);
    if (IS (p, LITERAL)) {
      (*count)++;
      if (strncmp (NSYMBOL (p), str, (size_t) len) == 0) {
        (*matches)++;
        (*full_match) = (BOOL_T) ((*full_match) | (strcmp (NSYMBOL (p), str) == 0));
        if (*first_match == 0 && *full_match) {
          *first_match = *count;
        }
      }
    }
  }
}

//! @brief Read appropriate insertion from a choice pattern.

int read_choice_pattern (NODE_T * p, A68G_REF ref_file)
{

// This implementation does not have the RR peculiarity that longest
// matching literal must be first, in case of non-unique first chars.

  A68G_FILE *file = FILE_DEREF (&ref_file);
  BOOL_T cont = A68G_TRUE;
  int longest_match = 0, longest_match_len = 0;
  while (cont) {
    int ch = char_scanner (file);
    if (!END_OF_FILE (file)) {
      int len, count = 0, matches = 0, first_match = 0;
      BOOL_T full_match = A68G_FALSE;
      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
      len = get_transput_buffer_index (INPUT_BUFFER);
      traverse_choice_pattern (p, get_transput_buffer (INPUT_BUFFER), len, &count, &matches, &first_match, &full_match);
      if (full_match && matches == 1 && first_match > 0) {
        return first_match;
      } else if (full_match && matches > 1 && first_match > 0) {
        longest_match = first_match;
        longest_match_len = len;
      } else if (matches == 0) {
        cont = A68G_FALSE;
      }
    } else {
      cont = A68G_FALSE;
    }
  }
  if (longest_match > 0) {
// Push back look-ahead chars.
    if (get_transput_buffer_index (INPUT_BUFFER) > 0) {
      char *z = get_transput_buffer (INPUT_BUFFER);
      END_OF_FILE (file) = A68G_FALSE;
      add_string_transput_buffer (p, TRANSPUT_BUFFER (file), &z[longest_match_len]);
    }
    return longest_match;
  } else {
    value_error (p, M_INT, ref_file);
    return 0;
  }
}

//! @brief Read value according to a general-pattern.

void read_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
{
  GENIE_UNIT (NEXT_SUB (p));
// RR says to ignore parameters just calculated, so we will.
  A68G_REF row;
  POP_REF (p, &row);
  genie_read_standard (p, mode, item, ref_file);
}

// INTEGRAL, REAL, COMPLEX and BITS patterns.

//! @brief Read sign-mould according current format.

void read_sign_mould (NODE_T * p, MOID_T * m, A68G_REF ref_file, int *sign)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, INSERTION)) {
      read_insertion (SUB (p), ref_file);
    } else if (IS (p, REPLICATOR)) {
      int k = get_replicator_value (SUB (p), A68G_TRUE);
      for (int j = 1; j <= k; j++) {
        read_sign_mould (NEXT (p), m, ref_file, sign);
      }
      return;                   // Leave this!
    } else {
      switch (ATTRIBUTE (p)) {
      case FORMAT_ITEM_Z:
      case FORMAT_ITEM_D:
      case FORMAT_ITEM_S:
      case FORMAT_ITEM_PLUS:
      case FORMAT_ITEM_MINUS: {
          int ch = read_single_char (p, ref_file);
// When a sign has been read, digits are expected.
          if (*sign != 0) {
            if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
              plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
            } else {
              plusab_transput_buffer (p, INPUT_BUFFER, '0');
            }
// When a sign has not been read, a sign is expected.  If there is a digit
// in stead of a sign, the digit is accepted and '+' is assumed; RR demands a
// space to preceed the digit, Algol68G does not.
          } else {
            if (strchr (SIGN_DIGITS, ch) != NO_TEXT) {
              if (ch == '+') {
                *sign = 1;
              } else if (ch == '-') {
                *sign = -1;
              } else if (ch == BLANK_CHAR) {
                ;
              }
            } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
              plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
              *sign = 1;
            }
          }
          break;
        }
      default: {
          read_sign_mould (SUB (p), m, ref_file, sign);
          break;
        }
      }
    }
  }
}

//! @brief Read mould according current format.

void read_integral_mould (NODE_T * p, MOID_T * m, A68G_REF ref_file)
{
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, INSERTION)) {
      read_insertion (SUB (p), ref_file);
    } else if (IS (p, REPLICATOR)) {
      int k = get_replicator_value (SUB (p), A68G_TRUE);
      for (int j = 1; j <= k; j++) {
        read_integral_mould (NEXT (p), m, ref_file);
      }
      return; // Leave this!
    } else if (IS (p, FORMAT_ITEM_Z)) {
      int ch = read_single_char (p, ref_file);
      const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK;
      if (expect (p, m, ref_file, digits, (char) ch)) {
        plusab_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch));
      } else {
        plusab_transput_buffer (p, INPUT_BUFFER, '0');
      }
    } else if (IS (p, FORMAT_ITEM_D)) {
      int ch = read_single_char (p, ref_file);
      const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS : INT_DIGITS;
      if (expect (p, m, ref_file, digits, (char) ch)) {
        plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
      } else {
        plusab_transput_buffer (p, INPUT_BUFFER, '0');
      }
    } else if (IS (p, FORMAT_ITEM_S)) {
      plusab_transput_buffer (p, INPUT_BUFFER, '0');
    } else {
      read_integral_mould (SUB (p), m, ref_file);
    }
  }
}

//! @brief Read mould according current format.

void read_integral_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
{
  NODE_T *q = SUB (p);
  if (q != NO_NODE && IS (q, SIGN_MOULD)) {
    int sign = 0;
    char *z;
    plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
    read_sign_mould (SUB (q), m, ref_file, &sign);
    z = get_transput_buffer (INPUT_BUFFER);
    z[0] = (char) ((sign == -1) ? '-' : '+');
    FORWARD (q);
  }
  if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
    read_integral_mould (SUB (q), m, ref_file);
  }
  genie_string_to_value (p, m, item, ref_file);
}

//! @brief Read point, exponent or i-frame.

void read_pie_frame (NODE_T * p, MOID_T * m, A68G_REF ref_file, int att, int item, char ch)
{
// Widen ch to a stringlet.
  char sym[3];
  sym[0] = ch;
  sym[1] = (char) TO_LOWER (ch);
  sym[2] = NULL_CHAR;
// Now read the frame.
  for (; p != NO_NODE; FORWARD (p)) {
    if (IS (p, INSERTION)) {
      read_insertion (p, ref_file);
    } else if (IS (p, att)) {
      read_pie_frame (SUB (p), m, ref_file, att, item, ch);
      return;
    } else if (IS (p, FORMAT_ITEM_S)) {
      plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
      return;
    } else if (IS (p, item)) {
      int ch0 = read_single_char (p, ref_file);
      if (expect (p, m, ref_file, sym, (char) ch0)) {
        plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
      } else {
        plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
      }
    }
  }
}

//! @brief Read REAL value using real pattern.

void read_real_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
{
// Dive into pattern.
  NODE_T *q = (IS (p, REAL_PATTERN)) ? SUB (p) : p;
// Dissect pattern.
  if (q != NO_NODE && IS (q, SIGN_MOULD)) {
    int sign = 0;
    char *z;
    plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
    read_sign_mould (SUB (q), m, ref_file, &sign);
    z = get_transput_buffer (INPUT_BUFFER);
    z[0] = (char) ((sign == -1) ? '-' : '+');
    FORWARD (q);
  }
  if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
    read_integral_mould (SUB (q), m, ref_file);
    FORWARD (q);
  }
  if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
    read_pie_frame (SUB (q), m, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, POINT_CHAR);
    FORWARD (q);
  }
  if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
    read_integral_mould (SUB (q), m, ref_file);
    FORWARD (q);
  }
  if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
    read_pie_frame (SUB (q), m, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E, EXPONENT_CHAR);
    q = NEXT_SUB (q);
    if (q != NO_NODE && IS (q, SIGN_MOULD)) {
      int k, sign = 0;
      char *z;
      plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
      k = get_transput_buffer_index (INPUT_BUFFER);
      read_sign_mould (SUB (q), m, ref_file, &sign);
      z = get_transput_buffer (INPUT_BUFFER);
      z[k - 1] = (char) ((sign == -1) ? '-' : '+');
      FORWARD (q);
    }
    if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
      read_integral_mould (SUB (q), m, ref_file);
      FORWARD (q);
    }
  }
  genie_string_to_value (p, m, item, ref_file);
}

//! @brief Read COMPLEX value using complex pattern.

void read_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * m, BYTE_T * re, BYTE_T * im, A68G_REF ref_file)
{
// Dissect pattern.
  NODE_T *reel = SUB (p);
  NODE_T *plus_i_times = NEXT (reel);
  NODE_T *imag = NEXT (plus_i_times);
// Read pattern.
  read_real_pattern (reel, m, re, ref_file);
  reset_transput_buffer (INPUT_BUFFER);
  read_pie_frame (plus_i_times, comp, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I, 'I');
  reset_transput_buffer (INPUT_BUFFER);
  read_real_pattern (imag, m, im, ref_file);
}

//! @brief Read BITS value according pattern.

void read_bits_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
{
  int radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
  if (radix < 2 || radix > 16) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  char *z = get_transput_buffer (INPUT_BUFFER);
  ASSERT (a68g_bufprt (z, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
  set_transput_buffer_index (INPUT_BUFFER, strlen (z));
  read_integral_mould (NEXT_SUB (p), m, ref_file);
  genie_string_to_value (p, m, item, ref_file);
}

//! @brief Read object with from file and store.

void genie_read_real_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
{
  if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
    genie_read_standard (p, mode, item, ref_file);
  } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
    read_number_generic (p, mode, item, ref_file);
  } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
    read_c_pattern (p, mode, item, ref_file);
  } else if (IS (p, REAL_PATTERN)) {
    read_real_pattern (p, mode, item, ref_file);
  } else {
    pattern_error (p, mode, ATTRIBUTE (p));
  }
}

//! @brief At end of read purge all insertions.

void purge_format_read (NODE_T * p, A68G_REF ref_file)
{
  BOOL_T siga;
  do {
    NODE_T *pat;
    while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
      format_error (p, ref_file, ERROR_FORMAT_PICTURES);
    }
    A68G_FILE *file = FILE_DEREF (&ref_file);
    NODE_T *dollar = SUB (BODY (&FORMAT (file)));
    A68G_FORMAT *old_fmt = (A68G_FORMAT *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (dollar)));
    siga = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
    if (siga) {
// Pop embedded format and proceed.
      (void) end_of_format (p, ref_file);
    }
  } while (siga);
}

//! @brief Read object with from file and store.

void genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file, int *formats)
{
  errno = 0;
  reset_transput_buffer (INPUT_BUFFER);
  if (mode == M_FORMAT) {
    CHECK_REF (p, ref_file, M_REF_FILE);
    A68G_FILE *file = FILE_DEREF (&ref_file);
// Forget about eventual active formats and set up new one.
    if (*formats > 0) {
      purge_format_read (p, ref_file);
    }
    (*formats)++;
    A68G_FP = FRAME_POINTER (file);
    A68G_SP = STACK_POINTER (file);
    open_format_frame (p, ref_file, (A68G_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68G_TRUE);
  } else if (mode == M_PROC_REF_FILE_VOID) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
    exit_genie (p, A68G_RUNTIME_ERROR);
  } else if (mode == M_REF_SOUND) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_REF_SOUND);
    exit_genie (p, A68G_RUNTIME_ERROR);
  } else if (IS_REF (mode)) {
    CHECK_REF (p, *(A68G_REF *) item, mode);
    genie_read_standard_format (p, SUB (mode), ADDRESS ((A68G_REF *) item), ref_file, formats);
  } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      genie_read_standard (pat, mode, item, ref_file);
    } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
      read_number_generic (pat, mode, item, ref_file);
    } else if (IS (pat, INTEGRAL_C_PATTERN)) {
      read_c_pattern (pat, mode, item, ref_file);
    } else if (IS (pat, INTEGRAL_PATTERN)) {
      read_integral_pattern (pat, mode, item, ref_file);
    } else if (IS (pat, CHOICE_PATTERN)) {
      int k = read_choice_pattern (pat, ref_file);
      if (mode == M_INT) {
        A68G_INT *z = (A68G_INT *) item;
        VALUE (z) = k;
        STATUS (z) = (STATUS_MASK_T) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK);
      } else {
        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_DEPRECATED, mode);
        exit_genie (p, A68G_RUNTIME_ERROR);
      }
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    genie_read_real_format (pat, mode, item, ref_file);
  } else if (mode == M_COMPLEX) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, COMPLEX_PATTERN)) {
      read_complex_pattern (pat, mode, M_REAL, item, &item[SIZE (M_REAL)], ref_file);
    } else {
// Try reading as two REAL values.
      genie_read_real_format (pat, M_REAL, item, ref_file);
      genie_read_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
    }
  } else if (mode == M_LONG_COMPLEX) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, COMPLEX_PATTERN)) {
      read_complex_pattern (pat, mode, M_LONG_REAL, item, &item[SIZE (M_LONG_REAL)], ref_file);
    } else {
// Try reading as two LONG REAL values.
      genie_read_real_format (pat, M_LONG_REAL, item, ref_file);
      genie_read_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
    }
  } else if (mode == M_LONG_LONG_COMPLEX) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, COMPLEX_PATTERN)) {
      read_complex_pattern (pat, mode, M_LONG_LONG_REAL, item, &item[SIZE (M_LONG_LONG_REAL)], ref_file);
    } else {
// Try reading as two LONG LONG REAL values.
      genie_read_real_format (pat, M_LONG_LONG_REAL, item, ref_file);
      genie_read_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
    }
  } else if (mode == M_BOOL) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      genie_read_standard (p, mode, item, ref_file);
    } else if (IS (pat, BOOLEAN_PATTERN)) {
      if (NEXT_SUB (pat) == NO_NODE) {
        genie_read_standard (p, mode, item, ref_file);
      } else {
        A68G_BOOL *z = (A68G_BOOL *) item;
        int k = read_choice_pattern (pat, ref_file);
        if (k == 1 || k == 2) {
          VALUE (z) = (BOOL_T) ((k == 1) ? A68G_TRUE : A68G_FALSE);
          STATUS (z) = INIT_MASK;
        } else {
          STATUS (z) = NULL_MASK;
        }
      }
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      genie_read_standard (p, mode, item, ref_file);
    } else if (IS (pat, BITS_PATTERN)) {
      read_bits_pattern (pat, mode, item, ref_file);
    } else if (IS (pat, BITS_C_PATTERN)) {
      read_c_pattern (pat, mode, item, ref_file);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_CHAR) {
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      genie_read_standard (p, mode, item, ref_file);
    } else if (IS (pat, STRING_PATTERN)) {
      read_string_pattern (pat, M_CHAR, ref_file);
      genie_string_to_value (p, mode, item, ref_file);
    } else if (IS (pat, CHAR_C_PATTERN)) {
      read_c_pattern (pat, mode, item, ref_file);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (mode == M_ROW_CHAR || mode == M_STRING) {
// Handle these separately instead of reading [] CHAR.
    NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
    if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
      genie_read_standard (p, mode, item, ref_file);
    } else if (IS (pat, STRING_PATTERN)) {
      read_string_pattern (pat, mode, ref_file);
      genie_string_to_value (p, mode, item, ref_file);
    } else if (IS (pat, STRING_C_PATTERN)) {
      read_c_pattern (pat, mode, item, ref_file);
    } else {
      pattern_error (p, mode, ATTRIBUTE (pat));
    }
  } else if (IS_UNION (mode)) {
    A68G_UNION *z = (A68G_UNION *) item;
    genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file, formats);
  } else if (IS_STRUCT (mode)) {
    for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
      BYTE_T *elem = &item[OFFSET (q)];
      genie_read_standard_format (p, MOID (q), elem, ref_file, formats);
    }
  } else if (IS_ROW (mode) || IS_FLEX (mode)) {
    MOID_T *deflexed = DEFLEX (mode);
    A68G_ARRAY *arr;
    A68G_TUPLE *tup;
    CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
    GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
    if (get_row_size (tup, DIM (arr)) > 0) {
      BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
      BOOL_T done = A68G_FALSE;
      initialise_internal_index (tup, DIM (arr));
      while (!done) {
        ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
        ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
        BYTE_T *elem = &base_addr[elem_addr];
        genie_read_standard_format (p, SUB (deflexed), elem, ref_file, formats);
        done = increment_internal_index (tup, DIM (arr));
      }
    }
  }
  if (errno != 0) {
    transput_error (p, ref_file, mode);
  }
}

//! @brief PROC ([] SIMPLIN) VOID read f

void genie_read_format (NODE_T * p)
{
  A68G_REF row;
  POP_REF (p, &row);
  genie_stand_in (p);
  PUSH_REF (p, row);
  genie_read_file_format (p);
}

//! @brief PROC (REF FILE, [] SIMPLIN) VOID get f

void genie_read_file_format (NODE_T * p)
{
  A68G_REF row;
  POP_REF (p, &row);
  CHECK_REF (p, row, M_ROW_SIMPLIN);
  A68G_ARRAY *arr; A68G_TUPLE *tup;
  GET_DESCRIPTOR (arr, tup, &row);
  INT_T elems = ROW_SIZE (tup);
  A68G_REF ref_file;
  POP_REF (p, &ref_file);
  CHECK_REF (p, ref_file, M_REF_FILE);
  A68G_FILE *file = FILE_DEREF (&ref_file);
  CHECK_INIT (p, INITIALISED (file), M_FILE);
  if (!OPENED (file)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  if (DRAW_MOOD (file)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  if (WRITE_MOOD (file)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  if (!GET (&CHANNEL (file))) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
  if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
    if (IS_NIL (STRING (file))) {
      if ((FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0)) == A68G_NO_FILE) {
        open_error (p, ref_file, "getting");
      }
    } else {
      FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0);
    }
    DRAW_MOOD (file) = A68G_FALSE;
    READ_MOOD (file) = A68G_TRUE;
    WRITE_MOOD (file) = A68G_FALSE;
    CHAR_MOOD (file) = A68G_TRUE;
  }
  if (!CHAR_MOOD (file)) {
    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
    exit_genie (p, A68G_RUNTIME_ERROR);
  }
// Save stack state since formats have frames.
  ADDR_T pop_fp = FRAME_POINTER (file), pop_sp = STACK_POINTER (file);
  FRAME_POINTER (file) = A68G_FP;
  STACK_POINTER (file) = A68G_SP;
// Process [] SIMPLIN.
  if (BODY (&FORMAT (file)) != NO_NODE) {
    open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68G_FALSE);
  }
  if (elems <= 0) {
    return;
  }
  int formats = 0;
  BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
  INT_T elem_index = 0;
  for (INT_T k = 0; k < elems; k++) {
    A68G_UNION *z = (A68G_UNION *) & (base_address[elem_index]);
    MOID_T *mode = (MOID_T *) (VALUE (z));
    BYTE_T *item = (BYTE_T *) & (base_address[elem_index + A68G_UNION_SIZE]);
    genie_read_standard_format (p, mode, item, ref_file, &formats);
    elem_index += SIZE (M_SIMPLIN);
  }
// Empty the format to purge insertions.
  purge_format_read (p, ref_file);
  BODY (&FORMAT (file)) = NO_NODE;
// Forget about active formats.
  A68G_FP = FRAME_POINTER (file);
  A68G_SP = STACK_POINTER (file);
  FRAME_POINTER (file) = pop_fp;
  STACK_POINTER (file) = pop_sp;
}
