rts-formatted.c

     
   1  //! @file rts-formatted.c
   2  //! @author J. Marcel van der Veer
   3  //!
   4  //! @section Copyright
   5  //!
   6  //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
   7  //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
   8  //!
   9  //! @section License
  10  //!
  11  //! This program is free software; you can redistribute it and/or modify it 
  12  //! under the terms of the GNU General Public License as published by the 
  13  //! Free Software Foundation; either version 3 of the License, or 
  14  //! (at your option) any later version.
  15  //!
  16  //! This program is distributed in the hope that it will be useful, but 
  17  //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  //! more details. You should have received a copy of the GNU General Public 
  20  //! License along with this program. If not, see [http://www.gnu.org/licenses/].
  21  
  22  //! @section Synopsis 
  23  //!
  24  //! Formatted transput.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-frames.h"
  29  #include "a68g-prelude.h"
  30  #include "a68g-mp.h"
  31  #include "a68g-double.h"
  32  #include "a68g-transput.h"
  33  
  34  // Transput - Formatted transput.
  35  // In Algol68G, a value of mode FORMAT looks like a routine text. The value
  36  // comprises a pointer to its environment in the stack, and a pointer where the
  37  // format text is at in the syntax tree.
  38  
  39  #define INT_DIGITS "0123456789"
  40  #define BITS_DIGITS "0123456789abcdefABCDEF"
  41  #define INT_DIGITS_BLANK " 0123456789"
  42  #define BITS_DIGITS_BLANK " 0123456789abcdefABCDEF"
  43  #define SIGN_DIGITS " +-"
  44  
  45  //! @brief Convert to other radix, binary up to hexadecimal.
  46  
  47  BOOL_T convert_radix (NODE_T * p, UNSIGNED_T z, int radix, int width)
  48  {
  49    reset_transput_buffer (EDIT_BUFFER);
  50    if (radix < 2 || radix > 16) {
  51      radix = 16;
  52    }
  53    if (width > 0) {
  54      while (width > 0) {
  55        int digit = (int) (z % (UNSIGNED_T) radix);
  56        plusto_transput_buffer (p, digchar (digit), EDIT_BUFFER);
  57        width--;
  58        z /= (UNSIGNED_T) radix;
  59      }
  60      return z == 0;
  61    } else if (width == 0) {
  62      do {
  63        int digit = (int) (z % (UNSIGNED_T) radix);
  64        plusto_transput_buffer (p, digchar (digit), EDIT_BUFFER);
  65        z /= (UNSIGNED_T) radix;
  66      } while (z > 0);
  67      return A68_TRUE;
  68    } else {
  69      return A68_FALSE;
  70    }
  71  }
  72  
  73  //! @brief Handle format error event.
  74  
  75  void format_error (NODE_T * p, A68_REF ref_file, char *diag)
  76  {
  77    A68_FILE *f = FILE_DEREF (&ref_file);
  78    A68_BOOL z;
  79    on_event_handler (p, FORMAT_ERROR_MENDED (f), ref_file);
  80    POP_OBJECT (p, &z, A68_BOOL);
  81    if (VALUE (&z) == A68_FALSE) {
  82      diagnostic (A68_RUNTIME_ERROR, p, diag);
  83      exit_genie (p, A68_RUNTIME_ERROR);
  84    }
  85  }
  86  
  87  //! @brief Initialise processing of pictures.
  88  
  89  void initialise_collitems (NODE_T * p)
  90  {
  91  
  92  // Every picture has a counter that says whether it has not been used OR the number
  93  // of times it can still be used.
  94  
  95    for (; p != NO_NODE; FORWARD (p)) {
  96      if (IS (p, PICTURE)) {
  97        A68_COLLITEM *z = (A68_COLLITEM *) FRAME_LOCAL (A68_FP, OFFSET (TAX (p)));
  98        STATUS (z) = INIT_MASK;
  99        COUNT (z) = ITEM_NOT_USED;
 100      }
 101  // Don't dive into f, g, n frames and collections.
 102      if (!(IS (p, ENCLOSED_CLAUSE) || IS (p, COLLECTION))) {
 103        initialise_collitems (SUB (p));
 104      }
 105    }
 106  }
 107  
 108  //! @brief Initialise processing of format text.
 109  
 110  void open_format_frame (NODE_T * p, A68_REF ref_file, A68_FORMAT * fmt, BOOL_T embedded, BOOL_T init)
 111  {
 112  // Open a new frame for the format text and save for return to embedding one.
 113    A68_FILE *file = FILE_DEREF (&ref_file);
 114    NODE_T *dollar;
 115    A68_FORMAT *save;
 116  // Integrity check.
 117    if ((STATUS (fmt) & SKIP_FORMAT_MASK) || (BODY (fmt) == NO_NODE)) {
 118      format_error (p, ref_file, ERROR_FORMAT_UNDEFINED);
 119    }
 120  // Ok, seems usable.
 121    dollar = SUB (BODY (fmt));
 122    OPEN_PROC_FRAME (dollar, ENVIRON (fmt));
 123    INIT_STATIC_FRAME (dollar);
 124  // Save old format.
 125    save = (A68_FORMAT *) FRAME_LOCAL (A68_FP, OFFSET (TAX (dollar)));
 126    *save = (embedded == EMBEDDED_FORMAT ? FORMAT (file) : nil_format);
 127    FORMAT (file) = *fmt;
 128  // Reset all collitems.
 129    if (init) {
 130      initialise_collitems (dollar);
 131    }
 132  }
 133  
 134  //! @brief Handle end-of-format event.
 135  
 136  int end_of_format (NODE_T * p, A68_REF ref_file)
 137  {
 138  // Format-items return immediately to the embedding format text. The outermost
 139  //format text calls "on format end".
 140    A68_FILE *file = FILE_DEREF (&ref_file);
 141    NODE_T *dollar = SUB (BODY (&FORMAT (file)));
 142    A68_FORMAT *save = (A68_FORMAT *) FRAME_LOCAL (A68_FP, OFFSET (TAX (dollar)));
 143    if (IS_NIL_FORMAT (save)) {
 144  // Not embedded, outermost format: execute event routine.
 145      A68_BOOL z;
 146      on_event_handler (p, FORMAT_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
 147      POP_OBJECT (p, &z, A68_BOOL);
 148      if (VALUE (&z) == A68_FALSE) {
 149  // Restart format.
 150        A68_FP = FRAME_POINTER (file);
 151        A68_SP = STACK_POINTER (file);
 152        open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_TRUE);
 153      }
 154      return NOT_EMBEDDED_FORMAT;
 155    } else {
 156  // Embedded format, return to embedding format, cf. RR.
 157      CLOSE_FRAME;
 158      FORMAT (file) = *save;
 159      return EMBEDDED_FORMAT;
 160    }
 161  }
 162  
 163  //! @brief Return integral value of replicator.
 164  
 165  int get_replicator_value (NODE_T * p, BOOL_T check)
 166  {
 167    int z = 0;
 168    if (IS (p, STATIC_REPLICATOR)) {
 169      A68_INT u;
 170      if (genie_string_to_value_internal (p, M_INT, NSYMBOL (p), (BYTE_T *) & u) == A68_FALSE) {
 171        diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_INT);
 172        exit_genie (p, A68_RUNTIME_ERROR);
 173      }
 174      z = VALUE (&u);
 175    } else if (IS (p, DYNAMIC_REPLICATOR)) {
 176      A68_INT u;
 177      EXECUTE_UNIT (NEXT_SUB (p));
 178      POP_OBJECT (p, &u, A68_INT);
 179      z = VALUE (&u);
 180    } else if (IS (p, REPLICATOR)) {
 181      z = get_replicator_value (SUB (p), check);
 182    }
 183  // Not conform RR as Andrew Herbert rightfully pointed out.
 184  //  if (check && z < 0) {
 185  //    diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INVALID_REPLICATOR);
 186  //    exit_genie (p, A68_RUNTIME_ERROR);
 187  //  }
 188    if (z < 0) {
 189      z = 0;
 190    }
 191    return z;
 192  }
 193  
 194  //! @brief Return first available pattern.
 195  
 196  NODE_T *scan_format_pattern (NODE_T * p, A68_REF ref_file)
 197  {
 198    for (; p != NO_NODE; FORWARD (p)) {
 199      if (IS (p, PICTURE_LIST)) {
 200        NODE_T *prio = scan_format_pattern (SUB (p), ref_file);
 201        if (prio != NO_NODE) {
 202          return prio;
 203        }
 204      }
 205      if (IS (p, PICTURE)) {
 206        NODE_T *picture = SUB (p);
 207        A68_COLLITEM *collitem = (A68_COLLITEM *) FRAME_LOCAL (A68_FP, OFFSET (TAX (p)));
 208        if (COUNT (collitem) != 0) {
 209          if (IS (picture, A68_PATTERN)) {
 210            COUNT (collitem) = 0; // This pattern is now done
 211            picture = SUB (picture);
 212            if (ATTRIBUTE (picture) != FORMAT_PATTERN) {
 213              return picture;
 214            } else {
 215              NODE_T *pat;
 216              A68_FORMAT z;
 217              A68_FILE *file = FILE_DEREF (&ref_file);
 218              EXECUTE_UNIT (NEXT_SUB (picture));
 219              POP_OBJECT (p, &z, A68_FORMAT);
 220              open_format_frame (p, ref_file, &z, EMBEDDED_FORMAT, A68_TRUE);
 221              pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
 222              if (pat != NO_NODE) {
 223                return pat;
 224              } else {
 225                (void) end_of_format (p, ref_file);
 226              }
 227            }
 228          } else if (IS (picture, INSERTION)) {
 229            A68_FILE *file = FILE_DEREF (&ref_file);
 230            if (READ_MOOD (file)) {
 231              read_insertion (picture, ref_file);
 232            } else if (WRITE_MOOD (file)) {
 233              write_insertion (picture, ref_file, INSERTION_NORMAL);
 234            } else {
 235              ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
 236            }
 237            COUNT (collitem) = 0; // This insertion is now done
 238          } else if (IS (picture, REPLICATOR) || IS (picture, COLLECTION)) {
 239            BOOL_T go_on = A68_TRUE;
 240            NODE_T *a68_select = NO_NODE;
 241            if (COUNT (collitem) == ITEM_NOT_USED) {
 242              if (IS (picture, REPLICATOR)) {
 243                COUNT (collitem) = get_replicator_value (SUB (p), A68_TRUE);
 244                go_on = (BOOL_T) (COUNT (collitem) > 0);
 245                FORWARD (picture);
 246              } else {
 247                COUNT (collitem) = 1;
 248              }
 249              initialise_collitems (NEXT_SUB (picture));
 250            } else if (IS (picture, REPLICATOR)) {
 251              FORWARD (picture);
 252            }
 253            while (go_on) {
 254  // Get format item from collection. If collection is done, but repitition is not,
 255  // then re-initialise the collection and repeat.
 256              a68_select = scan_format_pattern (NEXT_SUB (picture), ref_file);
 257              if (a68_select != NO_NODE) {
 258                return a68_select;
 259              } else {
 260                COUNT (collitem)--;
 261                go_on = (BOOL_T) (COUNT (collitem) > 0);
 262                if (go_on) {
 263                  initialise_collitems (NEXT_SUB (picture));
 264                }
 265              }
 266            }
 267          }
 268        }
 269      }
 270    }
 271    return NO_NODE;
 272  }
 273  
 274  //! @brief Return first available pattern.
 275  
 276  NODE_T *get_next_format_pattern (NODE_T * p, A68_REF ref_file, BOOL_T mood)
 277  {
 278  // "mood" can be WANT_PATTERN: pattern needed by caller, so perform end-of-format
 279  // if needed or SKIP_PATTERN: just emptying current pattern/collection/format.
 280    A68_FILE *file = FILE_DEREF (&ref_file);
 281    if (BODY (&FORMAT (file)) == NO_NODE) {
 282      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
 283      exit_genie (p, A68_RUNTIME_ERROR);
 284      return NO_NODE;
 285    } else {
 286      NODE_T *pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
 287      if (pat == NO_NODE) {
 288        if (mood == WANT_PATTERN) {
 289          int z;
 290          do {
 291            z = end_of_format (p, ref_file);
 292            pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
 293          } while (z == EMBEDDED_FORMAT && pat == NO_NODE);
 294          if (pat == NO_NODE) {
 295            diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
 296            exit_genie (p, A68_RUNTIME_ERROR);
 297          }
 298        }
 299      }
 300      return pat;
 301    }
 302  }
 303  
 304  //! @brief Diagnostic_node in case mode does not match picture.
 305  
 306  void pattern_error (NODE_T * p, MOID_T * mode, int att)
 307  {
 308    diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_CANNOT_TRANSPUT, mode, att);
 309    exit_genie (p, A68_RUNTIME_ERROR);
 310  }
 311  
 312  //! @brief Unite value at top of stack to NUMBER.
 313  
 314  void unite_to_number (NODE_T * p, MOID_T * mode, BYTE_T * item)
 315  {
 316    ADDR_T sp = A68_SP;
 317    PUSH_UNION (p, mode);
 318    PUSH (p, item, (int) SIZE (mode));
 319    A68_SP = sp + SIZE (M_NUMBER);
 320  }
 321  
 322  //! @brief Write a group of insertions.
 323  
 324  void write_insertion (NODE_T * p, A68_REF ref_file, MOOD_T mood)
 325  {
 326    for (; p != NO_NODE; FORWARD (p)) {
 327      write_insertion (SUB (p), ref_file, mood);
 328      if (IS (p, FORMAT_ITEM_L)) {
 329        plusab_transput_buffer (p, FORMATTED_BUFFER, NEWLINE_CHAR);
 330        write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
 331      } else if (IS (p, FORMAT_ITEM_P)) {
 332        plusab_transput_buffer (p, FORMATTED_BUFFER, FORMFEED_CHAR);
 333        write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
 334      } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
 335        plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
 336      } else if (IS (p, FORMAT_ITEM_Y)) {
 337        PUSH_REF (p, ref_file);
 338        PUSH_VALUE (p, -1, A68_INT);
 339        genie_set (p);
 340      } else if (IS (p, LITERAL)) {
 341        if (mood & INSERTION_NORMAL) {
 342          add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
 343        } else if (mood & INSERTION_BLANK) {
 344          int j, k = (int) strlen (NSYMBOL (p));
 345          for (j = 1; j <= k; j++) {
 346            plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
 347          }
 348        }
 349      } else if (IS (p, REPLICATOR)) {
 350        int j, k = get_replicator_value (SUB (p), A68_TRUE);
 351        if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
 352          for (j = 1; j <= k; j++) {
 353            write_insertion (NEXT (p), ref_file, mood);
 354          }
 355        } else {
 356          int pos = get_transput_buffer_index (FORMATTED_BUFFER);
 357          for (j = 1; j < (k - pos); j++) {
 358            plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
 359          }
 360        }
 361        return;
 362      }
 363    }
 364  }
 365  
 366  //! @brief Write string to file following current format.
 367  
 368  void write_string_pattern (NODE_T * p, MOID_T * mode, A68_REF ref_file, char **str)
 369  {
 370    for (; p != NO_NODE; FORWARD (p)) {
 371      if (IS (p, INSERTION)) {
 372        write_insertion (SUB (p), ref_file, INSERTION_NORMAL);
 373      } else if (IS (p, FORMAT_ITEM_A)) {
 374        if ((*str)[0] != NULL_CHAR) {
 375          plusab_transput_buffer (p, FORMATTED_BUFFER, (*str)[0]);
 376          (*str)++;
 377        } else {
 378          value_error (p, mode, ref_file);
 379        }
 380      } else if (IS (p, FORMAT_ITEM_S)) {
 381        if ((*str)[0] != NULL_CHAR) {
 382          (*str)++;
 383        } else {
 384          value_error (p, mode, ref_file);
 385        }
 386        return;
 387      } else if (IS (p, REPLICATOR)) {
 388        int j, k = get_replicator_value (SUB (p), A68_TRUE);
 389        for (j = 1; j <= k; j++) {
 390          write_string_pattern (NEXT (p), mode, ref_file, str);
 391        }
 392        return;
 393      } else {
 394        write_string_pattern (SUB (p), mode, ref_file, str);
 395      }
 396    }
 397  }
 398  
 399  //! @brief Scan c_pattern.
 400  
 401  void scan_c_pattern (NODE_T * p, BOOL_T * right_align, BOOL_T * sign, int *width, int *after, int *letter)
 402  {
 403    if (IS (p, FORMAT_ITEM_ESCAPE)) {
 404      FORWARD (p);
 405    }
 406    if (IS (p, FORMAT_ITEM_MINUS)) {
 407      *right_align = A68_TRUE;
 408      FORWARD (p);
 409    } else {
 410      *right_align = A68_FALSE;
 411    }
 412    if (IS (p, FORMAT_ITEM_PLUS)) {
 413      *sign = A68_TRUE;
 414      FORWARD (p);
 415    } else {
 416      *sign = A68_FALSE;
 417    }
 418    if (IS (p, REPLICATOR)) {
 419      *width = get_replicator_value (SUB (p), A68_TRUE);
 420      FORWARD (p);
 421    }
 422    if (IS (p, FORMAT_ITEM_POINT)) {
 423      FORWARD (p);
 424    }
 425    if (IS (p, REPLICATOR)) {
 426      *after = get_replicator_value (SUB (p), A68_TRUE);
 427      FORWARD (p);
 428    }
 429    *letter = ATTRIBUTE (p);
 430  }
 431  
 432  //! @brief Write appropriate insertion from a choice pattern.
 433  
 434  void write_choice_pattern (NODE_T * p, A68_REF ref_file, int *count)
 435  {
 436    for (; p != NO_NODE; FORWARD (p)) {
 437      write_choice_pattern (SUB (p), ref_file, count);
 438      if (IS (p, PICTURE)) {
 439        (*count)--;
 440        if (*count == 0) {
 441          write_insertion (SUB (p), ref_file, INSERTION_NORMAL);
 442        }
 443      }
 444    }
 445  }
 446  
 447  //! @brief Write appropriate insertion from a boolean pattern.
 448  
 449  void write_boolean_pattern (NODE_T * p, A68_REF ref_file, BOOL_T z)
 450  {
 451    int k = (z ? 1 : 2);
 452    write_choice_pattern (p, ref_file, &k);
 453  }
 454  
 455  //! @brief Write value according to a general pattern.
 456  
 457  void write_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, int mod)
 458  {
 459    A68_REF row;
 460    A68_ARRAY *arr;
 461    A68_TUPLE *tup;
 462    int size;
 463  // Push arguments.
 464    unite_to_number (p, mode, item);
 465    EXECUTE_UNIT (NEXT_SUB (p));
 466    POP_REF (p, &row);
 467    GET_DESCRIPTOR (arr, tup, &row);
 468    size = ROW_SIZE (tup);
 469    if (size > 0) {
 470      int i;
 471      BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
 472      for (i = LWB (tup); i <= UPB (tup); i++) {
 473        int addr = INDEX_1_DIM (arr, tup, i);
 474        int arg = VALUE ((A68_INT *) & (base_address[addr]));
 475        PUSH_VALUE (p, arg, A68_INT);
 476      }
 477    }
 478  // Make a string.
 479    if (mod == FORMAT_ITEM_G) {
 480      switch (size) {
 481      case 1:
 482        {
 483          genie_whole (p);
 484          break;
 485        }
 486      case 2:
 487        {
 488          genie_fixed (p);
 489          break;
 490        }
 491      case 3:
 492        {
 493          genie_float (p);
 494          break;
 495        }
 496      default:
 497        {
 498          diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
 499          exit_genie (p, A68_RUNTIME_ERROR);
 500          break;
 501        }
 502      }
 503    } else if (mod == FORMAT_ITEM_H) {
 504      int def_expo = 0, def_mult;
 505      A68_INT a_width, a_after, a_expo, a_mult;
 506      STATUS (&a_width) = INIT_MASK;
 507      VALUE (&a_width) = 0;
 508      STATUS (&a_after) = INIT_MASK;
 509      VALUE (&a_after) = 0;
 510      STATUS (&a_expo) = INIT_MASK;
 511      VALUE (&a_expo) = 0;
 512      STATUS (&a_mult) = INIT_MASK;
 513      VALUE (&a_mult) = 0;
 514  // Set default values 
 515      if (mode == M_REAL || mode == M_INT) {
 516        def_expo = EXP_WIDTH + 1;
 517      } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
 518        def_expo = LONG_EXP_WIDTH + 1;
 519      } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
 520        def_expo = LONG_LONG_EXP_WIDTH + 1;
 521      }
 522      def_mult = 3;
 523  // Pop user values 
 524      switch (size) {
 525      case 1:
 526        {
 527          POP_OBJECT (p, &a_after, A68_INT);
 528          VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
 529          VALUE (&a_expo) = def_expo;
 530          VALUE (&a_mult) = def_mult;
 531          break;
 532        }
 533      case 2:
 534        {
 535          POP_OBJECT (p, &a_mult, A68_INT);
 536          POP_OBJECT (p, &a_after, A68_INT);
 537          VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
 538          VALUE (&a_expo) = def_expo;
 539          break;
 540        }
 541      case 3:
 542        {
 543          POP_OBJECT (p, &a_mult, A68_INT);
 544          POP_OBJECT (p, &a_after, A68_INT);
 545          POP_OBJECT (p, &a_width, A68_INT);
 546          VALUE (&a_expo) = def_expo;
 547          break;
 548        }
 549      case 4:
 550        {
 551          POP_OBJECT (p, &a_mult, A68_INT);
 552          POP_OBJECT (p, &a_expo, A68_INT);
 553          POP_OBJECT (p, &a_after, A68_INT);
 554          POP_OBJECT (p, &a_width, A68_INT);
 555          break;
 556        }
 557      default:
 558        {
 559          diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
 560          exit_genie (p, A68_RUNTIME_ERROR);
 561          break;
 562        }
 563      }
 564      PUSH_VALUE (p, VALUE (&a_width), A68_INT);
 565      PUSH_VALUE (p, VALUE (&a_after), A68_INT);
 566      PUSH_VALUE (p, VALUE (&a_expo), A68_INT);
 567      PUSH_VALUE (p, VALUE (&a_mult), A68_INT);
 568      genie_real (p);
 569    }
 570    add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
 571  }
 572  
 573  //! @brief Write %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.
 574  
 575  void write_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
 576  {
 577    BOOL_T right_align, sign, invalid;
 578    int width = 0, after = 0, letter;
 579    ADDR_T pop_sp = A68_SP;
 580    char *str = NO_TEXT;
 581    if (IS (p, CHAR_C_PATTERN)) {
 582      A68_CHAR *z = (A68_CHAR *) item;
 583      char q[2];
 584      q[0] = (char) VALUE (z);
 585      q[1] = NULL_CHAR;
 586      str = (char *) &q;
 587      width = (int) strlen (str);
 588      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 589    } else if (IS (p, STRING_C_PATTERN)) {
 590      str = (char *) item;
 591      width = (int) strlen (str);
 592      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 593    } else if (IS (p, INTEGRAL_C_PATTERN)) {
 594      width = 0;
 595      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 596      unite_to_number (p, mode, item);
 597      PUSH_VALUE (p, (sign ? width : -width), A68_INT);
 598      str = whole (p);
 599    } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
 600      int att = ATTRIBUTE (p), expval = 0, expo = 0;
 601      if (att == FLOAT_C_PATTERN || att == GENERAL_C_PATTERN) {
 602        int digits = 0;
 603        if (mode == M_REAL || mode == M_INT) {
 604          width = REAL_WIDTH + EXP_WIDTH + 4;
 605          after = REAL_WIDTH - 1;
 606          expo = EXP_WIDTH + 1;
 607        } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
 608          width = LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4;
 609          after = LONG_REAL_WIDTH - 1;
 610          expo = LONG_EXP_WIDTH + 1;
 611        } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
 612          width = LONG_LONG_REAL_WIDTH + LONG_LONG_EXP_WIDTH + 4;
 613          after = LONG_LONG_REAL_WIDTH - 1;
 614          expo = LONG_LONG_EXP_WIDTH + 1;
 615        }
 616        scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
 617        if (digits == 0 && after > 0) {
 618          width = after + expo + 4;
 619        } else if (digits > 0) {
 620          width = digits;
 621        }
 622        unite_to_number (p, mode, item);
 623        PUSH_VALUE (p, (sign ? width : -width), A68_INT);
 624        PUSH_VALUE (p, after, A68_INT);
 625        PUSH_VALUE (p, expo, A68_INT);
 626        PUSH_VALUE (p, 1, A68_INT);
 627        str = real (p);
 628        A68_SP = pop_sp;
 629      }
 630      if (att == GENERAL_C_PATTERN) {
 631        char *expch = strchr (str, EXPONENT_CHAR);
 632        if (expch != NO_TEXT) {
 633          expval = (int) strtol (&(expch[1]), NO_VAR, 10);
 634        }
 635      }
 636      if ((att == FIXED_C_PATTERN) || (att == GENERAL_C_PATTERN && (expval > -4 && expval <= after))) {
 637        int digits = 0;
 638        if (mode == M_REAL || mode == M_INT) {
 639          width = REAL_WIDTH + 2;
 640          after = REAL_WIDTH - 1;
 641        } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
 642          width = LONG_REAL_WIDTH + 2;
 643          after = LONG_REAL_WIDTH - 1;
 644        } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
 645          width = LONG_LONG_REAL_WIDTH + 2;
 646          after = LONG_LONG_REAL_WIDTH - 1;
 647        }
 648        scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
 649        if (digits == 0 && after > 0) {
 650          width = after + 2;
 651        } else if (digits > 0) {
 652          width = digits;
 653        }
 654        unite_to_number (p, mode, item);
 655        PUSH_VALUE (p, (sign ? width : -width), A68_INT);
 656        PUSH_VALUE (p, after, A68_INT);
 657        str = fixed (p);
 658        A68_SP = pop_sp;
 659      }
 660    } else if (IS (p, BITS_C_PATTERN)) {
 661      int radix = 10, nibble = 1;
 662      width = 0;
 663      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 664      if (letter == FORMAT_ITEM_B) {
 665        radix = 2;
 666        nibble = 1;
 667      } else if (letter == FORMAT_ITEM_O) {
 668        radix = 8;
 669        nibble = 3;
 670      } else if (letter == FORMAT_ITEM_X) {
 671        radix = 16;
 672        nibble = 4;
 673      }
 674      if (width == 0) {
 675        if (mode == M_BITS) {
 676          width = (int) ceil ((REAL_T) BITS_WIDTH / (REAL_T) nibble);
 677        } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
 678  #if (A68_LEVEL <= 2)
 679          width = (int) ceil ((REAL_T) get_mp_bits_width (mode) / (REAL_T) nibble);
 680  #else
 681          width = (int) ceil ((REAL_T) LONG_BITS_WIDTH / (REAL_T) nibble);
 682  #endif
 683        }
 684      }
 685      if (mode == M_BITS) {
 686        A68_BITS *z = (A68_BITS *) item;
 687        reset_transput_buffer (EDIT_BUFFER);
 688        if (!convert_radix (p, VALUE (z), radix, width)) {
 689          errno = EDOM;
 690          value_error (p, mode, ref_file);
 691        }
 692        str = get_transput_buffer (EDIT_BUFFER);
 693      } else if (mode == M_LONG_BITS) {
 694  #if (A68_LEVEL >= 3)
 695        A68_LONG_BITS *z = (A68_LONG_BITS *) item;
 696        reset_transput_buffer (EDIT_BUFFER);
 697        if (!convert_radix_double (p, VALUE (z), radix, width)) {
 698          errno = EDOM;
 699          value_error (p, mode, ref_file);
 700        }
 701        str = get_transput_buffer (EDIT_BUFFER);
 702  #else
 703        int digits = DIGITS (mode);
 704        MP_T *u = (MP_T *) item;
 705        MP_T *v = nil_mp (p, digits);
 706        MP_T *w = nil_mp (p, digits);
 707        reset_transput_buffer (EDIT_BUFFER);
 708        if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
 709          errno = EDOM;
 710          value_error (p, mode, ref_file);
 711        }
 712        str = get_transput_buffer (EDIT_BUFFER);
 713  #endif
 714      } else if (mode == M_LONG_LONG_BITS) {
 715  #if (A68_LEVEL <= 2)
 716        int digits = DIGITS (mode);
 717        MP_T *u = (MP_T *) item;
 718        MP_T *v = nil_mp (p, digits);
 719        MP_T *w = nil_mp (p, digits);
 720        reset_transput_buffer (EDIT_BUFFER);
 721        if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
 722          errno = EDOM;
 723          value_error (p, mode, ref_file);
 724        }
 725        str = get_transput_buffer (EDIT_BUFFER);
 726  #endif
 727      }
 728    }
 729  // Did the conversion succeed?.
 730    if (IS (p, CHAR_C_PATTERN) || IS (p, STRING_C_PATTERN)) {
 731      invalid = A68_FALSE;
 732    } else {
 733      invalid = (strchr (str, ERROR_CHAR) != NO_TEXT);
 734    }
 735    if (invalid) {
 736      value_error (p, mode, ref_file);
 737      (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
 738    } else {
 739  // Align and output.
 740      if (width == 0) {
 741        add_string_transput_buffer (p, FORMATTED_BUFFER, str);
 742      } else {
 743        if (right_align == A68_TRUE) {
 744          while (str[0] == BLANK_CHAR) {
 745            str++;
 746          }
 747          int blanks = width - (int) strlen (str);
 748          if (blanks >= 0) {
 749            add_string_transput_buffer (p, FORMATTED_BUFFER, str);
 750            while (blanks--) {
 751              plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
 752            }
 753          } else {
 754            value_error (p, mode, ref_file);
 755            (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
 756          }
 757        } else {
 758          while (str[0] == BLANK_CHAR) {
 759            str++;
 760          }
 761          int blanks = width - (int) strlen (str);
 762          if (blanks >= 0) {
 763            while (blanks--) {
 764              plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
 765            }
 766            add_string_transput_buffer (p, FORMATTED_BUFFER, str);
 767          } else {
 768            value_error (p, mode, ref_file);
 769            (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
 770          }
 771        }
 772      }
 773    }
 774  }
 775  
 776  //! @brief Read one char from file.
 777  
 778  char read_single_char (NODE_T * p, A68_REF ref_file)
 779  {
 780    A68_FILE *file = FILE_DEREF (&ref_file);
 781    int ch = char_scanner (file);
 782    if (ch == EOF_CHAR) {
 783      end_of_file_error (p, ref_file);
 784    }
 785    return (char) ch;
 786  }
 787  
 788  //! @brief Scan n chars from file to input buffer.
 789  
 790  void scan_n_chars (NODE_T * p, int n, MOID_T * m, A68_REF ref_file)
 791  {
 792    int k;
 793    (void) m;
 794    for (k = 0; k < n; k++) {
 795      int ch = read_single_char (p, ref_file);
 796      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 797    }
 798  }
 799  
 800  //! @brief Read %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.
 801  
 802  void read_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
 803  {
 804    BOOL_T right_align, sign;
 805    int width, after, letter;
 806    ADDR_T pop_sp = A68_SP;
 807    reset_transput_buffer (INPUT_BUFFER);
 808    if (IS (p, CHAR_C_PATTERN)) {
 809      width = 0;
 810      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 811      if (width == 0) {
 812        genie_read_standard (p, mode, item, ref_file);
 813      } else {
 814        scan_n_chars (p, width, mode, ref_file);
 815        if (width > 1 && right_align == A68_FALSE) {
 816          for (; width > 1; width--) {
 817            (void) pop_char_transput_buffer (INPUT_BUFFER);
 818          }
 819        }
 820        genie_string_to_value (p, mode, item, ref_file);
 821      }
 822    } else if (IS (p, STRING_C_PATTERN)) {
 823      width = 0;
 824      scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 825      if (width == 0) {
 826        genie_read_standard (p, mode, item, ref_file);
 827      } else {
 828        scan_n_chars (p, width, mode, ref_file);
 829        genie_string_to_value (p, mode, item, ref_file);
 830      }
 831    } else if (IS (p, INTEGRAL_C_PATTERN)) {
 832      if (mode != M_INT && mode != M_LONG_INT && mode != M_LONG_LONG_INT) {
 833        pattern_error (p, mode, ATTRIBUTE (p));
 834      } else {
 835        width = 0;
 836        scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 837        if (width == 0) {
 838          genie_read_standard (p, mode, item, ref_file);
 839        } else {
 840          scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
 841          genie_string_to_value (p, mode, item, ref_file);
 842        }
 843      }
 844    } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
 845      if (mode != M_REAL && mode != M_LONG_REAL && mode != M_LONG_LONG_REAL) {
 846        pattern_error (p, mode, ATTRIBUTE (p));
 847      } else {
 848        width = 0;
 849        scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 850        if (width == 0) {
 851          genie_read_standard (p, mode, item, ref_file);
 852        } else {
 853          scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
 854          genie_string_to_value (p, mode, item, ref_file);
 855        }
 856      }
 857    } else if (IS (p, BITS_C_PATTERN)) {
 858      if (mode != M_BITS && mode != M_LONG_BITS && mode != M_LONG_LONG_BITS) {
 859        pattern_error (p, mode, ATTRIBUTE (p));
 860      } else {
 861        int radix = 10;
 862        char *str;
 863        width = 0;
 864        scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
 865        if (letter == FORMAT_ITEM_B) {
 866          radix = 2;
 867        } else if (letter == FORMAT_ITEM_O) {
 868          radix = 8;
 869        } else if (letter == FORMAT_ITEM_X) {
 870          radix = 16;
 871        }
 872        str = get_transput_buffer (INPUT_BUFFER);
 873        if (width == 0) {
 874          A68_FILE *file = FILE_DEREF (&ref_file);
 875          int ch;
 876          ASSERT (snprintf (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
 877          set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str));
 878          ch = char_scanner (file);
 879          while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
 880            if (IS_NL_FF (ch)) {
 881              skip_nl_ff (p, &ch, ref_file);
 882            } else {
 883              ch = char_scanner (file);
 884            }
 885          }
 886          while (ch != EOF_CHAR && IS_XDIGIT (ch)) {
 887            plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 888            ch = char_scanner (file);
 889          }
 890          unchar_scanner (p, file, (char) ch);
 891        } else {
 892          ASSERT (snprintf (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
 893          set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str));
 894          scan_n_chars (p, width, mode, ref_file);
 895        }
 896        genie_string_to_value (p, mode, item, ref_file);
 897      }
 898    }
 899    A68_SP = pop_sp;
 900  }
 901  
 902  // INTEGRAL, REAL, COMPLEX and BITS patterns.
 903  
 904  //! @brief Count Z and D frames in a mould.
 905  
 906  void count_zd_frames (NODE_T * p, int *z)
 907  {
 908    for (; p != NO_NODE; FORWARD (p)) {
 909      if (IS (p, FORMAT_ITEM_D) || IS (p, FORMAT_ITEM_Z)) {
 910        (*z)++;
 911      } else if (IS (p, REPLICATOR)) {
 912        int j, k = get_replicator_value (SUB (p), A68_TRUE);
 913        for (j = 1; j <= k; j++) {
 914          count_zd_frames (NEXT (p), z);
 915        }
 916        return;
 917      } else {
 918        count_zd_frames (SUB (p), z);
 919      }
 920    }
 921  }
 922  
 923  //! @brief Get sign from sign mould.
 924  
 925  NODE_T *get_sign (NODE_T * p)
 926  {
 927    for (; p != NO_NODE; FORWARD (p)) {
 928      NODE_T *q = get_sign (SUB (p));
 929      if (q != NO_NODE) {
 930        return q;
 931      } else if (IS (p, FORMAT_ITEM_PLUS) || IS (p, FORMAT_ITEM_MINUS)) {
 932        return p;
 933      }
 934    }
 935    return NO_NODE;
 936  }
 937  
 938  //! @brief Shift sign through Z frames until non-zero digit or D frame.
 939  
 940  void shift_sign (NODE_T * p, char **q)
 941  {
 942    for (; p != NO_NODE && (*q) != NO_TEXT; FORWARD (p)) {
 943      shift_sign (SUB (p), q);
 944      if (IS (p, FORMAT_ITEM_Z)) {
 945        if (((*q)[0] == '+' || (*q)[0] == '-') && (*q)[1] == '0') {
 946          char ch = (*q)[0];
 947          (*q)[0] = (*q)[1];
 948          (*q)[1] = ch;
 949          (*q)++;
 950        }
 951      } else if (IS (p, FORMAT_ITEM_D)) {
 952        (*q) = NO_TEXT;
 953      } else if (IS (p, REPLICATOR)) {
 954        int j, k = get_replicator_value (SUB (p), A68_TRUE);
 955        for (j = 1; j <= k; j++) {
 956          shift_sign (NEXT (p), q);
 957        }
 958        return;
 959      }
 960    }
 961  }
 962  
 963  //! @brief Pad trailing blanks to integral until desired width.
 964  
 965  void put_zeroes_to_integral (NODE_T * p, int n)
 966  {
 967    for (; n > 0; n--) {
 968      plusab_transput_buffer (p, EDIT_BUFFER, '0');
 969    }
 970  }
 971  
 972  //! @brief Pad a sign to integral representation.
 973  
 974  void put_sign_to_integral (NODE_T * p, int sign)
 975  {
 976    NODE_T *sign_node = get_sign (SUB (p));
 977    if (IS (sign_node, FORMAT_ITEM_PLUS)) {
 978      plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? '+' : '-'));
 979    } else {
 980      plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? BLANK_CHAR : '-'));
 981    }
 982  }
 983  
 984  //! @brief Write point, exponent or plus-i-times symbol.
 985  
 986  void write_pie_frame (NODE_T * p, A68_REF ref_file, int att, int sym)
 987  {
 988    for (; p != NO_NODE; FORWARD (p)) {
 989      if (IS (p, INSERTION)) {
 990        write_insertion (p, ref_file, INSERTION_NORMAL);
 991      } else if (IS (p, att)) {
 992        write_pie_frame (SUB (p), ref_file, att, sym);
 993        return;
 994      } else if (IS (p, sym)) {
 995        add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
 996      } else if (IS (p, FORMAT_ITEM_S)) {
 997        return;
 998      }
 999    }
1000  }
1001  
1002  //! @brief Write sign when appropriate.
1003  
1004  void write_mould_put_sign (NODE_T * p, char **q)
1005  {
1006    if ((*q)[0] == '+' || (*q)[0] == '-' || (*q)[0] == BLANK_CHAR) {
1007      plusab_transput_buffer (p, FORMATTED_BUFFER, (*q)[0]);
1008      (*q)++;
1009    }
1010  }
1011  
1012  //! @brief Write character according to a mould.
1013  
1014  void add_char_mould (NODE_T * p, char ch, char **q)
1015  {
1016    if (ch != NULL_CHAR) {
1017      plusab_transput_buffer (p, FORMATTED_BUFFER, ch);
1018      (*q)++;
1019    }
1020  }
1021  
1022  //! @brief Write string according to a mould.
1023  
1024  void write_mould (NODE_T * p, A68_REF ref_file, int type, char **q, MOOD_T * mood)
1025  {
1026    for (; p != NO_NODE; FORWARD (p)) {
1027  // Insertions are inserted straight away. Note that we can suppress them using "mood", which is not standard A68.
1028      if (IS (p, INSERTION)) {
1029        write_insertion (SUB (p), ref_file, *mood);
1030      } else {
1031        write_mould (SUB (p), ref_file, type, q, mood);
1032  // Z frames print blanks until first non-zero digits comes.
1033        if (IS (p, FORMAT_ITEM_Z)) {
1034          write_mould_put_sign (p, q);
1035          if ((*q)[0] == '0') {
1036            if (*mood & DIGIT_BLANK) {
1037              add_char_mould (p, BLANK_CHAR, q);
1038              *mood = (*mood & ~INSERTION_NORMAL) | INSERTION_BLANK;
1039            } else if (*mood & DIGIT_NORMAL) {
1040              add_char_mould (p, '0', q);
1041              *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1042            }
1043          } else {
1044            add_char_mould (p, (*q)[0], q);
1045            *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1046          }
1047        }
1048  // D frames print a digit.
1049        else if (IS (p, FORMAT_ITEM_D)) {
1050          write_mould_put_sign (p, q);
1051          add_char_mould (p, (*q)[0], q);
1052          *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1053        }
1054  // Suppressible frames.
1055        else if (IS (p, FORMAT_ITEM_S)) {
1056  // Suppressible frames are ignored in a sign-mould.
1057          if (type == SIGN_MOULD) {
1058            write_mould (NEXT (p), ref_file, type, q, mood);
1059          } else if (type == INTEGRAL_MOULD) {
1060            if ((*q)[0] != NULL_CHAR) {
1061              (*q)++;
1062            }
1063          }
1064          return;
1065        }
1066  // Replicator.
1067        else if (IS (p, REPLICATOR)) {
1068          int j, k = get_replicator_value (SUB (p), A68_TRUE);
1069          for (j = 1; j <= k; j++) {
1070            write_mould (NEXT (p), ref_file, type, q, mood);
1071          }
1072          return;
1073        }
1074      }
1075    }
1076  }
1077  
1078  //! @brief Write INT value using int pattern.
1079  
1080  void write_integral_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file)
1081  {
1082    errno = 0;
1083    if (!(mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT)) {
1084      pattern_error (p, root, ATTRIBUTE (p));
1085    } else {
1086      ADDR_T pop_sp = A68_SP;
1087      char *str = "*";
1088      int width = 0, sign = 0;
1089      MOOD_T mood;
1090  // Dive into the pattern if needed.
1091      if (IS (p, INTEGRAL_PATTERN)) {
1092        p = SUB (p);
1093      }
1094  // Find width.
1095      count_zd_frames (p, &width);
1096  // Make string.
1097      reset_transput_buffer (EDIT_BUFFER);
1098      if (mode == M_INT) {
1099        A68_INT *z = (A68_INT *) item;
1100        sign = SIGN (VALUE (z));
1101        str = sub_whole (p, ABS (VALUE (z)), width);
1102      } else if (mode == M_LONG_INT) {
1103  #if (A68_LEVEL >= 3)
1104        A68_LONG_INT *z = (A68_LONG_INT *) item;
1105        DOUBLE_NUM_T w = VALUE (z);
1106        sign = sign_double_int (w);
1107        str = long_sub_whole_double (p, abs_double_int (w), width);
1108  #else
1109        MP_T *z = (MP_T *) item;
1110        sign = MP_SIGN (z);
1111        MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
1112        str = long_sub_whole (p, z, DIGITS (mode), width);
1113  #endif
1114      } else if (mode == M_LONG_LONG_INT) {
1115        MP_T *z = (MP_T *) item;
1116        sign = MP_SIGN (z);
1117        MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
1118        str = long_sub_whole (p, z, DIGITS (mode), width);
1119      }
1120  // Edit string and output.
1121      if (strchr (str, ERROR_CHAR) != NO_TEXT) {
1122        value_error (p, root, ref_file);
1123      }
1124      if (IS (p, SIGN_MOULD)) {
1125        put_sign_to_integral (p, sign);
1126      } else if (sign < 0) {
1127        value_sign_error (p, root, ref_file);
1128      }
1129      put_zeroes_to_integral (p, width - (int) strlen (str));
1130      add_string_transput_buffer (p, EDIT_BUFFER, str);
1131      str = get_transput_buffer (EDIT_BUFFER);
1132      mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1133      if (IS (p, SIGN_MOULD)) {
1134        if (str[0] == '+' || str[0] == '-') {
1135          shift_sign (SUB (p), &str);
1136        }
1137        str = get_transput_buffer (EDIT_BUFFER);
1138        write_mould (SUB (p), ref_file, SIGN_MOULD, &str, &mood);
1139        FORWARD (p);
1140      }
1141      if (IS (p, INTEGRAL_MOULD)) {       // This *should* be the case
1142        write_mould (SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
1143      }
1144      A68_SP = pop_sp;
1145    }
1146  }
1147  
1148  //! @brief Write REAL value using real pattern.
1149  
1150  void write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file)
1151  {
1152    errno = 0;
1153    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)) {
1154      pattern_error (p, root, ATTRIBUTE (p));
1155    } else {
1156      ADDR_T pop_sp = A68_SP;
1157      int stag_digits = 0, frac_digits = 0, expo_digits = 0;
1158      int mant_length, sign = 0, exp_value;
1159      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;
1160      char *str = NO_TEXT, *stag_str = NO_TEXT, *frac_str = NO_TEXT;
1161      MOOD_T mood;
1162  // Dive into pattern.
1163      q = ((IS (p, REAL_PATTERN)) ? SUB (p) : p);
1164  // Dissect pattern and establish widths.
1165      if (q != NO_NODE && IS (q, SIGN_MOULD)) {
1166        sign_mould = q;
1167        count_zd_frames (SUB (sign_mould), &stag_digits);
1168        FORWARD (q);
1169      }
1170      if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
1171        stag_mould = q;
1172        count_zd_frames (SUB (stag_mould), &stag_digits);
1173        FORWARD (q);
1174      }
1175      if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
1176        point_frame = q;
1177        FORWARD (q);
1178      }
1179      if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
1180        frac_mould = q;
1181        count_zd_frames (SUB (frac_mould), &frac_digits);
1182        FORWARD (q);
1183      }
1184      if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
1185        e_frame = SUB (q);
1186        expo_mould = NEXT_SUB (q);
1187        q = expo_mould;
1188        if (IS (q, SIGN_MOULD)) {
1189          count_zd_frames (SUB (q), &expo_digits);
1190          FORWARD (q);
1191        }
1192        if (IS (q, INTEGRAL_MOULD)) {
1193          count_zd_frames (SUB (q), &expo_digits);
1194        }
1195      }
1196  // Make string representation.
1197      if (point_frame == NO_NODE) {
1198        mant_length = stag_digits;
1199      } else {
1200        mant_length = 1 + stag_digits + frac_digits;
1201      }
1202      if (mode == M_REAL || mode == M_INT) {
1203        REAL_T x;
1204        if (mode == M_REAL) {
1205          x = VALUE ((A68_REAL *) item);
1206        } else {
1207          x = (REAL_T) VALUE ((A68_INT *) item);
1208        }
1209        CHECK_REAL (p, x);
1210        exp_value = 0;
1211        sign = SIGN (x);
1212        if (sign_mould != NO_NODE) {
1213          put_sign_to_integral (sign_mould, sign);
1214        }
1215        x = ABS (x);
1216        if (expo_mould != NO_NODE) {
1217          standardise (&x, stag_digits, frac_digits, &exp_value);
1218        }
1219        str = sub_fixed (p, x, mant_length, frac_digits);
1220      } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
1221  #if (A68_LEVEL >= 3)
1222        DOUBLE_NUM_T x = VALUE ((A68_DOUBLE *) item);
1223        if (mode == M_LONG_INT) {
1224          x = double_int_to_double_real (p, x);
1225        }
1226        CHECK_DOUBLE_REAL (p, x.f);
1227        exp_value = 0;
1228        sign = sign_double_real (x);
1229        if (sign_mould != NO_NODE) {
1230          put_sign_to_integral (sign_mould, sign);
1231        }
1232        x.f = fabsq (x.f);
1233        if (expo_mould != NO_NODE) {
1234          standardise_double (&(x.f), stag_digits, frac_digits, &exp_value);
1235        }
1236        str = sub_fixed_double (p, x.f, mant_length, frac_digits, LONG_REAL_WIDTH);
1237  #else
1238        ADDR_T pop_sp2 = A68_SP;
1239        int digits = DIGITS (mode);
1240        MP_T *x = nil_mp (p, digits);
1241        (void) move_mp (x, (MP_T *) item, digits);
1242        exp_value = 0;
1243        sign = SIGN (x[2]);
1244        if (sign_mould != NO_NODE) {
1245          put_sign_to_integral (sign_mould, sign);
1246        }
1247        x[2] = ABS (x[2]);
1248        if (expo_mould != NO_NODE) {
1249          long_standardise (p, x, DIGITS (mode), stag_digits, frac_digits, &exp_value);
1250        }
1251        str = long_sub_fixed (p, x, DIGITS (mode), mant_length, frac_digits);
1252        A68_SP = pop_sp2;
1253  #endif
1254      } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
1255        ADDR_T pop_sp2 = A68_SP;
1256        int digits = DIGITS (mode);
1257        MP_T *x = nil_mp (p, digits);
1258        (void) move_mp (x, (MP_T *) item, digits);
1259        exp_value = 0;
1260        sign = SIGN (x[2]);
1261        if (sign_mould != NO_NODE) {
1262          put_sign_to_integral (sign_mould, sign);
1263        }
1264        x[2] = ABS (x[2]);
1265        if (expo_mould != NO_NODE) {
1266          long_standardise (p, x, DIGITS (mode), stag_digits, frac_digits, &exp_value);
1267        }
1268        str = long_sub_fixed (p, x, DIGITS (mode), mant_length, frac_digits);
1269        A68_SP = pop_sp2;
1270      }
1271  // Edit and output the string.
1272      if (strchr (str, ERROR_CHAR) != NO_TEXT) {
1273        value_error (p, root, ref_file);
1274      }
1275      reset_transput_buffer (STRING_BUFFER);
1276      add_string_transput_buffer (p, STRING_BUFFER, str);
1277      stag_str = get_transput_buffer (STRING_BUFFER);
1278      if (strchr (stag_str, ERROR_CHAR) != NO_TEXT) {
1279        value_error (p, root, ref_file);
1280      }
1281      str = strchr (stag_str, POINT_CHAR);
1282      if (str != NO_TEXT) {
1283        frac_str = &str[1];
1284        str[0] = NULL_CHAR;
1285      } else {
1286        frac_str = NO_TEXT;
1287      }
1288  // Stagnant part.
1289      reset_transput_buffer (EDIT_BUFFER);
1290      if (sign_mould != NO_NODE) {
1291        put_sign_to_integral (sign_mould, sign);
1292      } else if (sign < 0) {
1293        value_sign_error (sign_mould, root, ref_file);
1294      }
1295      put_zeroes_to_integral (p, stag_digits - (int) strlen (stag_str));
1296      add_string_transput_buffer (p, EDIT_BUFFER, stag_str);
1297      stag_str = get_transput_buffer (EDIT_BUFFER);
1298      mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1299      if (sign_mould != NO_NODE) {
1300        if (stag_str[0] == '+' || stag_str[0] == '-') {
1301          shift_sign (SUB (p), &stag_str);
1302        }
1303        stag_str = get_transput_buffer (EDIT_BUFFER);
1304        write_mould (SUB (sign_mould), ref_file, SIGN_MOULD, &stag_str, &mood);
1305      }
1306      if (stag_mould != NO_NODE) {
1307        write_mould (SUB (stag_mould), ref_file, INTEGRAL_MOULD, &stag_str, &mood);
1308      }
1309  // Point frame.
1310      if (point_frame != NO_NODE) {
1311        write_pie_frame (point_frame, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT);
1312      }
1313  // Fraction.
1314      if (frac_mould != NO_NODE) {
1315        reset_transput_buffer (EDIT_BUFFER);
1316        add_string_transput_buffer (p, EDIT_BUFFER, frac_str);
1317        frac_str = get_transput_buffer (EDIT_BUFFER);
1318        mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1319        write_mould (SUB (frac_mould), ref_file, INTEGRAL_MOULD, &frac_str, &mood);
1320      }
1321  // Exponent.
1322      if (expo_mould != NO_NODE) {
1323        A68_INT z;
1324        STATUS (&z) = INIT_MASK;
1325        VALUE (&z) = exp_value;
1326        if (e_frame != NO_NODE) {
1327          write_pie_frame (e_frame, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E);
1328        }
1329        write_integral_pattern (expo_mould, M_INT, root, (BYTE_T *) & z, ref_file);
1330      }
1331      A68_SP = pop_sp;
1332    }
1333  }
1334  
1335  //! @brief Write COMPLEX value using complex pattern.
1336  
1337  void write_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * root, BYTE_T * re, BYTE_T * im, A68_REF ref_file)
1338  {
1339    NODE_T *reel, *plus_i_times, *imag;
1340    errno = 0;
1341  // Dissect pattern.
1342    reel = SUB (p);
1343    plus_i_times = NEXT (reel);
1344    imag = NEXT (plus_i_times);
1345  // Write pattern.
1346    write_real_pattern (reel, comp, root, re, ref_file);
1347    write_pie_frame (plus_i_times, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I);
1348    write_real_pattern (imag, comp, root, im, ref_file);
1349  }
1350  
1351  //! @brief Write BITS value using bits pattern.
1352  
1353  void write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
1354  {
1355    MOOD_T mood;
1356    int width = 0, radix;
1357    char *str;
1358    ADDR_T pop_sp = A68_SP;
1359    if (mode == M_BITS) {
1360      A68_BITS *z = (A68_BITS *) item;
1361  // Establish width and radix.
1362      count_zd_frames (SUB (p), &width);
1363      radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
1364      if (radix < 2 || radix > 16) {
1365        diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1366        exit_genie (p, A68_RUNTIME_ERROR);
1367      }
1368  // Generate string of correct width.
1369      reset_transput_buffer (EDIT_BUFFER);
1370      if (!convert_radix (p, VALUE (z), radix, width)) {
1371        errno = EDOM;
1372        value_error (p, mode, ref_file);
1373      }
1374    } else if (mode == M_LONG_BITS) {
1375  #if (A68_LEVEL >= 3)
1376      A68_LONG_BITS *z = (A68_LONG_BITS *) item;
1377  // Establish width and radix.
1378      count_zd_frames (SUB (p), &width);
1379      radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
1380      if (radix < 2 || radix > 16) {
1381        diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1382        exit_genie (p, A68_RUNTIME_ERROR);
1383      }
1384  // Generate string of correct width.
1385      reset_transput_buffer (EDIT_BUFFER);
1386      if (!convert_radix_double (p, VALUE (z), radix, width)) {
1387        errno = EDOM;
1388        value_error (p, mode, ref_file);
1389      }
1390  #else
1391      int digits = DIGITS (mode);
1392      MP_T *u = (MP_T *) item;
1393      MP_T *v = nil_mp (p, digits);
1394      MP_T *w = nil_mp (p, digits);
1395  // Establish width and radix.
1396      count_zd_frames (SUB (p), &width);
1397      radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
1398      if (radix < 2 || radix > 16) {
1399        diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1400        exit_genie (p, A68_RUNTIME_ERROR);
1401      }
1402  // Generate string of correct width.
1403      reset_transput_buffer (EDIT_BUFFER);
1404      if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
1405        errno = EDOM;
1406        value_error (p, mode, ref_file);
1407      }
1408  #endif
1409    } else if (mode == M_LONG_LONG_BITS) {
1410  #if (A68_LEVEL <= 2)
1411      int digits = DIGITS (mode);
1412      MP_T *u = (MP_T *) item;
1413      MP_T *v = nil_mp (p, digits);
1414      MP_T *w = nil_mp (p, digits);
1415  // Establish width and radix.
1416      count_zd_frames (SUB (p), &width);
1417      radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
1418      if (radix < 2 || radix > 16) {
1419        diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1420        exit_genie (p, A68_RUNTIME_ERROR);
1421      }
1422  // Generate string of correct width.
1423      reset_transput_buffer (EDIT_BUFFER);
1424      if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
1425        errno = EDOM;
1426        value_error (p, mode, ref_file);
1427      }
1428  #endif
1429    }
1430  // Output the edited string.
1431    mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1432    str = get_transput_buffer (EDIT_BUFFER);
1433    write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
1434    A68_SP = pop_sp;
1435  }
1436  
1437  //! @brief Write value to file.
1438  
1439  void genie_write_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
1440  {
1441    if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1442      genie_value_to_string (p, M_REAL, item, ATTRIBUTE (SUB (p)));
1443      add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1444    } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1445      write_number_generic (p, M_REAL, item, ATTRIBUTE (SUB (p)));
1446    } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1447      write_c_pattern (p, M_REAL, item, ref_file);
1448    } else if (IS (p, REAL_PATTERN)) {
1449      write_real_pattern (p, M_REAL, M_REAL, item, ref_file);
1450    } else if (IS (p, COMPLEX_PATTERN)) {
1451      A68_REAL im;
1452      STATUS (&im) = INIT_MASK;
1453      VALUE (&im) = 0.0;
1454      write_complex_pattern (p, M_REAL, M_COMPLEX, (BYTE_T *) item, (BYTE_T *) & im, ref_file);
1455    } else {
1456      pattern_error (p, M_REAL, ATTRIBUTE (p));
1457    }
1458  }
1459  
1460  //! @brief Write value to file.
1461  
1462  void genie_write_long_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
1463  {
1464    if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1465      genie_value_to_string (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1466      add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1467    } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1468      write_number_generic (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1469    } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1470      write_c_pattern (p, M_LONG_REAL, item, ref_file);
1471    } else if (IS (p, REAL_PATTERN)) {
1472      write_real_pattern (p, M_LONG_REAL, M_LONG_REAL, item, ref_file);
1473    } else if (IS (p, COMPLEX_PATTERN)) {
1474  #if (A68_LEVEL >= 3)
1475      ADDR_T pop_sp = A68_SP;
1476      A68_LONG_REAL *z = (A68_LONG_REAL *) STACK_TOP;
1477      DOUBLE_NUM_T im;
1478      im.f = 0.0q;
1479      PUSH_VALUE (p, im, A68_LONG_REAL);
1480      write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1481      A68_SP = pop_sp;
1482  #else
1483      ADDR_T pop_sp = A68_SP;
1484      MP_T *z = nil_mp (p, DIGITS (M_LONG_REAL));
1485      z[0] = (MP_T) INIT_MASK;
1486      write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1487      A68_SP = pop_sp;
1488  #endif
1489    } else {
1490      pattern_error (p, M_LONG_REAL, ATTRIBUTE (p));
1491    }
1492  }
1493  
1494  //! @brief Write value to file.
1495  
1496  void genie_write_long_mp_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
1497  {
1498    if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1499      genie_value_to_string (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1500      add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1501    } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1502      write_number_generic (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1503    } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1504      write_c_pattern (p, M_LONG_LONG_REAL, item, ref_file);
1505    } else if (IS (p, REAL_PATTERN)) {
1506      write_real_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_REAL, item, ref_file);
1507    } else if (IS (p, COMPLEX_PATTERN)) {
1508      ADDR_T pop_sp = A68_SP;
1509      MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
1510      z[0] = (MP_T) INIT_MASK;
1511      write_complex_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1512      A68_SP = pop_sp;
1513    } else {
1514      pattern_error (p, M_LONG_LONG_REAL, ATTRIBUTE (p));
1515    }
1516  }
1517  
1518  //! @brief At end of write purge all insertions.
1519  
1520  void purge_format_write (NODE_T * p, A68_REF ref_file)
1521  {
1522  // Problem here is shutting down embedded formats.
1523    BOOL_T go_on;
1524    do {
1525      A68_FILE *file;
1526      NODE_T *dollar, *pat;
1527      A68_FORMAT *old_fmt;
1528      while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
1529        format_error (p, ref_file, ERROR_FORMAT_PICTURES);
1530      }
1531      file = FILE_DEREF (&ref_file);
1532      dollar = SUB (BODY (&FORMAT (file)));
1533      old_fmt = (A68_FORMAT *) FRAME_LOCAL (A68_FP, OFFSET (TAX (dollar)));
1534      go_on = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
1535      if (go_on) {
1536  // Pop embedded format and proceed.
1537        (void) end_of_format (p, ref_file);
1538      }
1539    } while (go_on);
1540  }
1541  
1542  //! @brief Write value to file.
1543  
1544  void genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file, int *formats)
1545  {
1546    errno = 0;
1547    ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1548    if (mode == M_FORMAT) {
1549      A68_FILE *file;
1550      CHECK_REF (p, ref_file, M_REF_FILE);
1551      file = FILE_DEREF (&ref_file);
1552  // Forget about eventual active formats and set up new one.
1553      if (*formats > 0) {
1554        purge_format_write (p, ref_file);
1555      }
1556      (*formats)++;
1557      A68_FP = FRAME_POINTER (file);
1558      A68_SP = STACK_POINTER (file);
1559      open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE);
1560    } else if (mode == M_PROC_REF_FILE_VOID) {
1561      diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
1562      exit_genie (p, A68_RUNTIME_ERROR);
1563    } else if (mode == M_SOUND) {
1564      diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_SOUND);
1565      exit_genie (p, A68_RUNTIME_ERROR);
1566    } else if (mode == M_INT) {
1567      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1568      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1569        genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1570        add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1571      } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1572        write_number_generic (pat, M_INT, item, ATTRIBUTE (SUB (pat)));
1573      } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1574        write_c_pattern (pat, M_INT, item, ref_file);
1575      } else if (IS (pat, INTEGRAL_PATTERN)) {
1576        write_integral_pattern (pat, M_INT, M_INT, item, ref_file);
1577      } else if (IS (pat, REAL_PATTERN)) {
1578        write_real_pattern (pat, M_INT, M_INT, item, ref_file);
1579      } else if (IS (pat, COMPLEX_PATTERN)) {
1580        A68_REAL re, im;
1581        STATUS (&re) = INIT_MASK;
1582        VALUE (&re) = (REAL_T) VALUE ((A68_INT *) item);
1583        STATUS (&im) = INIT_MASK;
1584        VALUE (&im) = 0.0;
1585        write_complex_pattern (pat, M_REAL, M_COMPLEX, (BYTE_T *) & re, (BYTE_T *) & im, ref_file);
1586      } else if (IS (pat, CHOICE_PATTERN)) {
1587        int k = VALUE ((A68_INT *) item);
1588        write_choice_pattern (NEXT_SUB (pat), ref_file, &k);
1589      } else {
1590        pattern_error (p, mode, ATTRIBUTE (pat));
1591      }
1592    } else if (mode == M_LONG_INT) {
1593      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1594      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1595        genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1596        add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1597      } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1598        write_number_generic (pat, M_LONG_INT, item, ATTRIBUTE (SUB (pat)));
1599      } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1600        write_c_pattern (pat, M_LONG_INT, item, ref_file);
1601      } else if (IS (pat, INTEGRAL_PATTERN)) {
1602        write_integral_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
1603      } else if (IS (pat, REAL_PATTERN)) {
1604        write_real_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
1605      } else if (IS (pat, COMPLEX_PATTERN)) {
1606  #if (A68_LEVEL >= 3)
1607        ADDR_T pop_sp = A68_SP;
1608        A68_LONG_REAL *z = (A68_LONG_REAL *) STACK_TOP;
1609        DOUBLE_NUM_T im;
1610        im.f = 0.0q;
1611        PUSH_VALUE (p, im, A68_LONG_REAL);
1612        write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1613        A68_SP = pop_sp;
1614  #else
1615        ADDR_T pop_sp = A68_SP;
1616        MP_T *z = nil_mp (p, DIGITS (mode));
1617        z[0] = (MP_T) INIT_MASK;
1618        write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1619        A68_SP = pop_sp;
1620  #endif
1621      } else if (IS (pat, CHOICE_PATTERN)) {
1622        INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
1623        int sk;
1624        CHECK_INT_SHORTEN (p, k);
1625        sk = (int) k;
1626        write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
1627      } else {
1628        pattern_error (p, mode, ATTRIBUTE (pat));
1629      }
1630    } else if (mode == M_LONG_LONG_INT) {
1631      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1632      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1633        genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1634        add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1635      } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1636        write_number_generic (pat, M_LONG_LONG_INT, item, ATTRIBUTE (SUB (pat)));
1637      } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1638        write_c_pattern (pat, M_LONG_LONG_INT, item, ref_file);
1639      } else if (IS (pat, INTEGRAL_PATTERN)) {
1640        write_integral_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
1641      } else if (IS (pat, REAL_PATTERN)) {
1642        write_real_pattern (pat, M_INT, M_INT, item, ref_file);
1643      } else if (IS (pat, REAL_PATTERN)) {
1644        write_real_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
1645      } else if (IS (pat, COMPLEX_PATTERN)) {
1646        ADDR_T pop_sp = A68_SP;
1647        MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
1648        z[0] = (MP_T) INIT_MASK;
1649        write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1650        A68_SP = pop_sp;
1651      } else if (IS (pat, CHOICE_PATTERN)) {
1652        INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
1653        int sk;
1654        CHECK_INT_SHORTEN (p, k);
1655        sk = (int) k;
1656        write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
1657      } else {
1658        pattern_error (p, mode, ATTRIBUTE (pat));
1659      }
1660    } else if (mode == M_REAL) {
1661      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1662      genie_write_real_format (pat, item, ref_file);
1663    } else if (mode == M_LONG_REAL) {
1664      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1665      genie_write_long_real_format (pat, item, ref_file);
1666    } else if (mode == M_LONG_LONG_REAL) {
1667      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1668      genie_write_long_mp_real_format (pat, item, ref_file);
1669    } else if (mode == M_COMPLEX) {
1670      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1671      if (IS (pat, COMPLEX_PATTERN)) {
1672        write_complex_pattern (pat, M_REAL, M_COMPLEX, &item[0], &item[SIZE (M_REAL)], ref_file);
1673      } else {
1674  // Try writing as two REAL values.
1675        genie_write_real_format (pat, item, ref_file);
1676        genie_write_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
1677      }
1678    } else if (mode == M_LONG_COMPLEX) {
1679      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1680      if (IS (pat, COMPLEX_PATTERN)) {
1681        write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_REAL)], ref_file);
1682      } else {
1683  // Try writing as two LONG REAL values.
1684        genie_write_long_real_format (pat, item, ref_file);
1685        genie_write_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
1686      }
1687    } else if (mode == M_LONG_LONG_COMPLEX) {
1688      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1689      if (IS (pat, COMPLEX_PATTERN)) {
1690        write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_LONG_REAL)], ref_file);
1691      } else {
1692  // Try writing as two LONG LONG REAL values.
1693        genie_write_long_mp_real_format (pat, item, ref_file);
1694        genie_write_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
1695      }
1696    } else if (mode == M_BOOL) {
1697      A68_BOOL *z = (A68_BOOL *) item;
1698      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1699      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1700        plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR));
1701      } else if (IS (pat, BOOLEAN_PATTERN)) {
1702        if (NEXT_SUB (pat) == NO_NODE) {
1703          plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR));
1704        } else {
1705          write_boolean_pattern (pat, ref_file, (BOOL_T) (VALUE (z) == A68_TRUE));
1706        }
1707      } else {
1708        pattern_error (p, mode, ATTRIBUTE (pat));
1709      }
1710    } else if (mode == M_BITS) {
1711      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1712      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1713        char *str = (char *) STACK_TOP;
1714        genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
1715        add_string_transput_buffer (p, FORMATTED_BUFFER, str);
1716      } else if (IS (pat, BITS_PATTERN)) {
1717        write_bits_pattern (pat, M_BITS, item, ref_file);
1718      } else if (IS (pat, BITS_C_PATTERN)) {
1719        write_c_pattern (pat, M_BITS, item, ref_file);
1720      } else {
1721        pattern_error (p, mode, ATTRIBUTE (pat));
1722      }
1723    } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
1724      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1725      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1726        char *str = (char *) STACK_TOP;
1727        genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
1728        add_string_transput_buffer (p, FORMATTED_BUFFER, str);
1729      } else if (IS (pat, BITS_PATTERN)) {
1730        write_bits_pattern (pat, mode, item, ref_file);
1731      } else if (IS (pat, BITS_C_PATTERN)) {
1732        write_c_pattern (pat, mode, item, ref_file);
1733      } else {
1734        pattern_error (p, mode, ATTRIBUTE (pat));
1735      }
1736    } else if (mode == M_CHAR) {
1737      A68_CHAR *z = (A68_CHAR *) item;
1738      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1739      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1740        plusab_transput_buffer (p, FORMATTED_BUFFER, (char) VALUE (z));
1741      } else if (IS (pat, STRING_PATTERN)) {
1742        char *q = get_transput_buffer (EDIT_BUFFER);
1743        reset_transput_buffer (EDIT_BUFFER);
1744        plusab_transput_buffer (p, EDIT_BUFFER, (char) VALUE (z));
1745        write_string_pattern (pat, mode, ref_file, &q);
1746        if (q[0] != NULL_CHAR) {
1747          value_error (p, mode, ref_file);
1748        }
1749      } else if (IS (pat, STRING_C_PATTERN)) {
1750        char zz[2];
1751        zz[0] = VALUE (z);
1752        zz[1] = '\0';
1753        (void) c_to_a_string (pat, zz, 1);
1754        write_c_pattern (pat, mode, (BYTE_T *) zz, ref_file);
1755      } else {
1756        pattern_error (p, mode, ATTRIBUTE (pat));
1757      }
1758    } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1759  // Handle these separately instead of printing [] CHAR.
1760      A68_REF row = *(A68_REF *) item;
1761      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1762      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1763        PUSH_REF (p, row);
1764        add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1765      } else if (IS (pat, STRING_PATTERN)) {
1766        char *q;
1767        PUSH_REF (p, row);
1768        reset_transput_buffer (EDIT_BUFFER);
1769        add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
1770        q = get_transput_buffer (EDIT_BUFFER);
1771        write_string_pattern (pat, mode, ref_file, &q);
1772        if (q[0] != NULL_CHAR) {
1773          value_error (p, mode, ref_file);
1774        }
1775      } else if (IS (pat, STRING_C_PATTERN)) {
1776        char *q;
1777        PUSH_REF (p, row);
1778        reset_transput_buffer (EDIT_BUFFER);
1779        add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
1780        q = get_transput_buffer (EDIT_BUFFER);
1781        write_c_pattern (pat, mode, (BYTE_T *) q, ref_file);
1782      } else {
1783        pattern_error (p, mode, ATTRIBUTE (pat));
1784      }
1785    } else if (IS_UNION (mode)) {
1786      A68_UNION *z = (A68_UNION *) item;
1787      genie_write_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file, formats);
1788    } else if (IS_STRUCT (mode)) {
1789      PACK_T *q = PACK (mode);
1790      for (; q != NO_PACK; FORWARD (q)) {
1791        BYTE_T *elem = &item[OFFSET (q)];
1792        genie_check_initialisation (p, elem, MOID (q));
1793        genie_write_standard_format (p, MOID (q), elem, ref_file, formats);
1794      }
1795    } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1796      MOID_T *deflexed = DEFLEX (mode);
1797      A68_ARRAY *arr;
1798      A68_TUPLE *tup;
1799      CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
1800      GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1801      if (get_row_size (tup, DIM (arr)) > 0) {
1802        BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1803        BOOL_T done = A68_FALSE;
1804        initialise_internal_index (tup, DIM (arr));
1805        while (!done) {
1806          ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
1807          ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
1808          BYTE_T *elem = &base_addr[elem_addr];
1809          genie_check_initialisation (p, elem, SUB (deflexed));
1810          genie_write_standard_format (p, SUB (deflexed), elem, ref_file, formats);
1811          done = increment_internal_index (tup, DIM (arr));
1812        }
1813      }
1814    }
1815    if (errno != 0) {
1816      transput_error (p, ref_file, mode);
1817    }
1818  }
1819  
1820  //! @brief PROC ([] SIMPLOUT) VOID print f, write f
1821  
1822  void genie_write_format (NODE_T * p)
1823  {
1824    A68_REF row;
1825    POP_REF (p, &row);
1826    genie_stand_out (p);
1827    PUSH_REF (p, row);
1828    genie_write_file_format (p);
1829  }
1830  
1831  //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put f
1832  
1833  void genie_write_file_format (NODE_T * p)
1834  {
1835    A68_REF ref_file;
1836    A68_FILE *file;
1837    A68_REF row;
1838    A68_ARRAY *arr;
1839    A68_TUPLE *tup;
1840    BYTE_T *base_address;
1841    int elems, k, elem_index, formats;
1842    ADDR_T pop_fp, pop_sp;
1843    POP_REF (p, &row);
1844    CHECK_REF (p, row, M_ROW_SIMPLOUT);
1845    GET_DESCRIPTOR (arr, tup, &row);
1846    elems = ROW_SIZE (tup);
1847    POP_REF (p, &ref_file);
1848    CHECK_REF (p, ref_file, M_REF_FILE);
1849    file = FILE_DEREF (&ref_file);
1850    CHECK_INIT (p, INITIALISED (file), M_FILE);
1851    if (!OPENED (file)) {
1852      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1853      exit_genie (p, A68_RUNTIME_ERROR);
1854    }
1855    if (DRAW_MOOD (file)) {
1856      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1857      exit_genie (p, A68_RUNTIME_ERROR);
1858    }
1859    if (READ_MOOD (file)) {
1860      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1861      exit_genie (p, A68_RUNTIME_ERROR);
1862    }
1863    if (!PUT (&CHANNEL (file))) {
1864      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1865      exit_genie (p, A68_RUNTIME_ERROR);
1866    }
1867    if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1868      if (IS_NIL (STRING (file))) {
1869        if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILENO) {
1870          open_error (p, ref_file, "putting");
1871        }
1872      } else {
1873        FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, 0);
1874      }
1875      DRAW_MOOD (file) = A68_FALSE;
1876      READ_MOOD (file) = A68_FALSE;
1877      WRITE_MOOD (file) = A68_TRUE;
1878      CHAR_MOOD (file) = A68_TRUE;
1879    }
1880    if (!CHAR_MOOD (file)) {
1881      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
1882      exit_genie (p, A68_RUNTIME_ERROR);
1883    }
1884  // Save stack state since formats have frames.
1885    pop_fp = FRAME_POINTER (file);
1886    pop_sp = STACK_POINTER (file);
1887    FRAME_POINTER (file) = A68_FP;
1888    STACK_POINTER (file) = A68_SP;
1889  // Process [] SIMPLOUT.
1890    if (BODY (&FORMAT (file)) != NO_NODE) {
1891      open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
1892    }
1893    if (elems <= 0) {
1894      return;
1895    }
1896    formats = 0;
1897    base_address = DEREF (BYTE_T, &ARRAY (arr));
1898    elem_index = 0;
1899    for (k = 0; k < elems; k++) {
1900      A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
1901      MOID_T *mode = (MOID_T *) (VALUE (z));
1902      BYTE_T *item = &(base_address[elem_index + A68_UNION_SIZE]);
1903      genie_write_standard_format (p, mode, item, ref_file, &formats);
1904      elem_index += SIZE (M_SIMPLOUT);
1905    }
1906  // Empty the format to purge insertions.
1907    purge_format_write (p, ref_file);
1908    BODY (&FORMAT (file)) = NO_NODE;
1909  // Dump the buffer.
1910    write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
1911  // Forget about active formats.
1912    A68_FP = FRAME_POINTER (file);
1913    A68_SP = STACK_POINTER (file);
1914    FRAME_POINTER (file) = pop_fp;
1915    STACK_POINTER (file) = pop_sp;
1916  }
1917  
1918  //! @brief Give a value error in case a character is not among expected ones.
1919  
1920  BOOL_T expect (NODE_T * p, MOID_T * m, A68_REF ref_file, const char *items, char ch)
1921  {
1922    if (strchr ((char *) items, ch) == NO_TEXT) {
1923      value_error (p, m, ref_file);
1924      return A68_FALSE;
1925    } else {
1926      return A68_TRUE;
1927    }
1928  }
1929  
1930  //! @brief Read a group of insertions.
1931  
1932  void read_insertion (NODE_T * p, A68_REF ref_file)
1933  {
1934  
1935  // Algol68G does not check whether the insertions are textually there. It just
1936  //skips them. This because we blank literals in sign moulds before the sign is
1937  // put, which is non-standard Algol68, but convenient.
1938  
1939    A68_FILE *file = FILE_DEREF (&ref_file);
1940    for (; p != NO_NODE; FORWARD (p)) {
1941      read_insertion (SUB (p), ref_file);
1942      if (IS (p, FORMAT_ITEM_L)) {
1943        BOOL_T go_on = (BOOL_T) ! END_OF_FILE (file);
1944        while (go_on) {
1945          int ch = read_single_char (p, ref_file);
1946          go_on = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1947        }
1948      } else if (IS (p, FORMAT_ITEM_P)) {
1949        BOOL_T go_on = (BOOL_T) ! END_OF_FILE (file);
1950        while (go_on) {
1951          int ch = read_single_char (p, ref_file);
1952          go_on = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1953        }
1954      } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
1955        if (!END_OF_FILE (file)) {
1956          (void) read_single_char (p, ref_file);
1957        }
1958      } else if (IS (p, FORMAT_ITEM_Y)) {
1959        PUSH_REF (p, ref_file);
1960        PUSH_VALUE (p, -1, A68_INT);
1961        genie_set (p);
1962      } else if (IS (p, LITERAL)) {
1963  // Skip characters, but don't check the literal. 
1964        int len = (int) strlen (NSYMBOL (p));
1965        while (len-- && !END_OF_FILE (file)) {
1966          (void) read_single_char (p, ref_file);
1967        }
1968      } else if (IS (p, REPLICATOR)) {
1969        int j, k = get_replicator_value (SUB (p), A68_TRUE);
1970        if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
1971          for (j = 1; j <= k; j++) {
1972            read_insertion (NEXT (p), ref_file);
1973          }
1974        } else {
1975          int pos = get_transput_buffer_index (INPUT_BUFFER);
1976          for (j = 1; j < (k - pos); j++) {
1977            if (!END_OF_FILE (file)) {
1978              (void) read_single_char (p, ref_file);
1979            }
1980          }
1981        }
1982        return;                   // Don't delete this!
1983      }
1984    }
1985  }
1986  
1987  //! @brief Read string from file according current format.
1988  
1989  void read_string_pattern (NODE_T * p, MOID_T * m, A68_REF ref_file)
1990  {
1991    for (; p != NO_NODE; FORWARD (p)) {
1992      if (IS (p, INSERTION)) {
1993        read_insertion (SUB (p), ref_file);
1994      } else if (IS (p, FORMAT_ITEM_A)) {
1995        scan_n_chars (p, 1, m, ref_file);
1996      } else if (IS (p, FORMAT_ITEM_S)) {
1997        plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
1998        return;
1999      } else if (IS (p, REPLICATOR)) {
2000        int j, k = get_replicator_value (SUB (p), A68_TRUE);
2001        for (j = 1; j <= k; j++) {
2002          read_string_pattern (NEXT (p), m, ref_file);
2003        }
2004        return;
2005      } else {
2006        read_string_pattern (SUB (p), m, ref_file);
2007      }
2008    }
2009  }
2010  
2011  //! @brief Traverse choice pattern.
2012  
2013  void traverse_choice_pattern (NODE_T * p, char *str, int len, int *count, int *matches, int *first_match, BOOL_T * full_match)
2014  {
2015    for (; p != NO_NODE; FORWARD (p)) {
2016      traverse_choice_pattern (SUB (p), str, len, count, matches, first_match, full_match);
2017      if (IS (p, LITERAL)) {
2018        (*count)++;
2019        if (strncmp (NSYMBOL (p), str, (size_t) len) == 0) {
2020          (*matches)++;
2021          (*full_match) = (BOOL_T) ((*full_match) | (strcmp (NSYMBOL (p), str) == 0));
2022          if (*first_match == 0 && *full_match) {
2023            *first_match = *count;
2024          }
2025        }
2026      }
2027    }
2028  }
2029  
2030  //! @brief Read appropriate insertion from a choice pattern.
2031  
2032  int read_choice_pattern (NODE_T * p, A68_REF ref_file)
2033  {
2034  
2035  // This implementation does not have the RR peculiarity that longest
2036  // matching literal must be first, in case of non-unique first chars.
2037  
2038    A68_FILE *file = FILE_DEREF (&ref_file);
2039    BOOL_T cont = A68_TRUE;
2040    int longest_match = 0, longest_match_len = 0;
2041    while (cont) {
2042      int ch = char_scanner (file);
2043      if (!END_OF_FILE (file)) {
2044        int len, count = 0, matches = 0, first_match = 0;
2045        BOOL_T full_match = A68_FALSE;
2046        plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2047        len = get_transput_buffer_index (INPUT_BUFFER);
2048        traverse_choice_pattern (p, get_transput_buffer (INPUT_BUFFER), len, &count, &matches, &first_match, &full_match);
2049        if (full_match && matches == 1 && first_match > 0) {
2050          return first_match;
2051        } else if (full_match && matches > 1 && first_match > 0) {
2052          longest_match = first_match;
2053          longest_match_len = len;
2054        } else if (matches == 0) {
2055          cont = A68_FALSE;
2056        }
2057      } else {
2058        cont = A68_FALSE;
2059      }
2060    }
2061    if (longest_match > 0) {
2062  // Push back look-ahead chars.
2063      if (get_transput_buffer_index (INPUT_BUFFER) > 0) {
2064        char *z = get_transput_buffer (INPUT_BUFFER);
2065        END_OF_FILE (file) = A68_FALSE;
2066        add_string_transput_buffer (p, TRANSPUT_BUFFER (file), &z[longest_match_len]);
2067      }
2068      return longest_match;
2069    } else {
2070      value_error (p, M_INT, ref_file);
2071      return 0;
2072    }
2073  }
2074  
2075  //! @brief Read value according to a general-pattern.
2076  
2077  void read_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
2078  {
2079    A68_REF row;
2080    EXECUTE_UNIT (NEXT_SUB (p));
2081  // RR says to ignore parameters just calculated, so we will.
2082    POP_REF (p, &row);
2083    genie_read_standard (p, mode, item, ref_file);
2084  }
2085  
2086  // INTEGRAL, REAL, COMPLEX and BITS patterns.
2087  
2088  //! @brief Read sign-mould according current format.
2089  
2090  void read_sign_mould (NODE_T * p, MOID_T * m, A68_REF ref_file, int *sign)
2091  {
2092    for (; p != NO_NODE; FORWARD (p)) {
2093      if (IS (p, INSERTION)) {
2094        read_insertion (SUB (p), ref_file);
2095      } else if (IS (p, REPLICATOR)) {
2096        int j, k = get_replicator_value (SUB (p), A68_TRUE);
2097        for (j = 1; j <= k; j++) {
2098          read_sign_mould (NEXT (p), m, ref_file, sign);
2099        }
2100        return;                   // Leave this!
2101      } else {
2102        switch (ATTRIBUTE (p)) {
2103        case FORMAT_ITEM_Z:
2104        case FORMAT_ITEM_D:
2105        case FORMAT_ITEM_S:
2106        case FORMAT_ITEM_PLUS:
2107        case FORMAT_ITEM_MINUS:
2108          {
2109            int ch = read_single_char (p, ref_file);
2110  // When a sign has been read, digits are expected.
2111            if (*sign != 0) {
2112              if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
2113                plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2114              } else {
2115                plusab_transput_buffer (p, INPUT_BUFFER, '0');
2116              }
2117  // When a sign has not been read, a sign is expected.  If there is a digit
2118  // in stead of a sign, the digit is accepted and '+' is assumed; RR demands a
2119  // space to preceed the digit, Algol68G does not.
2120            } else {
2121              if (strchr (SIGN_DIGITS, ch) != NO_TEXT) {
2122                if (ch == '+') {
2123                  *sign = 1;
2124                } else if (ch == '-') {
2125                  *sign = -1;
2126                } else if (ch == BLANK_CHAR) {
2127                  ;
2128                }
2129              } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
2130                plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2131                *sign = 1;
2132              }
2133            }
2134            break;
2135          }
2136        default:
2137          {
2138            read_sign_mould (SUB (p), m, ref_file, sign);
2139            break;
2140          }
2141        }
2142      }
2143    }
2144  }
2145  
2146  //! @brief Read mould according current format.
2147  
2148  void read_integral_mould (NODE_T * p, MOID_T * m, A68_REF ref_file)
2149  {
2150    for (; p != NO_NODE; FORWARD (p)) {
2151      if (IS (p, INSERTION)) {
2152        read_insertion (SUB (p), ref_file);
2153      } else if (IS (p, REPLICATOR)) {
2154        int j, k = get_replicator_value (SUB (p), A68_TRUE);
2155        for (j = 1; j <= k; j++) {
2156          read_integral_mould (NEXT (p), m, ref_file);
2157        }
2158        return;                   // Leave this!
2159      } else if (IS (p, FORMAT_ITEM_Z)) {
2160        int ch = read_single_char (p, ref_file);
2161        const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK;
2162        if (expect (p, m, ref_file, digits, (char) ch)) {
2163          plusab_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch));
2164        } else {
2165          plusab_transput_buffer (p, INPUT_BUFFER, '0');
2166        }
2167      } else if (IS (p, FORMAT_ITEM_D)) {
2168        int ch = read_single_char (p, ref_file);
2169        const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS : INT_DIGITS;
2170        if (expect (p, m, ref_file, digits, (char) ch)) {
2171          plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2172        } else {
2173          plusab_transput_buffer (p, INPUT_BUFFER, '0');
2174        }
2175      } else if (IS (p, FORMAT_ITEM_S)) {
2176        plusab_transput_buffer (p, INPUT_BUFFER, '0');
2177      } else {
2178        read_integral_mould (SUB (p), m, ref_file);
2179      }
2180    }
2181  }
2182  
2183  //! @brief Read mould according current format.
2184  
2185  void read_integral_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
2186  {
2187    NODE_T *q = SUB (p);
2188    if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2189      int sign = 0;
2190      char *z;
2191      plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2192      read_sign_mould (SUB (q), m, ref_file, &sign);
2193      z = get_transput_buffer (INPUT_BUFFER);
2194      z[0] = (char) ((sign == -1) ? '-' : '+');
2195      FORWARD (q);
2196    }
2197    if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2198      read_integral_mould (SUB (q), m, ref_file);
2199    }
2200    genie_string_to_value (p, m, item, ref_file);
2201  }
2202  
2203  //! @brief Read point, exponent or i-frame.
2204  
2205  void read_pie_frame (NODE_T * p, MOID_T * m, A68_REF ref_file, int att, int item, char ch)
2206  {
2207  // Widen ch to a stringlet.
2208    char sym[3];
2209    sym[0] = ch;
2210    sym[1] = (char) TO_LOWER (ch);
2211    sym[2] = NULL_CHAR;
2212  // Now read the frame.
2213    for (; p != NO_NODE; FORWARD (p)) {
2214      if (IS (p, INSERTION)) {
2215        read_insertion (p, ref_file);
2216      } else if (IS (p, att)) {
2217        read_pie_frame (SUB (p), m, ref_file, att, item, ch);
2218        return;
2219      } else if (IS (p, FORMAT_ITEM_S)) {
2220        plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2221        return;
2222      } else if (IS (p, item)) {
2223        int ch0 = read_single_char (p, ref_file);
2224        if (expect (p, m, ref_file, sym, (char) ch0)) {
2225          plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2226        } else {
2227          plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2228        }
2229      }
2230    }
2231  }
2232  
2233  //! @brief Read REAL value using real pattern.
2234  
2235  void read_real_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
2236  {
2237  // Dive into pattern.
2238    NODE_T *q = (IS (p, REAL_PATTERN)) ? SUB (p) : p;
2239  // Dissect pattern.
2240    if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2241      int sign = 0;
2242      char *z;
2243      plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2244      read_sign_mould (SUB (q), m, ref_file, &sign);
2245      z = get_transput_buffer (INPUT_BUFFER);
2246      z[0] = (char) ((sign == -1) ? '-' : '+');
2247      FORWARD (q);
2248    }
2249    if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2250      read_integral_mould (SUB (q), m, ref_file);
2251      FORWARD (q);
2252    }
2253    if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
2254      read_pie_frame (SUB (q), m, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, POINT_CHAR);
2255      FORWARD (q);
2256    }
2257    if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2258      read_integral_mould (SUB (q), m, ref_file);
2259      FORWARD (q);
2260    }
2261    if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
2262      read_pie_frame (SUB (q), m, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E, EXPONENT_CHAR);
2263      q = NEXT_SUB (q);
2264      if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2265        int k, sign = 0;
2266        char *z;
2267        plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2268        k = get_transput_buffer_index (INPUT_BUFFER);
2269        read_sign_mould (SUB (q), m, ref_file, &sign);
2270        z = get_transput_buffer (INPUT_BUFFER);
2271        z[k - 1] = (char) ((sign == -1) ? '-' : '+');
2272        FORWARD (q);
2273      }
2274      if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2275        read_integral_mould (SUB (q), m, ref_file);
2276        FORWARD (q);
2277      }
2278    }
2279    genie_string_to_value (p, m, item, ref_file);
2280  }
2281  
2282  //! @brief Read COMPLEX value using complex pattern.
2283  
2284  void read_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * m, BYTE_T * re, BYTE_T * im, A68_REF ref_file)
2285  {
2286    NODE_T *reel, *plus_i_times, *imag;
2287  // Dissect pattern.
2288    reel = SUB (p);
2289    plus_i_times = NEXT (reel);
2290    imag = NEXT (plus_i_times);
2291  // Read pattern.
2292    read_real_pattern (reel, m, re, ref_file);
2293    reset_transput_buffer (INPUT_BUFFER);
2294    read_pie_frame (plus_i_times, comp, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I, 'I');
2295    reset_transput_buffer (INPUT_BUFFER);
2296    read_real_pattern (imag, m, im, ref_file);
2297  }
2298  
2299  //! @brief Read BITS value according pattern.
2300  
2301  void read_bits_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
2302  {
2303    int radix;
2304    char *z;
2305    radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
2306    if (radix < 2 || radix > 16) {
2307      diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
2308      exit_genie (p, A68_RUNTIME_ERROR);
2309    }
2310    z = get_transput_buffer (INPUT_BUFFER);
2311    ASSERT (snprintf (z, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
2312    set_transput_buffer_index (INPUT_BUFFER, (int) strlen (z));
2313    read_integral_mould (NEXT_SUB (p), m, ref_file);
2314    genie_string_to_value (p, m, item, ref_file);
2315  }
2316  
2317  //! @brief Read object with from file and store.
2318  
2319  void genie_read_real_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
2320  {
2321    if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
2322      genie_read_standard (p, mode, item, ref_file);
2323    } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
2324      read_number_generic (p, mode, item, ref_file);
2325    } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
2326      read_c_pattern (p, mode, item, ref_file);
2327    } else if (IS (p, REAL_PATTERN)) {
2328      read_real_pattern (p, mode, item, ref_file);
2329    } else {
2330      pattern_error (p, mode, ATTRIBUTE (p));
2331    }
2332  }
2333  
2334  //! @brief At end of read purge all insertions.
2335  
2336  void purge_format_read (NODE_T * p, A68_REF ref_file)
2337  {
2338    BOOL_T go_on;
2339    do {
2340      A68_FILE *file;
2341      NODE_T *dollar, *pat;
2342      A68_FORMAT *old_fmt;
2343      while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
2344        format_error (p, ref_file, ERROR_FORMAT_PICTURES);
2345      }
2346      file = FILE_DEREF (&ref_file);
2347      dollar = SUB (BODY (&FORMAT (file)));
2348      old_fmt = (A68_FORMAT *) FRAME_LOCAL (A68_FP, OFFSET (TAX (dollar)));
2349      go_on = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
2350      if (go_on) {
2351  // Pop embedded format and proceed.
2352        (void) end_of_format (p, ref_file);
2353      }
2354    } while (go_on);
2355  }
2356  
2357  //! @brief Read object with from file and store.
2358  
2359  void genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file, int *formats)
2360  {
2361    errno = 0;
2362    reset_transput_buffer (INPUT_BUFFER);
2363    if (mode == M_FORMAT) {
2364      A68_FILE *file;
2365      CHECK_REF (p, ref_file, M_REF_FILE);
2366      file = FILE_DEREF (&ref_file);
2367  // Forget about eventual active formats and set up new one.
2368      if (*formats > 0) {
2369        purge_format_read (p, ref_file);
2370      }
2371      (*formats)++;
2372      A68_FP = FRAME_POINTER (file);
2373      A68_SP = STACK_POINTER (file);
2374      open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE);
2375    } else if (mode == M_PROC_REF_FILE_VOID) {
2376      diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
2377      exit_genie (p, A68_RUNTIME_ERROR);
2378    } else if (mode == M_REF_SOUND) {
2379      diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_REF_SOUND);
2380      exit_genie (p, A68_RUNTIME_ERROR);
2381    } else if (IS_REF (mode)) {
2382      CHECK_REF (p, *(A68_REF *) item, mode);
2383      genie_read_standard_format (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file, formats);
2384    } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2385      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2386      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2387        genie_read_standard (pat, mode, item, ref_file);
2388      } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
2389        read_number_generic (pat, mode, item, ref_file);
2390      } else if (IS (pat, INTEGRAL_C_PATTERN)) {
2391        read_c_pattern (pat, mode, item, ref_file);
2392      } else if (IS (pat, INTEGRAL_PATTERN)) {
2393        read_integral_pattern (pat, mode, item, ref_file);
2394      } else if (IS (pat, CHOICE_PATTERN)) {
2395        int k = read_choice_pattern (pat, ref_file);
2396        if (mode == M_INT) {
2397          A68_INT *z = (A68_INT *) item;
2398          VALUE (z) = k;
2399          STATUS (z) = (STATUS_MASK_T) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK);
2400        } else {
2401          diagnostic (A68_RUNTIME_ERROR, p, ERROR_DEPRECATED, mode);
2402          exit_genie (p, A68_RUNTIME_ERROR);
2403        }
2404      } else {
2405        pattern_error (p, mode, ATTRIBUTE (pat));
2406      }
2407    } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2408      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2409      genie_read_real_format (pat, mode, item, ref_file);
2410    } else if (mode == M_COMPLEX) {
2411      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2412      if (IS (pat, COMPLEX_PATTERN)) {
2413        read_complex_pattern (pat, mode, M_REAL, item, &item[SIZE (M_REAL)], ref_file);
2414      } else {
2415  // Try reading as two REAL values.
2416        genie_read_real_format (pat, M_REAL, item, ref_file);
2417        genie_read_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
2418      }
2419    } else if (mode == M_LONG_COMPLEX) {
2420      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2421      if (IS (pat, COMPLEX_PATTERN)) {
2422        read_complex_pattern (pat, mode, M_LONG_REAL, item, &item[SIZE (M_LONG_REAL)], ref_file);
2423      } else {
2424  // Try reading as two LONG REAL values.
2425        genie_read_real_format (pat, M_LONG_REAL, item, ref_file);
2426        genie_read_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
2427      }
2428    } else if (mode == M_LONG_LONG_COMPLEX) {
2429      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2430      if (IS (pat, COMPLEX_PATTERN)) {
2431        read_complex_pattern (pat, mode, M_LONG_LONG_REAL, item, &item[SIZE (M_LONG_LONG_REAL)], ref_file);
2432      } else {
2433  // Try reading as two LONG LONG REAL values.
2434        genie_read_real_format (pat, M_LONG_LONG_REAL, item, ref_file);
2435        genie_read_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
2436      }
2437    } else if (mode == M_BOOL) {
2438      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2439      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2440        genie_read_standard (p, mode, item, ref_file);
2441      } else if (IS (pat, BOOLEAN_PATTERN)) {
2442        if (NEXT_SUB (pat) == NO_NODE) {
2443          genie_read_standard (p, mode, item, ref_file);
2444        } else {
2445          A68_BOOL *z = (A68_BOOL *) item;
2446          int k = read_choice_pattern (pat, ref_file);
2447          if (k == 1 || k == 2) {
2448            VALUE (z) = (BOOL_T) ((k == 1) ? A68_TRUE : A68_FALSE);
2449            STATUS (z) = INIT_MASK;
2450          } else {
2451            STATUS (z) = NULL_MASK;
2452          }
2453        }
2454      } else {
2455        pattern_error (p, mode, ATTRIBUTE (pat));
2456      }
2457    } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
2458      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2459      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2460        genie_read_standard (p, mode, item, ref_file);
2461      } else if (IS (pat, BITS_PATTERN)) {
2462        read_bits_pattern (pat, mode, item, ref_file);
2463      } else if (IS (pat, BITS_C_PATTERN)) {
2464        read_c_pattern (pat, mode, item, ref_file);
2465      } else {
2466        pattern_error (p, mode, ATTRIBUTE (pat));
2467      }
2468    } else if (mode == M_CHAR) {
2469      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2470      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2471        genie_read_standard (p, mode, item, ref_file);
2472      } else if (IS (pat, STRING_PATTERN)) {
2473        read_string_pattern (pat, M_CHAR, ref_file);
2474        genie_string_to_value (p, mode, item, ref_file);
2475      } else if (IS (pat, CHAR_C_PATTERN)) {
2476        read_c_pattern (pat, mode, item, ref_file);
2477      } else {
2478        pattern_error (p, mode, ATTRIBUTE (pat));
2479      }
2480    } else if (mode == M_ROW_CHAR || mode == M_STRING) {
2481  // Handle these separately instead of reading [] CHAR.
2482      NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2483      if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2484        genie_read_standard (p, mode, item, ref_file);
2485      } else if (IS (pat, STRING_PATTERN)) {
2486        read_string_pattern (pat, mode, ref_file);
2487        genie_string_to_value (p, mode, item, ref_file);
2488      } else if (IS (pat, STRING_C_PATTERN)) {
2489        read_c_pattern (pat, mode, item, ref_file);
2490      } else {
2491        pattern_error (p, mode, ATTRIBUTE (pat));
2492      }
2493    } else if (IS_UNION (mode)) {
2494      A68_UNION *z = (A68_UNION *) item;
2495      genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file, formats);
2496    } else if (IS_STRUCT (mode)) {
2497      PACK_T *q = PACK (mode);
2498      for (; q != NO_PACK; FORWARD (q)) {
2499        BYTE_T *elem = &item[OFFSET (q)];
2500        genie_read_standard_format (p, MOID (q), elem, ref_file, formats);
2501      }
2502    } else if (IS_ROW (mode) || IS_FLEX (mode)) {
2503      MOID_T *deflexed = DEFLEX (mode);
2504      A68_ARRAY *arr;
2505      A68_TUPLE *tup;
2506      CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
2507      GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
2508      if (get_row_size (tup, DIM (arr)) > 0) {
2509        BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
2510        BOOL_T done = A68_FALSE;
2511        initialise_internal_index (tup, DIM (arr));
2512        while (!done) {
2513          ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
2514          ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
2515          BYTE_T *elem = &base_addr[elem_addr];
2516          genie_read_standard_format (p, SUB (deflexed), elem, ref_file, formats);
2517          done = increment_internal_index (tup, DIM (arr));
2518        }
2519      }
2520    }
2521    if (errno != 0) {
2522      transput_error (p, ref_file, mode);
2523    }
2524  }
2525  
2526  //! @brief PROC ([] SIMPLIN) VOID read f
2527  
2528  void genie_read_format (NODE_T * p)
2529  {
2530    A68_REF row;
2531    POP_REF (p, &row);
2532    genie_stand_in (p);
2533    PUSH_REF (p, row);
2534    genie_read_file_format (p);
2535  }
2536  
2537  //! @brief PROC (REF FILE, [] SIMPLIN) VOID get f
2538  
2539  void genie_read_file_format (NODE_T * p)
2540  {
2541    A68_REF ref_file;
2542    A68_FILE *file;
2543    A68_REF row;
2544    A68_ARRAY *arr;
2545    A68_TUPLE *tup;
2546    BYTE_T *base_address;
2547    int elems, k, elem_index, formats;
2548    ADDR_T pop_fp, pop_sp;
2549    POP_REF (p, &row);
2550    CHECK_REF (p, row, M_ROW_SIMPLIN);
2551    GET_DESCRIPTOR (arr, tup, &row);
2552    elems = ROW_SIZE (tup);
2553    POP_REF (p, &ref_file);
2554    CHECK_REF (p, ref_file, M_REF_FILE);
2555    file = FILE_DEREF (&ref_file);
2556    CHECK_INIT (p, INITIALISED (file), M_FILE);
2557    if (!OPENED (file)) {
2558      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
2559      exit_genie (p, A68_RUNTIME_ERROR);
2560    }
2561    if (DRAW_MOOD (file)) {
2562      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
2563      exit_genie (p, A68_RUNTIME_ERROR);
2564    }
2565    if (WRITE_MOOD (file)) {
2566      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
2567      exit_genie (p, A68_RUNTIME_ERROR);
2568    }
2569    if (!GET (&CHANNEL (file))) {
2570      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
2571      exit_genie (p, A68_RUNTIME_ERROR);
2572    }
2573    if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
2574      if (IS_NIL (STRING (file))) {
2575        if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILENO) {
2576          open_error (p, ref_file, "getting");
2577        }
2578      } else {
2579        FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0);
2580      }
2581      DRAW_MOOD (file) = A68_FALSE;
2582      READ_MOOD (file) = A68_TRUE;
2583      WRITE_MOOD (file) = A68_FALSE;
2584      CHAR_MOOD (file) = A68_TRUE;
2585    }
2586    if (!CHAR_MOOD (file)) {
2587      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
2588      exit_genie (p, A68_RUNTIME_ERROR);
2589    }
2590  // Save stack state since formats have frames.
2591    pop_fp = FRAME_POINTER (file);
2592    pop_sp = STACK_POINTER (file);
2593    FRAME_POINTER (file) = A68_FP;
2594    STACK_POINTER (file) = A68_SP;
2595  // Process [] SIMPLIN.
2596    if (BODY (&FORMAT (file)) != NO_NODE) {
2597      open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
2598    }
2599    if (elems <= 0) {
2600      return;
2601    }
2602    formats = 0;
2603    base_address = DEREF (BYTE_T, &ARRAY (arr));
2604    elem_index = 0;
2605    for (k = 0; k < elems; k++) {
2606      A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
2607      MOID_T *mode = (MOID_T *) (VALUE (z));
2608      BYTE_T *item = (BYTE_T *) & (base_address[elem_index + A68_UNION_SIZE]);
2609      genie_read_standard_format (p, mode, item, ref_file, &formats);
2610      elem_index += SIZE (M_SIMPLIN);
2611    }
2612  // Empty the format to purge insertions.
2613    purge_format_read (p, ref_file);
2614    BODY (&FORMAT (file)) = NO_NODE;
2615  // Forget about active formats.
2616    A68_FP = FRAME_POINTER (file);
2617    A68_SP = STACK_POINTER (file);
2618    FRAME_POINTER (file) = pop_fp;
2619    STACK_POINTER (file) = pop_sp;
2620  }