rts-unformatted.c

     
   1  //! @file rts-unformatted.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  //! Unformatted transput.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-prelude.h"
  29  #include "a68g-mp.h"
  30  #include "a68g-double.h"
  31  #include "a68g-transput.h"
  32  
  33  //! @brief Skip new-lines and form-feeds.
  34  
  35  void skip_nl_ff (NODE_T * p, int *ch, A68_REF ref_file)
  36  {
  37    A68_FILE *f = FILE_DEREF (&ref_file);
  38    while ((*ch) != EOF_CHAR && IS_NL_FF (*ch)) {
  39      A68_BOOL *z = (A68_BOOL *) STACK_TOP;
  40      ADDR_T pop_sp = A68_SP;
  41      unchar_scanner (p, f, (char) (*ch));
  42      if (*ch == NEWLINE_CHAR) {
  43        on_event_handler (p, LINE_END_MENDED (f), ref_file);
  44        A68_SP = pop_sp;
  45        if (VALUE (z) == A68_FALSE) {
  46          PUSH_REF (p, ref_file);
  47          genie_new_line (p);
  48        }
  49      } else if (*ch == FORMFEED_CHAR) {
  50        on_event_handler (p, PAGE_END_MENDED (f), ref_file);
  51        A68_SP = pop_sp;
  52        if (VALUE (z) == A68_FALSE) {
  53          PUSH_REF (p, ref_file);
  54          genie_new_page (p);
  55        }
  56      }
  57      (*ch) = char_scanner (f);
  58    }
  59  }
  60  
  61  //! @brief Scan an int from file.
  62  
  63  void scan_integer (NODE_T * p, A68_REF ref_file)
  64  {
  65    A68_FILE *f = FILE_DEREF (&ref_file);
  66    reset_transput_buffer (INPUT_BUFFER);
  67    int ch = char_scanner (f);
  68    while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
  69      if (IS_NL_FF (ch)) {
  70        skip_nl_ff (p, &ch, ref_file);
  71      } else {
  72        ch = char_scanner (f);
  73      }
  74    }
  75    if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
  76      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
  77      ch = char_scanner (f);
  78    }
  79    while (ch != EOF_CHAR && IS_DIGIT (ch)) {
  80      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
  81      ch = char_scanner (f);
  82    }
  83    if (ch != EOF_CHAR) {
  84      unchar_scanner (p, f, (char) ch);
  85    }
  86  }
  87  
  88  //! @brief Scan a real from file.
  89  
  90  void scan_real (NODE_T * p, A68_REF ref_file)
  91  {
  92    A68_FILE *f = FILE_DEREF (&ref_file);
  93    char x_e = EXPONENT_CHAR;
  94    reset_transput_buffer (INPUT_BUFFER);
  95    int ch = char_scanner (f);
  96    while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
  97      if (IS_NL_FF (ch)) {
  98        skip_nl_ff (p, &ch, ref_file);
  99      } else {
 100        ch = char_scanner (f);
 101      }
 102    }
 103    if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
 104      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 105      ch = char_scanner (f);
 106    }
 107    while (ch != EOF_CHAR && IS_DIGIT (ch)) {
 108      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 109      ch = char_scanner (f);
 110    }
 111    if (ch == EOF_CHAR || !(ch == POINT_CHAR || TO_UPPER (ch) == TO_UPPER (x_e))) {
 112      goto salida;
 113    }
 114    if (ch == POINT_CHAR) {
 115      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 116      ch = char_scanner (f);
 117      while (ch != EOF_CHAR && IS_DIGIT (ch)) {
 118        plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 119        ch = char_scanner (f);
 120      }
 121    }
 122    if (ch == EOF_CHAR || TO_UPPER (ch) != TO_UPPER (x_e)) {
 123      goto salida;
 124    }
 125    if (TO_UPPER (ch) == TO_UPPER (x_e)) {
 126      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 127      ch = char_scanner (f);
 128      while (ch != EOF_CHAR && ch == BLANK_CHAR) {
 129        ch = char_scanner (f);
 130      }
 131      if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
 132        plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 133        ch = char_scanner (f);
 134      }
 135      while (ch != EOF_CHAR && IS_DIGIT (ch)) {
 136        plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 137        ch = char_scanner (f);
 138      }
 139    }
 140  salida:if (ch != EOF_CHAR) {
 141      unchar_scanner (p, f, (char) ch);
 142    }
 143  }
 144  
 145  //! @brief Scan a bits from file.
 146  
 147  void scan_bits (NODE_T * p, A68_REF ref_file)
 148  {
 149    A68_FILE *f = FILE_DEREF (&ref_file);
 150    reset_transput_buffer (INPUT_BUFFER);
 151    int ch = char_scanner (f);
 152    while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
 153      if (IS_NL_FF (ch)) {
 154        skip_nl_ff (p, &ch, ref_file);
 155      } else {
 156        ch = char_scanner (f);
 157      }
 158    }
 159    while (ch != EOF_CHAR && (ch == FLIP_CHAR || ch == FLOP_CHAR)) {
 160      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 161      ch = char_scanner (f);
 162    }
 163    if (ch != EOF_CHAR) {
 164      unchar_scanner (p, f, (char) ch);
 165    }
 166  }
 167  
 168  //! @brief Scan a char from file.
 169  
 170  void scan_char (NODE_T * p, A68_REF ref_file)
 171  {
 172    A68_FILE *f = FILE_DEREF (&ref_file);
 173    reset_transput_buffer (INPUT_BUFFER);
 174    int ch = char_scanner (f);
 175    skip_nl_ff (p, &ch, ref_file);
 176    if (ch != EOF_CHAR) {
 177      plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 178    }
 179  }
 180  
 181  //! @brief Scan a string from file.
 182  
 183  void scan_string (NODE_T * p, char *term, A68_REF ref_file)
 184  {
 185    A68_FILE *f = FILE_DEREF (&ref_file);
 186    if (END_OF_FILE (f)) {
 187      reset_transput_buffer (INPUT_BUFFER);
 188      end_of_file_error (p, ref_file);
 189    } else {
 190      reset_transput_buffer (INPUT_BUFFER);
 191      int ch = char_scanner (f);
 192      BOOL_T go_on = A68_TRUE;
 193      while (go_on) {
 194        if (ch == EOF_CHAR || END_OF_FILE (f)) {
 195          if (get_transput_buffer_index (INPUT_BUFFER) == 0) {
 196            end_of_file_error (p, ref_file);
 197          }
 198          go_on = A68_FALSE;
 199        } else if (IS_NL_FF (ch)) {
 200          ADDR_T pop_sp = A68_SP;
 201          unchar_scanner (p, f, (char) ch);
 202          if (ch == NEWLINE_CHAR) {
 203            on_event_handler (p, LINE_END_MENDED (f), ref_file);
 204          } else if (ch == FORMFEED_CHAR) {
 205            on_event_handler (p, PAGE_END_MENDED (f), ref_file);
 206          }
 207          A68_SP = pop_sp;
 208          go_on = A68_FALSE;
 209        } else if (term != NO_TEXT && strchr (term, ch) != NO_TEXT) {
 210          go_on = A68_FALSE;
 211          unchar_scanner (p, f, (char) ch);
 212        } else {
 213          plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
 214          ch = char_scanner (f);
 215        }
 216      }
 217    }
 218  }
 219  
 220  //! @brief Make temp file name.
 221  
 222  BOOL_T a68_mkstemp (char *fn, int flags, mode_t permissions)
 223  {
 224  // "tmpnam" is not safe, "mkstemp" is Unix, so a68g brings its own tmpnam.
 225  #define TMP_SIZE 32
 226  #define TRIALS 32
 227    BUFFER tfilename;
 228    char *letters = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
 229    int len = (int) strlen (letters);
 230    BOOL_T good_file = A68_FALSE;
 231  // Next are prefixes to try.
 232  // First we try /tmp, and if that won't go, the current dir.
 233    char *prefix[] = { "/tmp/a68_", "./a68_", NO_TEXT };
 234    for (int i = 0; prefix[i] != NO_TEXT; i++) {
 235      for (int k = 0; k < TRIALS && good_file == A68_FALSE; k++) {
 236        bufcpy (tfilename, prefix[i], BUFFER_SIZE);
 237        for (int j = 0; j < TMP_SIZE; j++) {
 238          int cindex;
 239          do {
 240            cindex = (int) (a68_unif_rand () * len);
 241          } while (cindex < 0 || cindex >= len);
 242          char chars[2];
 243          chars[0] = letters[cindex];
 244          chars[1] = NULL_CHAR;
 245          bufcat (tfilename, chars, BUFFER_SIZE);
 246        }
 247        bufcat (tfilename, ".tmp", BUFFER_SIZE);
 248        errno = 0;
 249        FILE_T fd = open (tfilename, flags | O_EXCL, permissions);
 250        good_file = (BOOL_T) (fd != A68_NO_FILENO && errno == 0);
 251        if (good_file) {
 252          (void) close (fd);
 253        }
 254      }
 255    }
 256    if (good_file) {
 257      bufcpy (fn, tfilename, BUFFER_SIZE);
 258      return A68_TRUE;
 259    } else {
 260      return A68_FALSE;
 261    }
 262  #undef TMP_SIZE
 263  #undef TRIALS
 264  }
 265  
 266  //! @brief Open a file, or establish it.
 267  
 268  FILE_T open_physical_file (NODE_T * p, A68_REF ref_file, int flags, mode_t permissions)
 269  {
 270    BOOL_T reading = (flags & ~O_BINARY) == A68_READ_ACCESS;
 271    BOOL_T writing = (flags & ~O_BINARY) == A68_WRITE_ACCESS;
 272    ABEND (reading == writing, ERROR_INTERNAL_CONSISTENCY, __func__);
 273    CHECK_REF (p, ref_file, M_REF_FILE);
 274    A68_FILE *file = FILE_DEREF (&ref_file);
 275    CHECK_INIT (p, INITIALISED (file), M_FILE);
 276    if (!IS_NIL (STRING (file))) {
 277      if (writing) {
 278        A68_REF z = *DEREF (A68_REF, &STRING (file));
 279        A68_ARRAY *a;
 280        A68_TUPLE *t;
 281        GET_DESCRIPTOR (a, t, &z);
 282        UPB (t) = LWB (t) - 1;
 283      }
 284  // Associated file.
 285      TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
 286      reset_transput_buffer (TRANSPUT_BUFFER (file));
 287      END_OF_FILE (file) = A68_FALSE;
 288      FILE_ENTRY (file) = -1;
 289      return FD (file);
 290    } else if (IS_NIL (IDENTIFICATION (file))) {
 291  // No identification, so generate a unique identification..
 292      if (reading) {
 293        return A68_NO_FILENO;
 294      } else {
 295        BUFFER tfilename;
 296        int len;
 297        if (!a68_mkstemp (tfilename, flags, permissions)) {
 298          diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NO_TEMP);
 299          exit_genie (p, A68_RUNTIME_ERROR);
 300        }
 301        FD (file) = open (tfilename, flags, permissions);
 302        len = 1 + (int) strlen (tfilename);
 303        IDENTIFICATION (file) = heap_generator (p, M_C_STRING, len);
 304        BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
 305        bufcpy (DEREF (char, &IDENTIFICATION (file)), tfilename, len);
 306        TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
 307        reset_transput_buffer (TRANSPUT_BUFFER (file));
 308        END_OF_FILE (file) = A68_FALSE;
 309        TMP_FILE (file) = A68_TRUE;
 310        FILE_ENTRY (file) = store_file_entry (p, FD (file), tfilename, TMP_FILE (file));
 311        return FD (file);
 312      }
 313    } else {
 314  // Opening an identified file.
 315      A68_REF ref_filename = IDENTIFICATION (file);
 316      CHECK_REF (p, ref_filename, M_ROWS);
 317      char *filename = DEREF (char, &ref_filename);
 318      if (OPEN_EXCLUSIVE (file)) {
 319  // Establishing requires that the file does not exist.
 320        if (flags == (A68_WRITE_ACCESS)) {
 321          flags |= O_EXCL;
 322        }
 323        OPEN_EXCLUSIVE (file) = A68_FALSE;
 324      }
 325      FD (file) = open (filename, flags, permissions);
 326      TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
 327      reset_transput_buffer (TRANSPUT_BUFFER (file));
 328      END_OF_FILE (file) = A68_FALSE;
 329      FILE_ENTRY (file) = store_file_entry (p, FD (file), filename, TMP_FILE (file));
 330      return FD (file);
 331    }
 332  }
 333  
 334  //! @brief Call PROC (REF FILE) VOID during transput.
 335  
 336  void genie_call_proc_ref_file_void (NODE_T * p, A68_REF ref_file, A68_PROCEDURE z)
 337  {
 338    ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
 339    MOID_T *u = M_PROC_REF_FILE_VOID;
 340    PUSH_REF (p, ref_file);
 341    genie_call_procedure (p, MOID (&z), u, u, &z, pop_sp, pop_fp);
 342    A68_SP = pop_sp;              // Voiding
 343  }
 344  
 345  // Unformatted transput.
 346  
 347  //! @brief Hexadecimal value of digit.
 348  
 349  int char_value (int ch)
 350  {
 351    switch (ch) {
 352    case '0':
 353      {
 354        return 0;
 355      }
 356    case '1':
 357      {
 358        return 1;
 359      }
 360    case '2':
 361      {
 362        return 2;
 363      }
 364    case '3':
 365      {
 366        return 3;
 367      }
 368    case '4':
 369      {
 370        return 4;
 371      }
 372    case '5':
 373      {
 374        return 5;
 375      }
 376    case '6':
 377      {
 378        return 6;
 379      }
 380    case '7':
 381      {
 382        return 7;
 383      }
 384    case '8':
 385      {
 386        return 8;
 387      }
 388    case '9':
 389      {
 390        return 9;
 391      }
 392    case 'A':
 393    case 'a':
 394      {
 395        return 10;
 396      }
 397    case 'B':
 398    case 'b':
 399      {
 400        return 11;
 401      }
 402    case 'C':
 403    case 'c':
 404      {
 405        return 12;
 406      }
 407    case 'D':
 408    case 'd':
 409      {
 410        return 13;
 411      }
 412    case 'E':
 413    case 'e':
 414      {
 415        return 14;
 416      }
 417    case 'F':
 418    case 'f':
 419      {
 420        return 15;
 421      }
 422    default:
 423      {
 424        return -1;
 425      }
 426    }
 427  }
 428  
 429  //! @brief INT value of BITS denotation
 430  
 431  UNSIGNED_T bits_to_int (NODE_T * p, char *str)
 432  {
 433    errno = 0;
 434    char *radix = NO_TEXT, *end = NO_TEXT;
 435    int base = (int) a68_strtou (str, &radix, 10);
 436    if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) {
 437      UNSIGNED_T bits = 0;
 438      if (base < 2 || base > 16) {
 439        diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base);
 440        exit_genie (p, A68_RUNTIME_ERROR);
 441      }
 442      bits = a68_strtou (&(radix[1]), &end, base);
 443      if (end != NO_TEXT && end[0] == NULL_CHAR && errno == 0) {
 444        return bits;
 445      }
 446    }
 447    diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_BITS);
 448    exit_genie (p, A68_RUNTIME_ERROR);
 449    return 0;
 450  }
 451  
 452  //! @brief Convert string to required mode and store.
 453  
 454  BOOL_T genie_string_to_value_internal (NODE_T * p, MOID_T * m, char *a, BYTE_T * item)
 455  {
 456    errno = 0;
 457  // strto.. does not mind empty strings.
 458    if (strlen (a) == 0) {
 459      return A68_FALSE;
 460    }
 461    if (m == M_INT) {
 462      A68_INT *z = (A68_INT *) item;
 463      char *end;
 464      VALUE (z) = (INT_T) a68_strtoi (a, &end, 10);
 465      if (end[0] == NULL_CHAR && errno == 0) {
 466        STATUS (z) = INIT_MASK;
 467        return A68_TRUE;
 468      } else {
 469        return A68_FALSE;
 470      }
 471    }
 472    if (m == M_REAL) {
 473      A68_REAL *z = (A68_REAL *) item;
 474      char *end;
 475      VALUE (z) = strtod (a, &end);
 476      if (end[0] == NULL_CHAR && errno == 0) {
 477        STATUS (z) = INIT_MASK;
 478        return A68_TRUE;
 479      } else {
 480        return A68_FALSE;
 481      }
 482    }
 483  #if (A68_LEVEL >= 3)
 484    if (m == M_LONG_INT) {
 485      A68_LONG_INT *z = (A68_LONG_INT *) item;
 486      if (string_to_double_int (p, z, a) == A68_FALSE) {
 487        return A68_FALSE;
 488      }
 489      STATUS (z) = INIT_MASK;
 490      return A68_TRUE;
 491    }
 492    if (m == M_LONG_REAL) {
 493      A68_LONG_REAL *z = (A68_LONG_REAL *) item;
 494      char *end;
 495  //  VALUE (z).f = strtoflt128 (a, &end);
 496      VALUE (z).f = string_to_double_real (a, &end);
 497      MATH_RTE (p, errno != 0, M_LONG_REAL, ERROR_MATH);
 498      if (end[0] == NULL_CHAR && errno == 0) {
 499        STATUS (z) = INIT_MASK;
 500        return A68_TRUE;
 501      } else {
 502        return A68_FALSE;
 503      }
 504    }
 505    if (m == M_LONG_BITS) {
 506      A68_LONG_BITS *z = (A68_LONG_BITS *) item;
 507      int rc = A68_TRUE;
 508      DOUBLE_NUM_T b;
 509      set_lw (b, 0x0);
 510      if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
 511  // [] BOOL denotation is "TTFFFFTFT ...".
 512        if (strlen (a) > (size_t) LONG_BITS_WIDTH) {
 513          errno = ERANGE;
 514          rc = A68_FALSE;
 515        } else {
 516          int j = (int) strlen (a) - 1, n = 1;
 517          UNSIGNED_T k = 0x1;
 518          for (; j >= 0; j--) {
 519            if (a[j] == FLIP_CHAR) {
 520              if (n <= LONG_BITS_WIDTH / 2) {
 521                LW (b) |= k;
 522              } else {
 523                HW (b) |= k;
 524              }
 525            } else if (a[j] != FLOP_CHAR) {
 526              rc = A68_FALSE;
 527            }
 528            k <<= 1;
 529          }
 530        }
 531        VALUE (z) = b;
 532      } else {
 533  // BITS denotation.
 534        VALUE (z) = double_strtou (p, a);
 535      }
 536      return rc;
 537    }
 538  #else
 539    if (m == M_LONG_BITS || m == M_LONG_LONG_BITS) {
 540      int digits = DIGITS (m);
 541      int status = A68_TRUE;
 542      ADDR_T pop_sp = A68_SP;
 543      MP_T *z = (MP_T *) item;
 544      if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
 545  // [] BOOL denotation is "TTFFFFTFT ...".
 546        if (strlen (a) > (size_t) BITS_WIDTH) {
 547          errno = ERANGE;
 548          status = A68_FALSE;
 549        } else {
 550          int j;
 551          MP_T *w = lit_mp (p, 1, 0, digits);
 552          SET_MP_ZERO (z, digits);
 553          for (j = (int) strlen (a) - 1; j >= 0; j--) {
 554            if (a[j] == FLIP_CHAR) {
 555              (void) add_mp (p, z, z, w, digits);
 556            } else if (a[j] != FLOP_CHAR) {
 557              status = A68_FALSE;
 558            }
 559            (void) mul_mp_digit (p, w, w, (MP_T) 2, digits);
 560          }
 561        }
 562      } else {
 563  // BITS denotation is also allowed.
 564        mp_strtou (p, z, a, m);
 565      }
 566      A68_SP = pop_sp;
 567      if (errno != 0 || status == A68_FALSE) {
 568        return A68_FALSE;
 569      }
 570      MP_STATUS (z) = (MP_T) INIT_MASK;
 571      return A68_TRUE;
 572    }
 573  #endif
 574    if (m == M_LONG_INT || m == M_LONG_LONG_INT) {
 575      int digits = DIGITS (m);
 576      MP_T *z = (MP_T *) item;
 577      if (strtomp (p, z, a, digits) == NaN_MP) {
 578        return A68_FALSE;
 579      }
 580      if (!check_mp_int (z, m)) {
 581        errno = ERANGE;
 582        return A68_FALSE;
 583      }
 584      MP_STATUS (z) = (MP_T) INIT_MASK;
 585      return A68_TRUE;
 586    }
 587    if (m == M_LONG_REAL || m == M_LONG_LONG_REAL) {
 588      int digits = DIGITS (m);
 589      MP_T *z = (MP_T *) item;
 590      if (strtomp (p, z, a, digits) == NaN_MP) {
 591        return A68_FALSE;
 592      }
 593      MP_STATUS (z) = (MP_T) INIT_MASK;
 594      return A68_TRUE;
 595    }
 596    if (m == M_BOOL) {
 597      A68_BOOL *z = (A68_BOOL *) item;
 598      char q = a[0], flip = FLIP_CHAR, flop = FLOP_CHAR;
 599      if (q == flip || q == flop) {
 600        VALUE (z) = (BOOL_T) (q == flip);
 601        STATUS (z) = INIT_MASK;
 602        return A68_TRUE;
 603      } else {
 604        return A68_FALSE;
 605      }
 606    }
 607    if (m == M_BITS) {
 608      A68_BITS *z = (A68_BITS *) item;
 609      int status = A68_TRUE;
 610      if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
 611  // [] BOOL denotation is "TTFFFFTFT ...".
 612        if (strlen (a) > (size_t) BITS_WIDTH) {
 613          errno = ERANGE;
 614          status = A68_FALSE;
 615        } else {
 616          int j = (int) strlen (a) - 1;
 617          UNSIGNED_T k = 0x1;
 618          VALUE (z) = 0;
 619          for (; j >= 0; j--) {
 620            if (a[j] == FLIP_CHAR) {
 621              VALUE (z) += k;
 622            } else if (a[j] != FLOP_CHAR) {
 623              status = A68_FALSE;
 624            }
 625            k <<= 1;
 626          }
 627        }
 628      } else {
 629  // BITS denotation is also allowed.
 630        VALUE (z) = bits_to_int (p, a);
 631      }
 632      if (errno != 0 || status == A68_FALSE) {
 633        return A68_FALSE;
 634      }
 635      STATUS (z) = INIT_MASK;
 636      return A68_TRUE;
 637    }
 638    return A68_FALSE;
 639  }
 640  
 641  //! @brief Convert string in input buffer to value of required mode.
 642  
 643  void genie_string_to_value (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
 644  {
 645    char *str = get_transput_buffer (INPUT_BUFFER);
 646    errno = 0;
 647  // end string, just in case.
 648    plusab_transput_buffer (p, INPUT_BUFFER, NULL_CHAR);
 649    if (mode == M_INT) {
 650      if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
 651        value_error (p, mode, ref_file);
 652      }
 653    } else if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
 654      if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
 655        value_error (p, mode, ref_file);
 656      }
 657    } else if (mode == M_REAL) {
 658      if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
 659        value_error (p, mode, ref_file);
 660      }
 661    } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
 662      if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
 663        value_error (p, mode, ref_file);
 664      }
 665    } else if (mode == M_BOOL) {
 666      if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
 667        value_error (p, mode, ref_file);
 668      }
 669    } else if (mode == M_BITS) {
 670      if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
 671        value_error (p, mode, ref_file);
 672      }
 673    } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
 674      if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
 675        value_error (p, mode, ref_file);
 676      }
 677    } else if (mode == M_CHAR) {
 678      A68_CHAR *z = (A68_CHAR *) item;
 679      if (str[0] == NULL_CHAR) {
 680  //      value_error (p, mode, ref_file);.
 681        VALUE (z) = NULL_CHAR;
 682        STATUS (z) = INIT_MASK;
 683      } else {
 684        int len = (int) strlen (str);
 685        if (len == 0 || len > 1) {
 686          value_error (p, mode, ref_file);
 687        }
 688        VALUE (z) = str[0];
 689        STATUS (z) = INIT_MASK;
 690      }
 691    } else if (mode == M_STRING) {
 692      A68_REF z;
 693      z = c_to_a_string (p, str, get_transput_buffer_index (INPUT_BUFFER) - 1);
 694      *(A68_REF *) item = z;
 695    }
 696    if (errno != 0) {
 697      transput_error (p, ref_file, mode);
 698    }
 699  }
 700  
 701  //! @brief Read object from file.
 702  
 703  void genie_read_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
 704  {
 705    A68_FILE *f = FILE_DEREF (&ref_file);
 706    errno = 0;
 707    if (END_OF_FILE (f)) {
 708      end_of_file_error (p, ref_file);
 709    }
 710    if (mode == M_PROC_REF_FILE_VOID) {
 711      genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
 712    } else if (mode == M_FORMAT) {
 713      diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
 714      exit_genie (p, A68_RUNTIME_ERROR);
 715    } else if (mode == M_REF_SOUND) {
 716      read_sound (p, ref_file, DEREF (A68_SOUND, (A68_REF *) item));
 717    } else if (IS_REF (mode)) {
 718      CHECK_REF (p, *(A68_REF *) item, mode);
 719      genie_read_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file);
 720    } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
 721      scan_integer (p, ref_file);
 722      genie_string_to_value (p, mode, item, ref_file);
 723    } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
 724      scan_real (p, ref_file);
 725      genie_string_to_value (p, mode, item, ref_file);
 726    } else if (mode == M_BOOL) {
 727      scan_char (p, ref_file);
 728      genie_string_to_value (p, mode, item, ref_file);
 729    } else if (mode == M_CHAR) {
 730      scan_char (p, ref_file);
 731      genie_string_to_value (p, mode, item, ref_file);
 732    } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
 733      scan_bits (p, ref_file);
 734      genie_string_to_value (p, mode, item, ref_file);
 735    } else if (mode == M_STRING) {
 736      char *term = DEREF (char, &TERMINATOR (f));
 737      scan_string (p, term, ref_file);
 738      genie_string_to_value (p, mode, item, ref_file);
 739    } else if (IS_STRUCT (mode)) {
 740      PACK_T *q = PACK (mode);
 741      for (; q != NO_PACK; FORWARD (q)) {
 742        genie_read_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
 743      }
 744    } else if (IS_UNION (mode)) {
 745      A68_UNION *z = (A68_UNION *) item;
 746      if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
 747        diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
 748        exit_genie (p, A68_RUNTIME_ERROR);
 749      }
 750      genie_read_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
 751    } else if (IS_ROW (mode) || IS_FLEX (mode)) {
 752      MOID_T *deflexed = DEFLEX (mode);
 753      A68_ARRAY *arr;
 754      A68_TUPLE *tup;
 755      CHECK_INIT (p, INITIALISED ((A68_REF *) item), mode);
 756      GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
 757      if (get_row_size (tup, DIM (arr)) > 0) {
 758        BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
 759        BOOL_T done = A68_FALSE;
 760        initialise_internal_index (tup, DIM (arr));
 761        while (!done) {
 762          ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
 763          ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
 764          genie_read_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
 765          done = increment_internal_index (tup, DIM (arr));
 766        }
 767      }
 768    }
 769    if (errno != 0) {
 770      transput_error (p, ref_file, mode);
 771    }
 772  }
 773  
 774  //! @brief PROC ([] SIMPLIN) VOID read
 775  
 776  void genie_read (NODE_T * p)
 777  {
 778    A68_REF row;
 779    POP_REF (p, &row);
 780    genie_stand_in (p);
 781    PUSH_REF (p, row);
 782    genie_read_file (p);
 783  }
 784  
 785  //! @brief Open for reading.
 786  
 787  void open_for_reading (NODE_T * p, A68_REF ref_file)
 788  {
 789    A68_FILE *file = FILE_DEREF (&ref_file);
 790    if (!OPENED (file)) {
 791      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
 792      exit_genie (p, A68_RUNTIME_ERROR);
 793    }
 794    if (DRAW_MOOD (file)) {
 795      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
 796      exit_genie (p, A68_RUNTIME_ERROR);
 797    }
 798    if (WRITE_MOOD (file)) {
 799      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
 800      exit_genie (p, A68_RUNTIME_ERROR);
 801    }
 802    if (!GET (&CHANNEL (file))) {
 803      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
 804      exit_genie (p, A68_RUNTIME_ERROR);
 805    }
 806    if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
 807      if (IS_NIL (STRING (file))) {
 808        if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILENO) {
 809          open_error (p, ref_file, "getting");
 810        }
 811      } else {
 812        FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0);
 813      }
 814      DRAW_MOOD (file) = A68_FALSE;
 815      READ_MOOD (file) = A68_TRUE;
 816      WRITE_MOOD (file) = A68_FALSE;
 817      CHAR_MOOD (file) = A68_TRUE;
 818    }
 819    if (!CHAR_MOOD (file)) {
 820      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
 821      exit_genie (p, A68_RUNTIME_ERROR);
 822    }
 823  }
 824  
 825  //! @brief PROC (REF FILE, [] SIMPLIN) VOID get
 826  
 827  void genie_read_file (NODE_T * p)
 828  {
 829    A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup;
 830    POP_REF (p, &row);
 831    CHECK_REF (p, row, M_ROW_SIMPLIN);
 832    GET_DESCRIPTOR (arr, tup, &row);
 833    int elems = ROW_SIZE (tup);
 834    A68_REF ref_file;
 835    POP_REF (p, &ref_file);
 836    CHECK_REF (p, ref_file, M_REF_FILE);
 837    A68_FILE *file = FILE_DEREF (&ref_file);
 838    CHECK_INIT (p, INITIALISED (file), M_FILE);
 839    open_for_reading (p, ref_file);
 840  // Read.
 841    if (elems <= 0) {
 842      return;
 843    }
 844    BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
 845    int elem_index = 0;
 846    for (int k = 0; k < elems; k++) {
 847      A68_UNION *z = (A68_UNION *) & base_address[elem_index];
 848      MOID_T *mode = (MOID_T *) (VALUE (z));
 849      BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
 850      genie_read_standard (p, mode, item, ref_file);
 851      elem_index += SIZE (M_SIMPLIN);
 852    }
 853  }
 854  
 855  //! @brief Convert value to string.
 856  
 857  void genie_value_to_string (NODE_T * p, MOID_T * moid, BYTE_T * item, int mod)
 858  {
 859    if (moid == M_INT) {
 860      A68_INT *z = (A68_INT *) item;
 861      PUSH_UNION (p, M_INT);
 862      PUSH_VALUE (p, VALUE (z), A68_INT);
 863      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT)));
 864      if (mod == FORMAT_ITEM_G) {
 865        PUSH_VALUE (p, INT_WIDTH + 1, A68_INT);
 866        genie_whole (p);
 867      } else if (mod == FORMAT_ITEM_H) {
 868        PUSH_VALUE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT);
 869        PUSH_VALUE (p, REAL_WIDTH - 1, A68_INT);
 870        PUSH_VALUE (p, EXP_WIDTH + 1, A68_INT);
 871        PUSH_VALUE (p, 3, A68_INT);
 872        genie_real (p);
 873      }
 874      return;
 875    }
 876  #if (A68_LEVEL >= 3)
 877    if (moid == M_LONG_INT) {
 878      A68_LONG_INT *z = (A68_LONG_INT *) item;
 879      PUSH_UNION (p, M_LONG_INT);
 880      PUSH (p, z, SIZE (M_LONG_INT));
 881      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_INT)));
 882      if (mod == FORMAT_ITEM_G) {
 883        PUSH_VALUE (p, LONG_WIDTH + 1, A68_INT);
 884        genie_whole (p);
 885      } else if (mod == FORMAT_ITEM_H) {
 886        PUSH_VALUE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT);
 887        PUSH_VALUE (p, LONG_REAL_WIDTH - 1, A68_INT);
 888        PUSH_VALUE (p, LONG_EXP_WIDTH + 1, A68_INT);
 889        PUSH_VALUE (p, 3, A68_INT);
 890        genie_real (p);
 891      }
 892      return;
 893    }
 894    if (moid == M_LONG_REAL) {
 895      A68_LONG_REAL *z = (A68_LONG_REAL *) item;
 896      PUSH_UNION (p, M_LONG_REAL);
 897      PUSH_VALUE (p, VALUE (z), A68_LONG_REAL);
 898      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL)));
 899      PUSH_VALUE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT);
 900      PUSH_VALUE (p, LONG_REAL_WIDTH - 1, A68_INT);
 901      PUSH_VALUE (p, LONG_EXP_WIDTH + 1, A68_INT);
 902      if (mod == FORMAT_ITEM_G) {
 903        genie_float (p);
 904      } else if (mod == FORMAT_ITEM_H) {
 905        PUSH_VALUE (p, 3, A68_INT);
 906        genie_real (p);
 907      }
 908      return;
 909    }
 910    if (moid == M_LONG_BITS) {
 911      A68_LONG_BITS *z = (A68_LONG_BITS *) item;
 912      char *s = stack_string (p, 8 + LONG_BITS_WIDTH);
 913      int n = 0, w;
 914      for (w = 0; w <= 1; w++) {
 915        UNSIGNED_T bit = D_SIGN;
 916        int j;
 917        for (j = 0; j < BITS_WIDTH; j++) {
 918          if (w == 0) {
 919            s[n] = (char) ((HW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR);
 920          } else {
 921            s[n] = (char) ((LW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR);
 922          }
 923          bit >>= 1;
 924          n++;
 925        }
 926      }
 927      s[n] = NULL_CHAR;
 928      return;
 929    }
 930  #else
 931    if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) {
 932      int bits = get_mp_bits_width (moid), word = get_mp_bits_words (moid);
 933      int pos = bits;
 934      char *str = stack_string (p, 8 + bits);
 935      ADDR_T pop_sp = A68_SP;
 936      unt *row = stack_mp_bits (p, (MP_T *) item, moid);
 937      str[pos--] = NULL_CHAR;
 938      while (pos >= 0) {
 939        unt bit = 0x1;
 940        int j;
 941        for (j = 0; j < MP_BITS_BITS && pos >= 0; j++) {
 942          str[pos--] = (char) ((row[word - 1] & bit) ? FLIP_CHAR : FLOP_CHAR);
 943          bit <<= 1;
 944        }
 945        word--;
 946      }
 947      A68_SP = pop_sp;
 948      return;
 949    }
 950  #endif
 951    if (moid == M_LONG_INT) {
 952      MP_T *z = (MP_T *) item;
 953      PUSH_UNION (p, M_LONG_INT);
 954      PUSH (p, z, SIZE (M_LONG_INT));
 955      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_INT)));
 956      if (mod == FORMAT_ITEM_G) {
 957        PUSH_VALUE (p, LONG_WIDTH + 1, A68_INT);
 958        genie_whole (p);
 959      } else if (mod == FORMAT_ITEM_H) {
 960        PUSH_VALUE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT);
 961        PUSH_VALUE (p, LONG_REAL_WIDTH - 1, A68_INT);
 962        PUSH_VALUE (p, LONG_EXP_WIDTH + 1, A68_INT);
 963        PUSH_VALUE (p, 3, A68_INT);
 964        genie_real (p);
 965      }
 966      return;
 967    }
 968    if (moid == M_LONG_LONG_INT) {
 969      MP_T *z = (MP_T *) item;
 970      PUSH_UNION (p, M_LONG_LONG_INT);
 971      PUSH (p, z, SIZE (M_LONG_LONG_INT));
 972      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_LONG_INT)));
 973      if (mod == FORMAT_ITEM_G) {
 974        PUSH_VALUE (p, LONG_LONG_WIDTH + 1, A68_INT);
 975        genie_whole (p);
 976      } else if (mod == FORMAT_ITEM_H) {
 977        PUSH_VALUE (p, LONG_LONG_REAL_WIDTH + LONG_LONG_EXP_WIDTH + 4, A68_INT);
 978        PUSH_VALUE (p, LONG_LONG_REAL_WIDTH - 1, A68_INT);
 979        PUSH_VALUE (p, LONG_LONG_EXP_WIDTH + 1, A68_INT);
 980        PUSH_VALUE (p, 3, A68_INT);
 981        genie_real (p);
 982      }
 983      return;
 984    }
 985    if (moid == M_REAL) {
 986      A68_REAL *z = (A68_REAL *) item;
 987      PUSH_UNION (p, M_REAL);
 988      PUSH_VALUE (p, VALUE (z), A68_REAL);
 989      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
 990      PUSH_VALUE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT);
 991      PUSH_VALUE (p, REAL_WIDTH - 1, A68_INT);
 992      PUSH_VALUE (p, EXP_WIDTH + 1, A68_INT);
 993      if (mod == FORMAT_ITEM_G) {
 994        genie_float (p);
 995      } else if (mod == FORMAT_ITEM_H) {
 996        PUSH_VALUE (p, 3, A68_INT);
 997        genie_real (p);
 998      }
 999      return;
1000    }
1001    if (moid == M_LONG_REAL) {
1002      MP_T *z = (MP_T *) item;
1003      PUSH_UNION (p, M_LONG_REAL);
1004      PUSH (p, z, (int) SIZE (M_LONG_REAL));
1005      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL)));
1006      PUSH_VALUE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT);
1007      PUSH_VALUE (p, LONG_REAL_WIDTH - 1, A68_INT);
1008      PUSH_VALUE (p, LONG_EXP_WIDTH + 1, A68_INT);
1009      if (mod == FORMAT_ITEM_G) {
1010        genie_float (p);
1011      } else if (mod == FORMAT_ITEM_H) {
1012        PUSH_VALUE (p, 3, A68_INT);
1013        genie_real (p);
1014      }
1015      return;
1016    }
1017    if (moid == M_LONG_LONG_REAL) {
1018      MP_T *z = (MP_T *) item;
1019      PUSH_UNION (p, M_LONG_LONG_REAL);
1020      PUSH (p, z, (int) SIZE (M_LONG_LONG_REAL));
1021      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_LONG_REAL)));
1022      PUSH_VALUE (p, LONG_LONG_REAL_WIDTH + LONG_LONG_EXP_WIDTH + 4, A68_INT);
1023      PUSH_VALUE (p, LONG_LONG_REAL_WIDTH - 1, A68_INT);
1024      PUSH_VALUE (p, LONG_LONG_EXP_WIDTH + 1, A68_INT);
1025      if (mod == FORMAT_ITEM_G) {
1026        genie_float (p);
1027      } else if (mod == FORMAT_ITEM_H) {
1028        PUSH_VALUE (p, 3, A68_INT);
1029        genie_real (p);
1030      }
1031      return;
1032    }
1033    if (moid == M_BITS) {
1034      A68_BITS *z = (A68_BITS *) item;
1035      char *str = stack_string (p, 8 + BITS_WIDTH);
1036      UNSIGNED_T bit = 0x1;
1037      int j;
1038      for (j = 1; j < BITS_WIDTH; j++) {
1039        bit <<= 1;
1040      }
1041      for (j = 0; j < BITS_WIDTH; j++) {
1042        str[j] = (char) ((VALUE (z) & bit) ? FLIP_CHAR : FLOP_CHAR);
1043        bit >>= 1;
1044      }
1045      str[j] = NULL_CHAR;
1046      return;
1047    }
1048  }
1049  
1050  //! @brief Print object to file.
1051  
1052  void genie_write_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
1053  {
1054    errno = 0;
1055    ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1056    if (mode == M_PROC_REF_FILE_VOID) {
1057      genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
1058    } else if (mode == M_FORMAT) {
1059      diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1060      exit_genie (p, A68_RUNTIME_ERROR);
1061    } else if (mode == M_SOUND) {
1062      write_sound (p, ref_file, (A68_SOUND *) item);
1063    } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
1064      genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1065      add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
1066    } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
1067      genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1068      add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
1069    } else if (mode == M_BOOL) {
1070      A68_BOOL *z = (A68_BOOL *) item;
1071      char flipflop = (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR);
1072      plusab_transput_buffer (p, UNFORMATTED_BUFFER, flipflop);
1073    } else if (mode == M_CHAR) {
1074      A68_CHAR *ch = (A68_CHAR *) item;
1075      plusab_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (ch));
1076    } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
1077      char *str = (char *) STACK_TOP;
1078      genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1079      add_string_transput_buffer (p, UNFORMATTED_BUFFER, str);
1080    } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1081  // Handle these separately since this is faster than straightening.
1082      add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
1083    } else if (IS_UNION (mode)) {
1084      A68_UNION *z = (A68_UNION *) item;
1085      genie_write_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
1086    } else if (IS_STRUCT (mode)) {
1087      PACK_T *q = PACK (mode);
1088      for (; q != NO_PACK; FORWARD (q)) {
1089        BYTE_T *elem = &item[OFFSET (q)];
1090        genie_check_initialisation (p, elem, MOID (q));
1091        genie_write_standard (p, MOID (q), elem, ref_file);
1092      }
1093    } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1094      MOID_T *deflexed = DEFLEX (mode);
1095      A68_ARRAY *arr;
1096      A68_TUPLE *tup;
1097      CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
1098      GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1099      if (get_row_size (tup, DIM (arr)) > 0) {
1100        BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1101        BOOL_T done = A68_FALSE;
1102        initialise_internal_index (tup, DIM (arr));
1103        while (!done) {
1104          ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
1105          ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
1106          BYTE_T *elem = &base_addr[elem_addr];
1107          genie_check_initialisation (p, elem, SUB (deflexed));
1108          genie_write_standard (p, SUB (deflexed), elem, ref_file);
1109          done = increment_internal_index (tup, DIM (arr));
1110        }
1111      }
1112    }
1113    if (errno != 0) {
1114      ABEND (IS_NIL (ref_file), ERROR_ACTION, error_specification ());
1115      transput_error (p, ref_file, mode);
1116    }
1117  }
1118  
1119  //! @brief PROC ([] SIMPLOUT) VOID print, write
1120  
1121  void genie_write (NODE_T * p)
1122  {
1123    A68_REF row;
1124    POP_REF (p, &row);
1125    genie_stand_out (p);
1126    PUSH_REF (p, row);
1127    genie_write_file (p);
1128  }
1129  
1130  //! @brief Open for writing.
1131  
1132  void open_for_writing (NODE_T * p, A68_REF ref_file)
1133  {
1134    A68_FILE *file = FILE_DEREF (&ref_file);
1135    if (!OPENED (file)) {
1136      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1137      exit_genie (p, A68_RUNTIME_ERROR);
1138    }
1139    if (DRAW_MOOD (file)) {
1140      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1141      exit_genie (p, A68_RUNTIME_ERROR);
1142    }
1143    if (READ_MOOD (file)) {
1144      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1145      exit_genie (p, A68_RUNTIME_ERROR);
1146    }
1147    if (!PUT (&CHANNEL (file))) {
1148      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1149      exit_genie (p, A68_RUNTIME_ERROR);
1150    }
1151    if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1152      if (IS_NIL (STRING (file))) {
1153        if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILENO) {
1154          open_error (p, ref_file, "putting");
1155        }
1156      } else {
1157        FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, 0);
1158      }
1159      DRAW_MOOD (file) = A68_FALSE;
1160      READ_MOOD (file) = A68_FALSE;
1161      WRITE_MOOD (file) = A68_TRUE;
1162      CHAR_MOOD (file) = A68_TRUE;
1163    }
1164    if (!CHAR_MOOD (file)) {
1165      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
1166      exit_genie (p, A68_RUNTIME_ERROR);
1167    }
1168  }
1169  
1170  //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put
1171  
1172  void genie_write_file (NODE_T * p)
1173  {
1174    A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup;
1175    POP_REF (p, &row);
1176    CHECK_REF (p, row, M_ROW_SIMPLOUT);
1177    GET_DESCRIPTOR (arr, tup, &row);
1178    int elems = ROW_SIZE (tup);
1179    A68_REF ref_file;
1180    POP_REF (p, &ref_file);
1181    CHECK_REF (p, ref_file, M_REF_FILE);
1182    A68_FILE *file = FILE_DEREF (&ref_file);
1183    CHECK_INIT (p, INITIALISED (file), M_FILE);
1184    open_for_writing (p, ref_file);
1185  // Write.
1186    if (elems <= 0) {
1187      return;
1188    }
1189    BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1190    int elem_index = 0;
1191    for (int k = 0; k < elems; k++) {
1192      A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
1193      MOID_T *mode = (MOID_T *) (VALUE (z));
1194      BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
1195      reset_transput_buffer (UNFORMATTED_BUFFER);
1196      genie_write_standard (p, mode, item, ref_file);
1197      write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);
1198      elem_index += SIZE (M_SIMPLOUT);
1199    }
1200  }
1201  
1202  //! @brief Read object binary from file.
1203  
1204  void genie_read_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
1205  {
1206    CHECK_REF (p, ref_file, M_REF_FILE);
1207    A68_FILE *f = FILE_DEREF (&ref_file);
1208    errno = 0;
1209    if (END_OF_FILE (f)) {
1210      end_of_file_error (p, ref_file);
1211    }
1212    if (mode == M_PROC_REF_FILE_VOID) {
1213      genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
1214    } else if (mode == M_FORMAT) {
1215      diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1216      exit_genie (p, A68_RUNTIME_ERROR);
1217    } else if (mode == M_REF_SOUND) {
1218      read_sound (p, ref_file, (A68_SOUND *) ADDRESS ((A68_REF *) item));
1219    } else if (IS_REF (mode)) {
1220      CHECK_REF (p, *(A68_REF *) item, mode);
1221      genie_read_bin_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file);
1222    } else if (mode == M_INT) {
1223      A68_INT *z = (A68_INT *) item;
1224      ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1225      STATUS (z) = INIT_MASK;
1226    } else if (mode == M_LONG_INT) {
1227  #if (A68_LEVEL >= 3)
1228      A68_LONG_INT *z = (A68_LONG_INT *) item;
1229      ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1230      STATUS (z) = INIT_MASK;
1231  #else
1232      MP_T *z = (MP_T *) item;
1233      ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1234      MP_STATUS (z) = (MP_T) INIT_MASK;
1235  #endif
1236    } else if (mode == M_LONG_LONG_INT) {
1237      MP_T *z = (MP_T *) item;
1238      ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1239      MP_STATUS (z) = (MP_T) INIT_MASK;
1240    } else if (mode == M_REAL) {
1241      A68_REAL *z = (A68_REAL *) item;
1242      ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1243      STATUS (z) = INIT_MASK;
1244    } else if (mode == M_LONG_REAL) {
1245  #if (A68_LEVEL >= 3)
1246      A68_LONG_REAL *z = (A68_LONG_REAL *) item;
1247      ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1248      STATUS (z) = INIT_MASK;
1249  #else
1250      MP_T *z = (MP_T *) item;
1251      ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1252      MP_STATUS (z) = (MP_T) INIT_MASK;
1253  #endif
1254    } else if (mode == M_LONG_LONG_REAL) {
1255      MP_T *z = (MP_T *) item;
1256      ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1257      MP_STATUS (z) = (MP_T) INIT_MASK;
1258    } else if (mode == M_BOOL) {
1259      A68_BOOL *z = (A68_BOOL *) item;
1260      ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1261      STATUS (z) = INIT_MASK;
1262    } else if (mode == M_CHAR) {
1263      A68_CHAR *z = (A68_CHAR *) item;
1264      ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1265      STATUS (z) = INIT_MASK;
1266    } else if (mode == M_BITS) {
1267      A68_BITS *z = (A68_BITS *) item;
1268      ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1269      STATUS (z) = INIT_MASK;
1270    } else if (mode == M_LONG_BITS) {
1271  #if (A68_LEVEL >= 3)
1272      A68_LONG_BITS *z = (A68_LONG_BITS *) item;
1273      ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1274      STATUS (z) = INIT_MASK;
1275  #else
1276      MP_T *z = (MP_T *) item;
1277      ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1278      MP_STATUS (z) = (MP_T) INIT_MASK;
1279  #endif
1280    } else if (mode == M_LONG_LONG_BITS) {
1281      MP_T *z = (MP_T *) item;
1282      ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1283      MP_STATUS (z) = (MP_T) INIT_MASK;
1284    } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1285      int len, k;
1286      ASSERT (io_read (FD (f), &(len), sizeof (len)) != -1);
1287      reset_transput_buffer (UNFORMATTED_BUFFER);
1288      for (k = 0; k < len; k++) {
1289        char ch;
1290        ASSERT (io_read (FD (f), &(ch), sizeof (char)) != -1);
1291        plusab_transput_buffer (p, UNFORMATTED_BUFFER, ch);
1292      }
1293      *(A68_REF *) item = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
1294    } else if (IS_UNION (mode)) {
1295      A68_UNION *z = (A68_UNION *) item;
1296      if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
1297        diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
1298        exit_genie (p, A68_RUNTIME_ERROR);
1299      }
1300      genie_read_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
1301    } else if (IS_STRUCT (mode)) {
1302      PACK_T *q = PACK (mode);
1303      for (; q != NO_PACK; FORWARD (q)) {
1304        genie_read_bin_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
1305      }
1306    } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1307      MOID_T *deflexed = DEFLEX (mode);
1308      A68_ARRAY *arr; A68_TUPLE *tup;
1309      CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
1310      GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1311      if (get_row_size (tup, DIM (arr)) > 0) {
1312        BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1313        BOOL_T done = A68_FALSE;
1314        initialise_internal_index (tup, DIM (arr));
1315        while (!done) {
1316          ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
1317          ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
1318          genie_read_bin_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
1319          done = increment_internal_index (tup, DIM (arr));
1320        }
1321      }
1322    }
1323    if (errno != 0) {
1324      transput_error (p, ref_file, mode);
1325    }
1326  }
1327  
1328  //! @brief PROC ([] SIMPLIN) VOID read bin
1329  
1330  void genie_read_bin (NODE_T * p)
1331  {
1332    A68_REF row;
1333    POP_REF (p, &row);
1334    genie_stand_back (p);
1335    PUSH_REF (p, row);
1336    genie_read_bin_file (p);
1337  }
1338  
1339  //! @brief PROC (REF FILE, [] SIMPLIN) VOID get bin
1340  
1341  void genie_read_bin_file (NODE_T * p)
1342  {
1343    A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup;
1344    POP_REF (p, &row);
1345    CHECK_REF (p, row, M_ROW_SIMPLIN);
1346    GET_DESCRIPTOR (arr, tup, &row);
1347    int elems = ROW_SIZE (tup);
1348    A68_REF ref_file;
1349    POP_REF (p, &ref_file);
1350    ref_file = *(A68_REF *) STACK_TOP;
1351    CHECK_REF (p, ref_file, M_REF_FILE);
1352    A68_FILE *file = FILE_DEREF (&ref_file);
1353    CHECK_INIT (p, INITIALISED (file), M_FILE);
1354    if (!OPENED (file)) {
1355      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1356      exit_genie (p, A68_RUNTIME_ERROR);
1357    }
1358    if (DRAW_MOOD (file)) {
1359      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1360      exit_genie (p, A68_RUNTIME_ERROR);
1361    }
1362    if (WRITE_MOOD (file)) {
1363      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1364      exit_genie (p, A68_RUNTIME_ERROR);
1365    }
1366    if (!GET (&CHANNEL (file))) {
1367      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
1368      exit_genie (p, A68_RUNTIME_ERROR);
1369    }
1370    if (!BIN (&CHANNEL (file))) {
1371      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary getting");
1372      exit_genie (p, A68_RUNTIME_ERROR);
1373    }
1374    if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1375      if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS | O_BINARY, 0)) == A68_NO_FILENO) {
1376        open_error (p, ref_file, "binary getting");
1377      }
1378      DRAW_MOOD (file) = A68_FALSE;
1379      READ_MOOD (file) = A68_TRUE;
1380      WRITE_MOOD (file) = A68_FALSE;
1381      CHAR_MOOD (file) = A68_FALSE;
1382    }
1383    if (CHAR_MOOD (file)) {
1384      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
1385      exit_genie (p, A68_RUNTIME_ERROR);
1386    }
1387  // Read.
1388    if (elems <= 0) {
1389      return;
1390    }
1391    int elem_index = 0;
1392    BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1393    for (int k = 0; k < elems; k++) {
1394      A68_UNION *z = (A68_UNION *) & base_address[elem_index];
1395      MOID_T *mode = (MOID_T *) (VALUE (z));
1396      BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
1397      genie_read_bin_standard (p, mode, item, ref_file);
1398      elem_index += SIZE (M_SIMPLIN);
1399    }
1400  }
1401  
1402  //! @brief Write object binary to file.
1403  
1404  void genie_write_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
1405  {
1406    CHECK_REF (p, ref_file, M_REF_FILE);
1407    A68_FILE *f = FILE_DEREF (&ref_file);
1408    errno = 0;
1409    if (mode == M_PROC_REF_FILE_VOID) {
1410      genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
1411    } else if (mode == M_FORMAT) {
1412      diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1413      exit_genie (p, A68_RUNTIME_ERROR);
1414    } else if (mode == M_SOUND) {
1415      write_sound (p, ref_file, (A68_SOUND *) item);
1416    } else if (mode == M_INT) {
1417      ASSERT (io_write (FD (f), &(VALUE ((A68_INT *) item)), sizeof (VALUE ((A68_INT *) item))) != -1);
1418    } else if (mode == M_LONG_INT) {
1419  #if (A68_LEVEL >= 3)
1420      ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_INT *) item)), sizeof (VALUE ((A68_LONG_INT *) item))) != -1);
1421  #else
1422      ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1423  #endif
1424    } else if (mode == M_LONG_LONG_INT) {
1425      ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1426    } else if (mode == M_REAL) {
1427      ASSERT (io_write (FD (f), &(VALUE ((A68_REAL *) item)), sizeof (VALUE ((A68_REAL *) item))) != -1);
1428    } else if (mode == M_LONG_REAL) {
1429  #if (A68_LEVEL >= 3)
1430      ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_REAL *) item)), sizeof (VALUE ((A68_LONG_REAL *) item))) != -1);
1431  #else
1432      ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1433  #endif
1434    } else if (mode == M_LONG_LONG_REAL) {
1435      ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1436    } else if (mode == M_BOOL) {
1437      ASSERT (io_write (FD (f), &(VALUE ((A68_BOOL *) item)), sizeof (VALUE ((A68_BOOL *) item))) != -1);
1438    } else if (mode == M_CHAR) {
1439      ASSERT (io_write (FD (f), &(VALUE ((A68_CHAR *) item)), sizeof (VALUE ((A68_CHAR *) item))) != -1);
1440    } else if (mode == M_BITS) {
1441      ASSERT (io_write (FD (f), &(VALUE ((A68_BITS *) item)), sizeof (VALUE ((A68_BITS *) item))) != -1);
1442    } else if (mode == M_LONG_BITS) {
1443  #if (A68_LEVEL >= 3)
1444      ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_BITS *) item)), sizeof (VALUE ((A68_LONG_BITS *) item))) != -1);
1445  #else
1446      ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1447  #endif
1448    } else if (mode == M_LONG_LONG_BITS) {
1449      ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1450    } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1451      reset_transput_buffer (UNFORMATTED_BUFFER);
1452      add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
1453      int len = get_transput_buffer_index (UNFORMATTED_BUFFER);
1454      ASSERT (io_write (FD (f), &(len), sizeof (len)) != -1);
1455      WRITE (FD (f), get_transput_buffer (UNFORMATTED_BUFFER));
1456    } else if (IS_UNION (mode)) {
1457      A68_UNION *z = (A68_UNION *) item;
1458      genie_write_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
1459    } else if (IS_STRUCT (mode)) {
1460      PACK_T *q = PACK (mode);
1461      for (; q != NO_PACK; FORWARD (q)) {
1462        BYTE_T *elem = &item[OFFSET (q)];
1463        genie_check_initialisation (p, elem, MOID (q));
1464        genie_write_bin_standard (p, MOID (q), elem, ref_file);
1465      }
1466    } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1467      MOID_T *deflexed = DEFLEX (mode);
1468      A68_ARRAY *arr; A68_TUPLE *tup;
1469      CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
1470      GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1471      if (get_row_size (tup, DIM (arr)) > 0) {
1472        BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1473        BOOL_T done = A68_FALSE;
1474        initialise_internal_index (tup, DIM (arr));
1475        while (!done) {
1476          ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
1477          ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
1478          BYTE_T *elem = &base_addr[elem_addr];
1479          genie_check_initialisation (p, elem, SUB (deflexed));
1480          genie_write_bin_standard (p, SUB (deflexed), elem, ref_file);
1481          done = increment_internal_index (tup, DIM (arr));
1482        }
1483      }
1484    }
1485    if (errno != 0) {
1486      transput_error (p, ref_file, mode);
1487    }
1488  }
1489  
1490  //! @brief PROC ([] SIMPLOUT) VOID write bin, print bin
1491  
1492  void genie_write_bin (NODE_T * p)
1493  {
1494    A68_REF row;
1495    POP_REF (p, &row);
1496    genie_stand_back (p);
1497    PUSH_REF (p, row);
1498    genie_write_bin_file (p);
1499  }
1500  
1501  //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put bin
1502  
1503  void genie_write_bin_file (NODE_T * p)
1504  {
1505    A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup;
1506    POP_REF (p, &row);
1507    CHECK_REF (p, row, M_ROW_SIMPLOUT);
1508    GET_DESCRIPTOR (arr, tup, &row);
1509    int elems = ROW_SIZE (tup);
1510    A68_REF ref_file;
1511    POP_REF (p, &ref_file);
1512    ref_file = *(A68_REF *) STACK_TOP;
1513    CHECK_REF (p, ref_file, M_REF_FILE);
1514    A68_FILE *file = FILE_DEREF (&ref_file);
1515    CHECK_INIT (p, INITIALISED (file), M_FILE);
1516    if (!OPENED (file)) {
1517      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1518      exit_genie (p, A68_RUNTIME_ERROR);
1519    }
1520    if (DRAW_MOOD (file)) {
1521      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1522      exit_genie (p, A68_RUNTIME_ERROR);
1523    }
1524    if (READ_MOOD (file)) {
1525      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1526      exit_genie (p, A68_RUNTIME_ERROR);
1527    }
1528    if (!PUT (&CHANNEL (file))) {
1529      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1530      exit_genie (p, A68_RUNTIME_ERROR);
1531    }
1532    if (!BIN (&CHANNEL (file))) {
1533      diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary putting");
1534      exit_genie (p, A68_RUNTIME_ERROR);
1535    }
1536    if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1537      if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS | O_BINARY, A68_PROTECTION)) == A68_NO_FILENO) {
1538        open_error (p, ref_file, "binary putting");
1539      }
1540      DRAW_MOOD (file) = A68_FALSE;
1541      READ_MOOD (file) = A68_FALSE;
1542      WRITE_MOOD (file) = A68_TRUE;
1543      CHAR_MOOD (file) = A68_FALSE;
1544    }
1545    if (CHAR_MOOD (file)) {
1546      diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
1547      exit_genie (p, A68_RUNTIME_ERROR);
1548    }
1549    if (elems <= 0) {
1550      return;
1551    }
1552    BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1553    int elem_index = 0;
1554    for (int k = 0; k < elems; k++) {
1555      A68_UNION *z = (A68_UNION *) & base_address[elem_index];
1556      MOID_T *mode = (MOID_T *) (VALUE (z));
1557      BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
1558      genie_write_bin_standard (p, mode, item, ref_file);
1559      elem_index += SIZE (M_SIMPLOUT);
1560    }
1561  }
1562  
1563  // Next are formatting routines "whole", "fixed" and "float" for mode
1564  // INT, LONG INT and LONG LONG INT, and REAL, LONG REAL and LONG LONG REAL.
1565  // They are direct implementations of the routines described in the
1566  // Revised Report, although those were only meant as a specification.
1567  // The rest of Algol68G should only reference "genie_whole", "genie_fixed"
1568  // or "genie_float" since internal routines like "sub_fixed" may leave the
1569  // stack corrupted when called directly.
1570  
1571  //! @brief Generate a string of error chars.
1572  
1573  char *error_chars (char *s, int n)
1574  {
1575    int k = (n != 0 ? ABS (n) : 1);
1576    s[k] = NULL_CHAR;
1577    while (--k >= 0) {
1578      s[k] = ERROR_CHAR;
1579    }
1580    return s;
1581  }
1582  
1583  //! @brief Convert temporary C string to A68 string.
1584  
1585  A68_REF tmp_to_a68_string (NODE_T * p, char *temp_string)
1586  {
1587  // no compaction allowed since temp_string might be up for garbage collecting ...
1588    return c_to_a_string (p, temp_string, DEFAULT_WIDTH);
1589  }
1590  
1591  //! @brief Add c to str, assuming that "str" is large enough.
1592  
1593  char *plusto (char c, char *str)
1594  {
1595    MOVE (&str[1], &str[0], (unt) (strlen (str) + 1));
1596    str[0] = c;
1597    return str;
1598  }
1599  
1600  //! @brief Add c to str, assuming that "str" is large enough.
1601  
1602  char *string_plusab_char (char *str, char c, int strwid)
1603  {
1604    char z[2];
1605    z[0] = c;
1606    z[1] = NULL_CHAR;
1607    bufcat (str, z, strwid);
1608    return str;
1609  }
1610  
1611  //! @brief Add leading spaces to str until length is width.
1612  
1613  char *leading_spaces (char *str, int width)
1614  {
1615    int j = width - (int) strlen (str);
1616    while (--j >= 0) {
1617      (void) plusto (BLANK_CHAR, str);
1618    }
1619    return str;
1620  }
1621  
1622  //! @brief Convert int to char using a table.
1623  
1624  char digchar (int k)
1625  {
1626    char *s = "0123456789abcdefghijklmnopqrstuvwxyz";
1627    if (k >= 0 && k < (int) strlen (s)) {
1628      return s[k];
1629    } else {
1630      return ERROR_CHAR;
1631    }
1632  }
1633  
1634  //! @brief Formatted string for HEX_NUMBER.
1635  
1636  char *bits (NODE_T * p)
1637  {
1638    A68_INT width, base;
1639    POP_OBJECT (p, &base, A68_INT);
1640    POP_OBJECT (p, &width, A68_INT);
1641    DECREMENT_STACK_POINTER (p, SIZE (M_HEX_NUMBER));
1642    CHECK_INT_SHORTEN (p, VALUE (&base));
1643    CHECK_INT_SHORTEN (p, VALUE (&width));
1644    MOID_T *mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
1645    int length = ABS (VALUE (&width)), radix = ABS (VALUE (&base));
1646    if (radix < 2 || radix > 16) {
1647      diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1648      exit_genie (p, A68_RUNTIME_ERROR);
1649    }
1650    reset_transput_buffer (EDIT_BUFFER);
1651  #if (A68_LEVEL <= 2)
1652    (void) mode;
1653    (void) length;
1654    (void) error_chars (get_transput_buffer (EDIT_BUFFER), VALUE (&width));
1655  #else
1656    {
1657      BOOL_T rc = A68_TRUE;
1658      if (mode == M_BOOL) {
1659        UNSIGNED_T z = VALUE ((A68_BOOL *) (STACK_OFFSET (A68_UNION_SIZE)));
1660        rc = convert_radix (p, (UNSIGNED_T) z, radix, length);
1661      } else if (mode == M_CHAR) {
1662        INT_T z = VALUE ((A68_CHAR *) (STACK_OFFSET (A68_UNION_SIZE)));
1663        rc = convert_radix (p, (UNSIGNED_T) z, radix, length);
1664      } else if (mode == M_INT) {
1665        INT_T z = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
1666        rc = convert_radix (p, (UNSIGNED_T) z, radix, length);
1667      } else if (mode == M_REAL) {
1668  // A trick to copy a REAL into an unt without truncating
1669        UNSIGNED_T z;
1670        memcpy (&z, (void *) &VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE))), 8);
1671        rc = convert_radix (p, z, radix, length);
1672      } else if (mode == M_BITS) {
1673        UNSIGNED_T z = VALUE ((A68_BITS *) (STACK_OFFSET (A68_UNION_SIZE)));
1674        rc = convert_radix (p, (UNSIGNED_T) z, radix, length);
1675      } else if (mode == M_LONG_INT) {
1676        DOUBLE_NUM_T z = VALUE ((A68_LONG_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
1677        rc = convert_radix_double (p, z, radix, length);
1678      } else if (mode == M_LONG_REAL) {
1679        DOUBLE_NUM_T z = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE)));
1680        rc = convert_radix_double (p, z, radix, length);
1681      } else if (mode == M_LONG_BITS) {
1682        DOUBLE_NUM_T z = VALUE ((A68_LONG_BITS *) (STACK_OFFSET (A68_UNION_SIZE)));
1683        rc = convert_radix_double (p, z, radix, length);
1684      }
1685      if (rc == A68_FALSE) {
1686        errno = EDOM;
1687        PRELUDE_ERROR (A68_TRUE, p, ERROR_OUT_OF_BOUNDS, mode);
1688      }
1689    }
1690  #endif
1691    return get_transput_buffer (EDIT_BUFFER);
1692  }
1693  
1694  //! @brief Standard string for LONG INT.
1695  
1696  #if (A68_LEVEL >= 3)
1697  char *long_sub_whole_double (NODE_T * p, DOUBLE_NUM_T n, int width)
1698  {
1699    char *s = stack_string (p, 8 + width);
1700    DOUBLE_NUM_T ten;
1701    set_lw (ten, 10);
1702    s[0] = NULL_CHAR;
1703    int len = 0;
1704    do {
1705      if (len < width) {
1706        DOUBLE_NUM_T w = double_udiv (p, M_LONG_INT, n, ten, 1);
1707        (void) plusto (digchar (LW (w)), s);
1708      }
1709      len++;
1710      n = double_udiv (p, M_LONG_INT, n, ten, 0);
1711    } while (!D_ZERO (n));
1712    if (len > width) {
1713      (void) error_chars (s, width);
1714    }
1715    return s;
1716  }
1717  #endif
1718  
1719  char *long_sub_whole (NODE_T * p, MP_T * m, int digits, int width)
1720  {
1721    int len = 0;
1722    char *s = stack_string (p, 8 + width);
1723    s[0] = NULL_CHAR;
1724    ADDR_T pop_sp = A68_SP;
1725    MP_T *n = nil_mp (p, digits);
1726    (void) move_mp (n, m, digits);
1727    do {
1728      if (len < width) {
1729  // Sic transit gloria mundi.
1730        int n_mod_10 = (MP_INT_T) MP_DIGIT (n, (int) (1 + MP_EXPONENT (n))) % 10;
1731        (void) plusto (digchar (n_mod_10), s);
1732      }
1733      len++;
1734      (void) over_mp_digit (p, n, n, (MP_T) 10, digits);
1735    } while (MP_DIGIT (n, 1) > 0);
1736    if (len > width) {
1737      (void) error_chars (s, width);
1738    }
1739    A68_SP = pop_sp;
1740    return s;
1741  }
1742  
1743  //! @brief Standard string for INT.
1744  
1745  char *sub_whole (NODE_T * p, INT_T n, int width)
1746  {
1747    char *s = stack_string (p, 8 + width);
1748    int len = 0;
1749    s[0] = NULL_CHAR;
1750    do {
1751      if (len < width) {
1752        (void) plusto (digchar (n % 10), s);
1753      }
1754      len++;
1755      n /= 10;
1756    } while (n != 0);
1757    if (len > width) {
1758      (void) error_chars (s, width);
1759    }
1760    return s;
1761  }
1762  
1763  //! @brief Formatted string for NUMBER.
1764  
1765  char *whole (NODE_T * p)
1766  {
1767    A68_INT width;
1768    POP_OBJECT (p, &width, A68_INT);
1769    CHECK_INT_SHORTEN (p, VALUE (&width));
1770    int arg_sp = A68_SP;
1771    DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1772    MOID_T *mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
1773    if (mode == M_INT) {
1774      INT_T x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
1775      INT_T n = ABS (x);
1776      int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0);
1777      int size = (x < 0 ? 1 : (VALUE (&width) > 0 ? 1 : 0));
1778      if (VALUE (&width) == 0) {
1779        INT_T m = n;
1780        length = 0;
1781        while ((m /= 10, length++, m != 0)) {
1782          ;
1783        }
1784      }
1785      size += length;
1786      size = 8 + (size > VALUE (&width) ? size : VALUE (&width));
1787      char *s = stack_string (p, size);
1788      bufcpy (s, sub_whole (p, n, length), size);
1789      if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
1790        (void) error_chars (s, VALUE (&width));
1791      } else {
1792        if (x < 0) {
1793          (void) plusto ('-', s);
1794        } else if (VALUE (&width) > 0) {
1795          (void) plusto ('+', s);
1796        }
1797        if (VALUE (&width) != 0) {
1798          (void) leading_spaces (s, ABS (VALUE (&width)));
1799        }
1800      }
1801      return s;
1802    }
1803  #if (A68_LEVEL >= 3)
1804    if (mode == M_LONG_INT) {
1805      DOUBLE_NUM_T x = VALUE ((A68_LONG_INT *) (STACK_OFFSET (A68_UNION_SIZE))), n, ten;
1806      set_lw (ten, 10);
1807      n = abs_double_int (x);
1808      int length = ABS (VALUE (&width)) - (D_NEG (x) || VALUE (&width) > 0 ? 1 : 0);
1809      int size = (D_NEG (x) ? 1 : (VALUE (&width) > 0 ? 1 : 0));
1810      if (VALUE (&width) == 0) {
1811        DOUBLE_NUM_T m = n;
1812        length = 0;
1813        while ((m = double_udiv (p, M_LONG_INT, m, ten, 0), length++, !D_ZERO (m))) {
1814          ;
1815        }
1816      }
1817      size += length;
1818      size = 8 + (size > VALUE (&width) ? size : VALUE (&width));
1819      char *s = stack_string (p, size);
1820      bufcpy (s, long_sub_whole_double (p, n, length), size);
1821      if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
1822        (void) error_chars (s, VALUE (&width));
1823      } else {
1824        if (D_NEG (x)) {
1825          (void) plusto ('-', s);
1826        } else if (VALUE (&width) > 0) {
1827          (void) plusto ('+', s);
1828        }
1829        if (VALUE (&width) != 0) {
1830          (void) leading_spaces (s, ABS (VALUE (&width)));
1831        }
1832      }
1833      return s;
1834    }
1835  #endif
1836    if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
1837      int digits = DIGITS (mode);
1838      MP_T *n = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
1839      A68_SP = arg_sp;            // We keep the mp where it's at
1840      if (MP_EXPONENT (n) >= (MP_T) digits) {
1841        int max_length = (mode == M_LONG_INT ? LONG_INT_WIDTH : LONG_LONG_INT_WIDTH);
1842        int length = (VALUE (&width) == 0 ? max_length : VALUE (&width));
1843        char *s = stack_string (p, 1 + length);
1844        (void) error_chars (s, length);
1845        return s;
1846      }
1847      BOOL_T ltz = (BOOL_T) (MP_DIGIT (n, 1) < 0);
1848      int length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
1849      int size = (ltz ? 1 : (VALUE (&width) > 0 ? 1 : 0));
1850      MP_DIGIT (n, 1) = ABS (MP_DIGIT (n, 1));
1851      if (VALUE (&width) == 0) {
1852        MP_T *m = nil_mp (p, digits);
1853        (void) move_mp (m, n, digits);
1854        length = 0;
1855        while ((over_mp_digit (p, m, m, (MP_T) 10, digits), length++, MP_DIGIT (m, 1) != 0)) {
1856          ;
1857        }
1858      }
1859      size += length;
1860      size = 8 + (size > VALUE (&width) ? size : VALUE (&width));
1861      char *s = stack_string (p, size);
1862      bufcpy (s, long_sub_whole (p, n, digits, length), size);
1863      if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
1864        (void) error_chars (s, VALUE (&width));
1865      } else {
1866        if (ltz) {
1867          (void) plusto ('-', s);
1868        } else if (VALUE (&width) > 0) {
1869          (void) plusto ('+', s);
1870        }
1871        if (VALUE (&width) != 0) {
1872          (void) leading_spaces (s, ABS (VALUE (&width)));
1873        }
1874      }
1875      return s;
1876    }
1877    if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
1878      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1879      PUSH_VALUE (p, VALUE (&width), A68_INT);
1880      PUSH_VALUE (p, 0, A68_INT);
1881      return fixed (p);
1882    }
1883    return NO_TEXT;
1884  }
1885  
1886  //! @brief Fetch next digit from LONG.
1887  
1888  char long_choose_dig (NODE_T * p, MP_T * y, int digits)
1889  {
1890  // Assuming positive "y".
1891    ADDR_T pop_sp = A68_SP;
1892    (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
1893    int c = MP_EXPONENT (y) == 0 ? (MP_INT_T) MP_DIGIT (y, 1) : 0;
1894    if (c > 9) {
1895      c = 9;
1896    }
1897    MP_T *t = lit_mp (p, c, 0, digits);
1898    (void) sub_mp (p, y, y, t, digits);
1899  // Reset the stack to prevent overflow, there may be many digits.
1900    A68_SP = pop_sp;
1901    return digchar (c);
1902  }
1903  
1904  //! @brief Standard string for LONG.
1905  
1906  char *long_sub_fixed (NODE_T * p, MP_T * x, int digits, int width, int after)
1907  {
1908    ADDR_T pop_sp = A68_SP;
1909    MP_T *y = nil_mp (p, digits);
1910    MP_T *s = nil_mp (p, digits);
1911    MP_T *t = nil_mp (p, digits);
1912    (void) ten_up_mp (p, t, -after, digits);
1913    (void) half_mp (p, t, t, digits);
1914    (void) add_mp (p, y, x, t, digits);
1915    int before = 0;
1916  // Not RR - argument reduction.
1917    while (MP_EXPONENT (y) > 1) {
1918      int k = (int) round (MP_EXPONENT (y) - 1);
1919      MP_EXPONENT (y) -= k;
1920      before += k * LOG_MP_RADIX;
1921    }
1922  // Follow RR again.
1923    SET_MP_ONE (s, digits);
1924    while ((sub_mp (p, t, y, s, digits), MP_DIGIT (t, 1) >= 0)) {
1925      before++;
1926      (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
1927    }
1928  // Compose the number.
1929    if (before + after + (after > 0 ? 1 : 0) > width) {
1930      char *str = stack_string (p, width + 1);
1931      (void) error_chars (str, width);
1932      A68_SP = pop_sp;
1933      return str;
1934    }
1935    int strwid = 8 + before + after;
1936    char *str = stack_string (p, strwid);
1937    str[0] = NULL_CHAR;
1938    int j, len = 0;
1939    for (j = 0; j < before; j++) {
1940      char ch = (char) (len < LONG_LONG_REAL_WIDTH ? long_choose_dig (p, y, digits) : '0');
1941      (void) string_plusab_char (str, ch, strwid);
1942      len++;
1943    }
1944    if (after > 0) {
1945      (void) string_plusab_char (str, POINT_CHAR, strwid);
1946    }
1947    for (j = 0; j < after; j++) {
1948      char ch = (char) (len < LONG_LONG_REAL_WIDTH ? long_choose_dig (p, y, digits) : '0');
1949      (void) string_plusab_char (str, ch, strwid);
1950      len++;
1951    }
1952    if ((int) strlen (str) > width) {
1953      (void) error_chars (str, width);
1954    }
1955    A68_SP = pop_sp;
1956    return str;
1957  }
1958  
1959  #if (A68_LEVEL >= 3)
1960  
1961  //! @brief Fetch next digit from REAL.
1962  
1963  char choose_dig_double (DOUBLE_T * y)
1964  {
1965  // Assuming positive "y".
1966    int c = (int) (*y *= 10);
1967    if (c > 9) {
1968      c = 9;
1969    }
1970    *y -= c;
1971    return digchar (c);
1972  }
1973  
1974  #endif
1975  
1976  #if (A68_LEVEL >= 3)
1977  
1978  //! @brief Standard string for REAL.
1979  
1980  char *sub_fixed_double (NODE_T * p, DOUBLE_T x, int width, int after, int precision)
1981  {
1982    ABEND (x < 0, ERROR_INTERNAL_CONSISTENCY, __func__);
1983  // Round and scale. 
1984    DOUBLE_T z = x + 0.5q * ten_up_double (-after);
1985    DOUBLE_T y = z;
1986    int before = 0;
1987  // Not according RR - argument reduction to avoid long division loop.
1988    if (z >= 1.0e10q) {          // Arbitrary, log10 must be worthwhile.
1989      before = (int) floorq (log10q (z)) - 1;
1990      z /= ten_up_double (before);
1991    }
1992  // Follow RR again.
1993    while (z >= 1.0q) {
1994      before++;
1995      z /= 10.0q;
1996    }
1997  // Scale number.
1998    y /= ten_up_double (before);
1999  // Put digits, prevent garbage from overstretching precision.
2000  // Many languages produce garbage when specifying more decimals 
2001  // than the type actually has. A68G pads '0's in this case.
2002  // That is just as arbitrary, but at least recognisable.
2003    int strwid = 8 + before + after;      // A bit too long.
2004    char *str = stack_string (p, strwid);
2005    int len = 0;
2006    for (int j = 0; j < before; j++) {
2007      char ch = (char) (len < precision ? choose_dig_double (&y) : '0');
2008      (void) string_plusab_char (str, ch, strwid);
2009      len++;
2010    }
2011    if (after > 0) {
2012      (void) string_plusab_char (str, POINT_CHAR, strwid);
2013    }
2014    for (int j = 0; j < after; j++) {
2015      char ch = (char) (len < precision ? choose_dig_double (&y) : '0');
2016      (void) string_plusab_char (str, ch, strwid);
2017      len++;
2018    }
2019    if ((int) strlen (str) > width) {
2020      (void) error_chars (str, width);
2021    }
2022    return str;
2023  }
2024  
2025  //! @brief Standard string for REAL.
2026  
2027  char *sub_fixed (NODE_T * p, REAL_T x, int width, int after)
2028  {
2029  // Better precision than the REAL only routine
2030    return sub_fixed_double (p, (DOUBLE_T) x, width, after, REAL_WIDTH);
2031  }
2032  
2033  #else
2034  
2035  //! @brief Fetch next digit from REAL.
2036  
2037  char choose_dig (REAL_T * y)
2038  {
2039  // Assuming positive "y".
2040    int c = (int) (*y *= 10);
2041    if (c > 9) {
2042      c = 9;
2043    }
2044    *y -= c;
2045    return digchar (c);
2046  }
2047  
2048  //! @brief Standard string for REAL.
2049  
2050  char *sub_fixed (NODE_T * p, REAL_T x, int width, int after)
2051  {
2052    ABEND (x < 0, ERROR_INTERNAL_CONSISTENCY, __func__);
2053  // Round and scale. 
2054    REAL_T z = x + 0.5 * ten_up (-after);
2055    REAL_T y = z;
2056    int before = 0;
2057  // Not according RR - argument reduction to avoid long division loop.
2058    if (z >= 1.0e10) {            // Arbitrary, log10 must be worthwhile.
2059      before = (int) floor (log10 (z)) - 1;
2060      z /= ten_up (before);
2061    }
2062  // Follow RR again.
2063    while (z >= 1.0) {
2064      before++;
2065      z /= 10.0;
2066    }
2067  // Scale number.
2068    y /= ten_up (before);
2069  // Put digits, prevent garbage from overstretching precision.
2070  // Many languages produce garbage when specifying more decimals 
2071  // than the type actually has. A68G pads '0's in this case.
2072  // That is just as arbitrary, but at least recognisable.
2073    int strwid = 8 + before + after;      // A bit too long.
2074    char *str = stack_string (p, strwid);
2075    int len = 0;
2076    for (int j = 0; j < before; j++) {
2077      char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0');
2078      (void) string_plusab_char (str, ch, strwid);
2079      len++;
2080    }
2081    if (after > 0) {
2082      (void) string_plusab_char (str, POINT_CHAR, strwid);
2083    }
2084    for (int j = 0; j < after; j++) {
2085      char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0');
2086      (void) string_plusab_char (str, ch, strwid);
2087      len++;
2088    }
2089    if ((int) strlen (str) > width) {
2090      (void) error_chars (str, width);
2091    }
2092    return str;
2093  }
2094  
2095  #endif
2096  
2097  //! @brief Formatted string for NUMBER.
2098  
2099  char *fixed (NODE_T * p)
2100  {
2101    A68_INT width, after;
2102    POP_OBJECT (p, &after, A68_INT);
2103    POP_OBJECT (p, &width, A68_INT);
2104    CHECK_INT_SHORTEN (p, VALUE (&after));
2105    CHECK_INT_SHORTEN (p, VALUE (&width));
2106    ADDR_T arg_sp = A68_SP;
2107    DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2108    MOID_T *mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
2109    ADDR_T pop_sp = A68_SP;
2110    if (mode == M_REAL) {
2111      REAL_T x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE)));
2112      int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0);
2113      CHECK_REAL (p, x);
2114      A68_SP = arg_sp;
2115      if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
2116        REAL_T y = ABS (x);
2117        if (VALUE (&width) == 0) {
2118          length = (VALUE (&after) == 0 ? 1 : 0);
2119          REAL_T z0 = ten_up (-VALUE (&after)), z1 = ten_up (length);
2120          while (y + 0.5 * z0 > z1) {
2121            length++;
2122            z1 *= 10.0;
2123          }
2124          length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
2125        }
2126        char *s = sub_fixed (p, y, length, VALUE (&after));
2127        if (strchr (s, ERROR_CHAR) == NO_TEXT) {
2128          if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && y < 1.0) {
2129            (void) plusto ('0', s);
2130          }
2131          if (x < 0) {
2132            (void) plusto ('-', s);
2133          } else if (VALUE (&width) > 0) {
2134            (void) plusto ('+', s);
2135          }
2136          if (VALUE (&width) != 0) {
2137            (void) leading_spaces (s, ABS (VALUE (&width)));
2138          }
2139          return s;
2140        } else if (VALUE (&after) > 0) {
2141          A68_SP = arg_sp;
2142          PUSH_VALUE (p, VALUE (&width), A68_INT);
2143          PUSH_VALUE (p, VALUE (&after) - 1, A68_INT);
2144          return fixed (p);
2145        } else {
2146          return error_chars (s, VALUE (&width));
2147        }
2148      } else {
2149        char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2150        return error_chars (s, VALUE (&width));
2151      }
2152    }
2153  #if (A68_LEVEL >= 3)
2154    if (mode == M_LONG_REAL) {
2155      DOUBLE_T x = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE))).f;
2156      int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0);
2157      CHECK_DOUBLE_REAL (p, x);
2158      A68_SP = arg_sp;
2159      if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
2160        DOUBLE_T y = ABS (x);
2161        if (VALUE (&width) == 0) {
2162          length = (VALUE (&after) == 0 ? 1 : 0);
2163          DOUBLE_T z0 = ten_up_double (-VALUE (&after)), z1 = ten_up_double (length);
2164          while (y + 0.5 * z0 > z1) {
2165            length++;
2166            z1 *= 10.0;
2167          }
2168          length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
2169        }
2170        char *s = sub_fixed_double (p, y, length, VALUE (&after), LONG_REAL_WIDTH);
2171        if (strchr (s, ERROR_CHAR) == NO_TEXT) {
2172          if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && y < 1.0) {
2173            (void) plusto ('0', s);
2174          }
2175          if (x < 0) {
2176            (void) plusto ('-', s);
2177          } else if (VALUE (&width) > 0) {
2178            (void) plusto ('+', s);
2179          }
2180          if (VALUE (&width) != 0) {
2181            (void) leading_spaces (s, ABS (VALUE (&width)));
2182          }
2183          return s;
2184        } else if (VALUE (&after) > 0) {
2185          A68_SP = arg_sp;
2186          PUSH_VALUE (p, VALUE (&width), A68_INT);
2187          PUSH_VALUE (p, VALUE (&after) - 1, A68_INT);
2188          return fixed (p);
2189        } else {
2190          return error_chars (s, VALUE (&width));
2191        }
2192      } else {
2193        char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2194        return error_chars (s, VALUE (&width));
2195      }
2196    }
2197  #endif
2198    if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2199      int digits = DIGITS (mode);
2200      MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
2201      A68_SP = arg_sp;
2202      BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
2203      MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
2204      int length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
2205      if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
2206        MP_T *z0 = nil_mp (p, digits);
2207        MP_T *z1 = nil_mp (p, digits);
2208        MP_T *t = nil_mp (p, digits);
2209        if (VALUE (&width) == 0) {
2210          length = (VALUE (&after) == 0 ? 1 : 0);
2211          (void) set_mp (z0, (MP_T) (MP_RADIX / 10), -1, digits);
2212          (void) set_mp (z1, (MP_T) 10, 0, digits);
2213          (void) pow_mp_int (p, z0, z0, VALUE (&after), digits);
2214          (void) pow_mp_int (p, z1, z1, length, digits);
2215          while ((div_mp_digit (p, t, z0, (MP_T) 2, digits), add_mp (p, t, x, t, digits), sub_mp (p, t, t, z1, digits), MP_DIGIT (t, 1) > 0)) {
2216            length++;
2217            (void) mul_mp_digit (p, z1, z1, (MP_T) 10, digits);
2218          }
2219          length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
2220        }
2221  //    char *s = stack_string (p, 8 + length);
2222        char *s = long_sub_fixed (p, x, digits, length, VALUE (&after));
2223        if (strchr (s, ERROR_CHAR) == NO_TEXT) {
2224          if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && (MP_EXPONENT (x) < 0 || MP_DIGIT (x, 1) == 0)) {
2225            (void) plusto ('0', s);
2226          }
2227          if (ltz) {
2228            (void) plusto ('-', s);
2229          } else if (VALUE (&width) > 0) {
2230            (void) plusto ('+', s);
2231          }
2232          if (VALUE (&width) != 0) {
2233            (void) leading_spaces (s, ABS (VALUE (&width)));
2234          }
2235          return s;
2236        } else if (VALUE (&after) > 0) {
2237          A68_SP = arg_sp;
2238          MP_DIGIT (x, 1) = ltz ? -ABS (MP_DIGIT (x, 1)) : ABS (MP_DIGIT (x, 1));
2239          PUSH_VALUE (p, VALUE (&width), A68_INT);
2240          PUSH_VALUE (p, VALUE (&after) - 1, A68_INT);
2241          return fixed (p);
2242        } else {
2243          return error_chars (s, VALUE (&width));
2244        }
2245      } else {
2246        char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2247        return error_chars (s, VALUE (&width));
2248      }
2249    }
2250    if (mode == M_INT) {
2251      int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
2252      PUSH_UNION (p, M_REAL);
2253      PUSH_VALUE (p, (REAL_T) x, A68_REAL);
2254      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
2255      PUSH_VALUE (p, VALUE (&width), A68_INT);
2256      PUSH_VALUE (p, VALUE (&after), A68_INT);
2257      return fixed (p);
2258    }
2259    if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2260      A68_SP = pop_sp;
2261      if (mode == M_LONG_INT) {
2262        VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_REAL;
2263      } else {
2264        VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL;
2265      } INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2266      PUSH_VALUE (p, VALUE (&width), A68_INT);
2267      PUSH_VALUE (p, VALUE (&after), A68_INT);
2268      return fixed (p);
2269    }
2270    return NO_TEXT;
2271  }
2272  
2273  //! @brief Scale LONG for formatting.
2274  
2275  void long_standardise (NODE_T * p, MP_T * y, int digits, int before, int after, int *q)
2276  {
2277    ADDR_T pop_sp = A68_SP;
2278    MP_T *f = nil_mp (p, digits);
2279    MP_T *g = nil_mp (p, digits);
2280    MP_T *h = nil_mp (p, digits);
2281    MP_T *t = nil_mp (p, digits);
2282    ten_up_mp (p, g, before, digits);
2283    (void) div_mp_digit (p, h, g, (MP_T) 10, digits);
2284  // Speed huge exponents.
2285    if ((MP_EXPONENT (y) - MP_EXPONENT (g)) > 1) {
2286      (*q) += LOG_MP_RADIX * ((int) MP_EXPONENT (y) - (int) MP_EXPONENT (g) - 1);
2287      MP_EXPONENT (y) = MP_EXPONENT (g) + 1;
2288    }
2289    while ((sub_mp (p, t, y, g, digits), MP_DIGIT (t, 1) >= 0)) {
2290      (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
2291      (*q)++;
2292    }
2293    if (MP_DIGIT (y, 1) != 0) {
2294  // Speed huge exponents.
2295      if ((MP_EXPONENT (y) - MP_EXPONENT (h)) < -1) {
2296        (*q) -= LOG_MP_RADIX * ((int) MP_EXPONENT (h) - (int) MP_EXPONENT (y) - 1);
2297        MP_EXPONENT (y) = MP_EXPONENT (h) - 1;
2298      }
2299      while ((sub_mp (p, t, y, h, digits), MP_DIGIT (t, 1) < 0)) {
2300        (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
2301        (*q)--;
2302      }
2303    }
2304    ten_up_mp (p, f, -after, digits);
2305    (void) div_mp_digit (p, t, f, (MP_T) 2, digits);
2306    (void) add_mp (p, t, y, t, digits);
2307    (void) sub_mp (p, t, t, g, digits);
2308    if (MP_DIGIT (t, 1) >= 0) {
2309      (void) move_mp (y, h, digits);
2310      (*q)++;
2311    }
2312    A68_SP = pop_sp;
2313  }
2314  
2315  #if (A68_LEVEL >= 3)
2316  
2317  //! @brief Scale REAL for formatting.
2318  
2319  void standardise_double (DOUBLE_T * y, int before, int after, int *p)
2320  {
2321  //int j; g = 1.0q; for (j = 0; j < before; j++) { g *= 10.0q; }
2322    DOUBLE_T g = ten_up_double (before);
2323    DOUBLE_T h = g / 10.0q;
2324    while (*y >= g) {
2325      *y *= 0.1q;
2326      (*p)++;
2327    }
2328    if (*y != 0.0q) {
2329      while (*y < h) {
2330        *y *= 10.0q;
2331        (*p)--;
2332      }
2333    }
2334  //f = 1.0q; for (j = 0; j < after; j++) { f *= 0.1q; }
2335    DOUBLE_T f = ten_up_double (-after);
2336    if (*y + 0.5q * f >= g) {
2337      *y = h;
2338      (*p)++;
2339    }
2340  }
2341  
2342  //! @brief Scale REAL for formatting.
2343  
2344  void standardise (REAL_T * y, int before, int after, int *p)
2345  {
2346  // Better precision than the REAL only routine
2347    DOUBLE_T z = (DOUBLE_T) * y;
2348    standardise_double (&z, before, after, p);
2349    *y = (REAL_T) z;
2350  }
2351  
2352  #else
2353  
2354  //! @brief Scale REAL for formatting.
2355  
2356  void standardise (REAL_T * y, int before, int after, int *p)
2357  {
2358  // This according RR, but for REAL the last digits are approximate.
2359  // A68G 3 uses DOUBLE precision version.
2360  //
2361  //int j; g = 1.0; for (j = 0; j < before; j++) { g *= 10.0; }
2362    REAL_T g = ten_up (before);
2363    REAL_T h = g / 10.0;
2364    while (*y >= g) {
2365      *y *= 0.1;
2366      (*p)++;
2367    }
2368    if (*y != 0.0) {
2369      while (*y < h) {
2370        *y *= 10.0;
2371        (*p)--;
2372      }
2373    }
2374  //f = 1.0; for (j = 0; j < after; j++) { f *= 0.1; }
2375    REAL_T f = ten_up (-after);
2376    if (*y + 0.5 * f >= g) {
2377      *y = h;
2378      (*p)++;
2379    }
2380  }
2381  
2382  #endif
2383  
2384  //! @brief Formatted string for NUMBER.
2385  
2386  char *real (NODE_T * p)
2387  {
2388  // POP arguments.
2389    A68_INT width, after, expo, frmt;
2390    POP_OBJECT (p, &frmt, A68_INT);
2391    POP_OBJECT (p, &expo, A68_INT);
2392    POP_OBJECT (p, &after, A68_INT);
2393    POP_OBJECT (p, &width, A68_INT);
2394    CHECK_INT_SHORTEN (p, VALUE (&frmt));
2395    CHECK_INT_SHORTEN (p, VALUE (&expo));
2396    CHECK_INT_SHORTEN (p, VALUE (&after));
2397    CHECK_INT_SHORTEN (p, VALUE (&width));
2398    ADDR_T arg_sp = A68_SP;
2399    DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2400    MOID_T *mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
2401    ADDR_T pop_sp = A68_SP;
2402    if (mode == M_REAL) {
2403      REAL_T x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE)));
2404      int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
2405      A68_SP = arg_sp;
2406      CHECK_REAL (p, x);
2407      if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
2408        REAL_T y = ABS (x);
2409        int q = 0;
2410        standardise (&y, before, VALUE (&after), &q);
2411        if (VALUE (&frmt) > 0) {
2412          while (q % VALUE (&frmt) != 0) {
2413            y *= 10;
2414            q--;
2415            if (VALUE (&after) > 0) {
2416              VALUE (&after)--;
2417            }
2418          }
2419        } else {
2420          REAL_T upb = ten_up (-VALUE (&frmt)), lwb = ten_up (-VALUE (&frmt) - 1);
2421          while (y < lwb) {
2422            y *= 10;
2423            q--;
2424            if (VALUE (&after) > 0) {
2425              VALUE (&after)--;
2426            }
2427          }
2428          while (y > upb) {
2429            y /= 10;
2430            q++;
2431            if (VALUE (&after) > 0) {
2432              VALUE (&after)++;
2433            }
2434          }
2435        }
2436        PUSH_UNION (p, M_REAL);
2437        PUSH_VALUE (p, SIGN (x) * y, A68_REAL);
2438        INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
2439        PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT);
2440        PUSH_VALUE (p, VALUE (&after), A68_INT);
2441        char *t1 = fixed (p);
2442        PUSH_UNION (p, M_INT);
2443        PUSH_VALUE (p, q, A68_INT);
2444        INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT)));
2445        PUSH_VALUE (p, VALUE (&expo), A68_INT);
2446        char *t2 = whole (p);
2447        int strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2);
2448        char *s = stack_string (p, strwid);
2449        bufcpy (s, t1, strwid);
2450        (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
2451        bufcat (s, t2, strwid);
2452        if (VALUE (&expo) == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
2453          A68_SP = arg_sp;
2454          PUSH_VALUE (p, VALUE (&width), A68_INT);
2455          PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT);
2456          PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT);
2457          PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2458          return real (p);
2459        } else {
2460          return s;
2461        }
2462      } else {
2463        char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2464        return error_chars (s, VALUE (&width));
2465      }
2466    }
2467  #if (A68_LEVEL >= 3)
2468    if (mode == M_LONG_REAL) {
2469      DOUBLE_T x = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE))).f;
2470      int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
2471      CHECK_DOUBLE_REAL (p, x);
2472      A68_SP = arg_sp;
2473      if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
2474        DOUBLE_T y = (x >= 0.0q ? x : -x);
2475        int q = 0;
2476        standardise_double (&y, before, VALUE (&after), &q);
2477        if (VALUE (&frmt) > 0) {
2478          while (q % VALUE (&frmt) != 0) {
2479            y *= 10.0q;
2480            q--;
2481            if (VALUE (&after) > 0) {
2482              VALUE (&after)--;
2483            }
2484          }
2485        } else {
2486          DOUBLE_T upb = ten_up_double (-VALUE (&frmt)), lwb = ten_up_double (-VALUE (&frmt) - 1);
2487          while (y < lwb) {
2488            y *= 10.0q;
2489            q--;
2490            if (VALUE (&after) > 0) {
2491              VALUE (&after)--;
2492            }
2493          }
2494          while (y > upb) {
2495            y /= 10.0q;
2496            q++;
2497            if (VALUE (&after) > 0) {
2498              VALUE (&after)++;
2499            }
2500          }
2501        }
2502        PUSH_UNION (p, M_LONG_REAL);
2503        {
2504          DOUBLE_NUM_T d;
2505          d.f = (x >= 0.0q ? y : -y);
2506          PUSH_VALUE (p, d, A68_LONG_REAL);
2507        }
2508        INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL)));
2509        PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT);
2510        PUSH_VALUE (p, VALUE (&after), A68_INT);
2511        char *t1 = fixed (p);
2512        PUSH_UNION (p, M_INT);
2513        PUSH_VALUE (p, q, A68_INT);
2514        INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT)));
2515        PUSH_VALUE (p, VALUE (&expo), A68_INT);
2516        char *t2 = whole (p);
2517        int strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2);
2518        char *s = stack_string (p, strwid);
2519        bufcpy (s, t1, strwid);
2520        (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
2521        bufcat (s, t2, strwid);
2522        if (VALUE (&expo) == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
2523          A68_SP = arg_sp;
2524          PUSH_VALUE (p, VALUE (&width), A68_INT);
2525          PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT);
2526          PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT);
2527          PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2528          return real (p);
2529        } else {
2530          return s;
2531        }
2532      } else {
2533        char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2534        return error_chars (s, VALUE (&width));
2535      }
2536    }
2537  #endif
2538    if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2539      int digits = DIGITS (mode);
2540      int before;
2541      MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
2542      CHECK_LONG_REAL (p, x, mode);
2543      BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
2544      A68_SP = arg_sp;
2545      MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
2546      before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
2547      if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
2548        int q = 0;
2549        size_t N_mp = SIZE_MP (digits);
2550        MP_T *z = nil_mp (p, digits);
2551        (void) move_mp (z, x, digits);
2552        long_standardise (p, z, digits, before, VALUE (&after), &q);
2553        if (VALUE (&frmt) > 0) {
2554          while (q % VALUE (&frmt) != 0) {
2555            (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
2556            q--;
2557            if (VALUE (&after) > 0) {
2558              VALUE (&after)--;
2559            }
2560          }
2561        } else {
2562          ADDR_T sp1 = A68_SP;
2563          MP_T *dif = nil_mp (p, digits);
2564          MP_T *lim = nil_mp (p, digits);
2565          (void) ten_up_mp (p, lim, -VALUE (&frmt) - 1, digits);
2566          (void) sub_mp (p, dif, z, lim, digits);
2567          while (MP_DIGIT (dif, 1) < 0) {
2568            (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
2569            q--;
2570            if (VALUE (&after) > 0) {
2571              VALUE (&after)--;
2572            }
2573            (void) sub_mp (p, dif, z, lim, digits);
2574          }
2575          (void) mul_mp_digit (p, lim, lim, (MP_T) 10, digits);
2576          (void) sub_mp (p, dif, z, lim, digits);
2577          while (MP_DIGIT (dif, 1) > 0) {
2578            (void) div_mp_digit (p, z, z, (MP_T) 10, digits);
2579            q++;
2580            if (VALUE (&after) > 0) {
2581              VALUE (&after)++;
2582            }
2583            (void) sub_mp (p, dif, z, lim, digits);
2584          }
2585          A68_SP = sp1;
2586        }
2587        PUSH_UNION (p, mode);
2588        MP_DIGIT (z, 1) = (ltz ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1));
2589        PUSH (p, z, N_mp);
2590        INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE_MP (digits)));
2591        PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT);
2592        PUSH_VALUE (p, VALUE (&after), A68_INT);
2593        char *t1 = fixed (p);
2594        PUSH_UNION (p, M_INT);
2595        PUSH_VALUE (p, q, A68_INT);
2596        INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT)));
2597        PUSH_VALUE (p, VALUE (&expo), A68_INT);
2598        char *t2 = whole (p);
2599        int strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2);
2600        char *s = stack_string (p, strwid);
2601        bufcpy (s, t1, strwid);
2602        (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
2603        bufcat (s, t2, strwid);
2604        if (VALUE (&expo) == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
2605          A68_SP = arg_sp;
2606          PUSH_VALUE (p, VALUE (&width), A68_INT);
2607          PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT);
2608          PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT);
2609          PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2610          return real (p);
2611        } else {
2612          return s;
2613        }
2614      } else {
2615        char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2616        return error_chars (s, VALUE (&width));
2617      }
2618    }
2619    if (mode == M_INT) {
2620      int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
2621      PUSH_UNION (p, M_REAL);
2622      PUSH_VALUE (p, (REAL_T) x, A68_REAL);
2623      INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
2624      PUSH_VALUE (p, VALUE (&width), A68_INT);
2625      PUSH_VALUE (p, VALUE (&after), A68_INT);
2626      PUSH_VALUE (p, VALUE (&expo), A68_INT);
2627      PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2628      return real (p);
2629    }
2630    if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2631      A68_SP = pop_sp;
2632      if (mode == M_LONG_INT) {
2633        VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_REAL;
2634      } else {
2635        VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL;
2636      } INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2637      PUSH_VALUE (p, VALUE (&width), A68_INT);
2638      PUSH_VALUE (p, VALUE (&after), A68_INT);
2639      PUSH_VALUE (p, VALUE (&expo), A68_INT);
2640      PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2641      return real (p);
2642    }
2643    return NO_TEXT;
2644  }
2645  
2646  //! @brief PROC (NUMBER, INT) STRING whole
2647  
2648  void genie_whole (NODE_T * p)
2649  {
2650    ADDR_T pop_sp = A68_SP;
2651    char *str = whole (p);
2652    A68_SP = pop_sp - SIZE (M_INT) - SIZE (M_NUMBER);
2653    A68_REF ref = tmp_to_a68_string (p, str);
2654    PUSH_REF (p, ref);
2655  }
2656  
2657  //! @brief PROC (NUMBER, INT, INT) STRING bits 
2658  
2659  void genie_bits (NODE_T * p)
2660  {
2661    ADDR_T pop_sp = A68_SP;
2662    char *str = bits (p);
2663    A68_SP = pop_sp - 2 * SIZE (M_INT) - SIZE (M_HEX_NUMBER);
2664    A68_REF ref = tmp_to_a68_string (p, str);
2665    PUSH_REF (p, ref);
2666  }
2667  
2668  //! @brief PROC (NUMBER, INT, INT) STRING fixed
2669  
2670  void genie_fixed (NODE_T * p)
2671  {
2672    ADDR_T pop_sp = A68_SP;
2673    char *str = fixed (p);
2674    A68_SP = pop_sp - 2 * SIZE (M_INT) - SIZE (M_NUMBER);
2675    A68_REF ref = tmp_to_a68_string (p, str);
2676    PUSH_REF (p, ref);
2677  }
2678  
2679  //! @brief PROC (NUMBER, INT, INT, INT) STRING eng
2680  
2681  void genie_real (NODE_T * p)
2682  {
2683    ADDR_T pop_sp = A68_SP;
2684    char *str = real (p);
2685    A68_SP = pop_sp - 4 * SIZE (M_INT) - SIZE (M_NUMBER);
2686    A68_REF ref = tmp_to_a68_string (p, str);
2687    PUSH_REF (p, ref);
2688  }
2689  
2690  //! @brief PROC (NUMBER, INT, INT, INT) STRING float
2691  
2692  void genie_float (NODE_T * p)
2693  {
2694    PUSH_VALUE (p, 1, A68_INT);
2695    genie_real (p);
2696  }
2697  
2698  // ALGOL68C routines.
2699  
2700  //! @def A68C_TRANSPUT
2701  //! @brief Generate Algol68C routines readint, getint, etcetera.
2702  
2703  #define A68C_TRANSPUT(n, m)\
2704   void genie_get_##n (NODE_T * p)\
2705    {\
2706      A68_REF ref_file;\
2707      POP_REF (p, &ref_file);\
2708      CHECK_REF (p, ref_file, M_REF_FILE);\
2709      BYTE_T *z = STACK_TOP;\
2710      INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
2711      ADDR_T pop_sp = A68_SP;\
2712      open_for_reading (p, ref_file);\
2713      genie_read_standard (p, MODE (m), z, ref_file);\
2714      A68_SP = pop_sp;\
2715    }\
2716  \
2717    void genie_put_##n (NODE_T * p)\
2718    {\
2719      int size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\
2720      A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\
2721      CHECK_REF (p, ref_file, M_REF_FILE);\
2722      reset_transput_buffer (UNFORMATTED_BUFFER);\
2723      open_for_writing (p, ref_file);\
2724      genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
2725      write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
2726      DECREMENT_STACK_POINTER (p, size + sizf);\
2727    }\
2728  \
2729    void genie_read_##n (NODE_T * p)\
2730    {\
2731      BYTE_T *z = STACK_TOP;\
2732      INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
2733      ADDR_T pop_sp = A68_SP;\
2734      open_for_reading (p, A68 (stand_in));\
2735      genie_read_standard (p, MODE (m), z, A68 (stand_in));\
2736      A68_SP = pop_sp;\
2737    }\
2738  \
2739    void genie_print_##n (NODE_T * p)\
2740    {\
2741      int size = SIZE (MODE (m));\
2742      reset_transput_buffer (UNFORMATTED_BUFFER);\
2743      open_for_writing (p, A68 (stand_out));\
2744      genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68 (stand_out));\
2745      write_purge_buffer (p, A68 (stand_out), UNFORMATTED_BUFFER);\
2746      DECREMENT_STACK_POINTER (p, size);\
2747    }
2748  
2749  A68C_TRANSPUT (int, INT);
2750  A68C_TRANSPUT (long_int, LONG_INT);
2751  A68C_TRANSPUT (long_mp_int, LONG_LONG_INT);
2752  A68C_TRANSPUT (real, REAL);
2753  A68C_TRANSPUT (long_real, LONG_REAL);
2754  A68C_TRANSPUT (long_mp_real, LONG_LONG_REAL);
2755  A68C_TRANSPUT (bits, BITS);
2756  A68C_TRANSPUT (long_bits, LONG_BITS);
2757  A68C_TRANSPUT (long_mp_bits, LONG_LONG_BITS);
2758  A68C_TRANSPUT (bool, BOOL);
2759  A68C_TRANSPUT (char, CHAR);
2760  A68C_TRANSPUT (string, STRING);
2761  
2762  #undef A68C_TRANSPUT
2763  
2764  #define A68C_TRANSPUT(n, s, m)\
2765   void genie_get_##n (NODE_T * p) {\
2766      A68_REF ref_file;\
2767      POP_REF (p, &ref_file);\
2768      CHECK_REF (p, ref_file, M_REF_FILE);\
2769      PUSH_REF (p, ref_file);\
2770      genie_get_##s (p);\
2771      PUSH_REF (p, ref_file);\
2772      genie_get_##s (p);\
2773    }\
2774    void genie_put_##n (NODE_T * p) {\
2775      int size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\
2776      A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\
2777      CHECK_REF (p, ref_file, M_REF_FILE);\
2778      reset_transput_buffer (UNFORMATTED_BUFFER);\
2779      open_for_writing (p, ref_file);\
2780      genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
2781      write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
2782      DECREMENT_STACK_POINTER (p, size + sizf);\
2783    }\
2784    void genie_read_##n (NODE_T * p) {\
2785      genie_read_##s (p);\
2786      genie_read_##s (p);\
2787    }\
2788    void genie_print_##n (NODE_T * p) {\
2789      int size = SIZE (MODE (m));\
2790      reset_transput_buffer (UNFORMATTED_BUFFER);\
2791      open_for_writing (p, A68 (stand_out));\
2792      genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68 (stand_out));\
2793      write_purge_buffer (p, A68 (stand_out), UNFORMATTED_BUFFER);\
2794      DECREMENT_STACK_POINTER (p, size);\
2795    }
2796  
2797  A68C_TRANSPUT (complex, real, COMPLEX);
2798  A68C_TRANSPUT (mp_complex, long_real, LONG_COMPLEX);
2799  A68C_TRANSPUT (long_mp_complex, long_mp_real, LONG_LONG_COMPLEX);
2800  
2801  #undef A68C_TRANSPUT
2802  
2803  //! @brief PROC STRING read line
2804  
2805  void genie_read_line (NODE_T * p)
2806  {
2807  #if defined (HAVE_READLINE)
2808    char *line = readline ("");
2809    if (line != NO_TEXT && (int) strlen (line) > 0) {
2810      add_history (line);
2811    }
2812    PUSH_REF (p, c_to_a_string (p, line, DEFAULT_WIDTH));
2813    a68_free (line);
2814  #else
2815    genie_read_string (p);
2816    genie_stand_in (p);
2817    genie_new_line (p);
2818  #endif
2819  }