rts-transput.c

     
   1  //! @file rts-transput.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-2025 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  //! Transput routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-prelude.h"
  29  #include "a68g-transput.h"
  30  
  31  // Transput - General routines and unformatted transput.
  32  // But Eeyore wasn't listening. He was taking the balloon out, and putting
  33  // it back again, as happy as could be ... Winnie the Pooh, A.A. Milne.
  34  // - Revised Report on the Algorithmic Language Algol 68.
  35  
  36  // File table handling 
  37  // In a table we record opened files.
  38  // When execution ends, unclosed files are closed, and temps are removed.
  39  // This keeps /tmp free of spurious files :-)
  40  
  41  //! @brief Init a file entry.
  42  
  43  void init_file_entry (int k)
  44  {
  45    if (k >= 0 && k < MAX_OPEN_FILES) {
  46      FILE_ENTRY *fe = &(A68G (file_entries)[k]);
  47      POS (fe) = NO_NODE;
  48      IS_OPEN (fe) = A68G_FALSE;
  49      IS_TMP (fe) = A68G_FALSE;
  50      FD (fe) = A68G_NO_FILE;
  51      IDF (fe) = nil_ref;
  52    }
  53  }
  54  
  55  //! @brief Initialise file entry table.
  56  
  57  void init_file_entries (void)
  58  {
  59    for (int k = 0; k < MAX_OPEN_FILES; k++) {
  60      init_file_entry (k);
  61    }
  62  }
  63  
  64  //! @brief Store file for later closing when not explicitly closed.
  65  
  66  int store_file_entry (NODE_T * p, FILE_T fd, char *idf, BOOL_T is_tmp)
  67  {
  68    for (int k = 0; k < MAX_OPEN_FILES; k++) {
  69      FILE_ENTRY *fe = &(A68G (file_entries)[k]);
  70      if (!IS_OPEN (fe)) {
  71        size_t len = 1 + strlen (idf);
  72        POS (fe) = p;
  73        IS_OPEN (fe) = A68G_TRUE;
  74        IS_TMP (fe) = is_tmp;
  75        FD (fe) = fd;
  76        IDF (fe) = heap_generator (p, M_C_STRING, len);
  77        BLOCK_GC_HANDLE (&(IDF (fe)));
  78        a68g_bufcpy (DEREF (char, &IDF (fe)), idf, len);
  79        return k;
  80      }
  81    }
  82    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES);
  83    exit_genie (p, A68G_RUNTIME_ERROR);
  84    return -1;
  85  }
  86  
  87  //! @brief Close file and delete temp file.
  88  
  89  void close_file_entry (NODE_T * p, int k)
  90  {
  91    if (k >= 0 && k < MAX_OPEN_FILES) {
  92      FILE_ENTRY *fe = &(A68G (file_entries)[k]);
  93      if (IS_OPEN (fe)) {
  94  // Close the file.
  95        if (FD (fe) != A68G_NO_FILE && close (FD (fe)) == -1) {
  96          init_file_entry (k);
  97          diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CLOSE);
  98          exit_genie (p, A68G_RUNTIME_ERROR);
  99        }
 100        IS_OPEN (fe) = A68G_FALSE;
 101      }
 102    }
 103  }
 104  
 105  //! @brief Close file and delete temp file.
 106  
 107  void free_file_entry (NODE_T * p, int k)
 108  {
 109    close_file_entry (p, k);
 110    if (k >= 0 && k < MAX_OPEN_FILES) {
 111      FILE_ENTRY *fe = &(A68G (file_entries)[k]);
 112      if (IS_OPEN (fe)) {
 113  // Attempt to remove a temp file, but ignore failure.
 114        if (FD (fe) != A68G_NO_FILE && IS_TMP (fe)) {
 115          if (!IS_NIL (IDF (fe))) {
 116            char *filename;
 117            CHECK_INIT (p, INITIALISED (&(IDF (fe))), M_ROWS);
 118            filename = DEREF (char, &IDF (fe));
 119            if (filename != NO_TEXT) {
 120              (void) remove (filename);
 121            }
 122          }
 123        }
 124  // Restore the fields.
 125        if (!IS_NIL (IDF (fe))) {
 126          UNBLOCK_GC_HANDLE (&(IDF (fe)));
 127        }
 128        init_file_entry (k);
 129      }
 130    }
 131  }
 132  
 133  //! @brief Close all files and delete all temp files.
 134  
 135  void free_file_entries (void)
 136  {
 137    for (int k = 0; k < MAX_OPEN_FILES; k++) {
 138      free_file_entry (NO_NODE, k);
 139    }
 140  }
 141  
 142  // Strings in transput are of arbitrary size. For this, we have transput buffers.
 143  // A transput buffer is a REF STRUCT (INT size, index, STRING buffer).
 144  // It is in the heap, but cannot be gc'ed. If it is too small, we give up on
 145  // it and make a larger one.
 146  
 147  A68G_REF ref_transput_buffer[MAX_TRANSPUT_BUFFER];
 148  
 149  //! @brief Set max number of chars in a transput buffer.
 150  
 151  void set_transput_buffer_size (int n, INT_T size)
 152  {
 153    A68G_INT *k = (A68G_INT *) (ADDRESS (&ref_transput_buffer[n]));
 154    STATUS (k) = INIT_MASK;
 155    VALUE (k) = size;
 156  }
 157  
 158  //! @brief Set char index for transput buffer.
 159  
 160  void set_transput_buffer_index (int n, INT_T cindex)
 161  {
 162    A68G_INT *k = (A68G_INT *) (ADDRESS (&ref_transput_buffer[n]) + SIZE (M_INT));
 163    STATUS (k) = INIT_MASK;
 164    VALUE (k) = cindex;
 165  }
 166  
 167  //! @brief Get max number of chars in a transput buffer.
 168  
 169  INT_T get_transput_buffer_size (int n)
 170  {
 171    A68G_INT *k = (A68G_INT *) (ADDRESS (&ref_transput_buffer[n]));
 172    return VALUE (k);
 173  }
 174  
 175  //! @brief Get char index for transput buffer.
 176  
 177  INT_T get_transput_buffer_index (int n)
 178  {
 179    A68G_INT *k = (A68G_INT *) (ADDRESS (&ref_transput_buffer[n]) + SIZE (M_INT));
 180    return VALUE (k);
 181  }
 182  
 183  //! @brief Get char[] from transput buffer.
 184  
 185  char *get_transput_buffer (int n)
 186  {
 187    return (char *) (ADDRESS (&ref_transput_buffer[n]) + 2 * SIZE (M_INT));
 188  }
 189  
 190  //! @brief Mark transput buffer as no longer in use.
 191  
 192  void unblock_transput_buffer (int n)
 193  {
 194    set_transput_buffer_index (n, TRANSPUT_BUFFER_BLOCKED);
 195  }
 196  
 197  //! @brief Find first unused transput buffer (for opening a file).
 198  
 199  int get_unblocked_transput_buffer (NODE_T * p)
 200  {
 201    for (int k = FIXED_TRANSPUT_BUFFERS; k < MAX_TRANSPUT_BUFFER; k++) {
 202      if (get_transput_buffer_index (k) == TRANSPUT_BUFFER_BLOCKED) {
 203        return k;
 204      }
 205    }
 206  // Oops!
 207    diagnostic (A68G_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES);
 208    exit_genie (p, A68G_RUNTIME_ERROR);
 209    return -1;
 210  }
 211  
 212  //! @brief Empty contents of transput buffer.
 213  
 214  void reset_transput_buffer (int n)
 215  {
 216    set_transput_buffer_index (n, 0);
 217    (get_transput_buffer (n))[0] = NULL_CHAR;
 218  }
 219  
 220  //! @brief Initialise transput buffers before use.
 221  
 222  void init_transput_buffers (NODE_T * p)
 223  {
 224    for (int k = 0; k < MAX_TRANSPUT_BUFFER; k++) {
 225      ref_transput_buffer[k] = heap_generator (p, M_ROWS, 2 * SIZE (M_INT) + TRANSPUT_BUFFER_SIZE);
 226      BLOCK_GC_HANDLE (&ref_transput_buffer[k]);
 227      set_transput_buffer_size (k, TRANSPUT_BUFFER_SIZE);
 228      reset_transput_buffer (k);
 229    }
 230  // Last buffers are available for FILE values.
 231    for (int k = FIXED_TRANSPUT_BUFFERS; k < MAX_TRANSPUT_BUFFER; k++) {
 232      unblock_transput_buffer (k);
 233    }
 234  }
 235  
 236  //! @brief Make a transput buffer larger.
 237  
 238  void enlarge_transput_buffer (NODE_T * p, int k, INT_T size)
 239  {
 240    int n = get_transput_buffer_index (k);
 241    char *sb_1 = get_transput_buffer (k), *sb_2;
 242    UNBLOCK_GC_HANDLE (&ref_transput_buffer[k]);
 243    ref_transput_buffer[k] = heap_generator (p, M_ROWS, 2 * SIZE (M_INT) + size);
 244    BLOCK_GC_HANDLE (&ref_transput_buffer[k]);
 245    set_transput_buffer_size (k, size);
 246    set_transput_buffer_index (k, n);
 247    sb_2 = get_transput_buffer (k);
 248    a68g_bufcpy (sb_2, sb_1, size);
 249  }
 250  
 251  //! @brief Add char to transput buffer; if the buffer is full, make it larger.
 252  
 253  void plusab_transput_buffer (NODE_T * p, int k, char ch)
 254  {
 255    char *sb = get_transput_buffer (k);
 256    size_t size = get_transput_buffer_size (k);
 257    int n = get_transput_buffer_index (k);
 258    if (n == size - 2) {
 259      enlarge_transput_buffer (p, k, 10 * size);
 260      plusab_transput_buffer (p, k, ch);
 261    } else {
 262      sb[n] = ch;
 263      sb[n + 1] = NULL_CHAR;
 264      set_transput_buffer_index (k, n + 1);
 265    }
 266  }
 267  
 268  //! @brief Add char to transput buffer at the head; if the buffer is full, make it larger.
 269  
 270  void plusto_transput_buffer (NODE_T * p, char ch, int k)
 271  {
 272    char *sb = get_transput_buffer (k);
 273    size_t size = get_transput_buffer_size (k);
 274    int n = get_transput_buffer_index (k);
 275    if (n == size - 2) {
 276      enlarge_transput_buffer (p, k, 10 * size);
 277      plusto_transput_buffer (p, ch, k);
 278    } else {
 279      MOVE (&sb[1], &sb[0], (unt) size);
 280      sb[0] = ch;
 281      sb[n + 1] = NULL_CHAR;
 282      set_transput_buffer_index (k, n + 1);
 283    }
 284  }
 285  
 286  //! @brief Add chars to transput buffer.
 287  
 288  void add_chars_transput_buffer (NODE_T * p, int k, int N, char *ch)
 289  {
 290    for (int j = 0; j < N; j++) {
 291      plusab_transput_buffer (p, k, ch[j]);
 292    }
 293  }
 294  
 295  //! @brief Add char[] to transput buffer.
 296  
 297  void add_string_transput_buffer (NODE_T * p, int k, char *ch)
 298  {
 299    for (; ch[0] != NULL_CHAR; ch++) {
 300      plusab_transput_buffer (p, k, ch[0]);
 301    }
 302  }
 303  
 304  //! @brief Add A68 string to transput buffer.
 305  
 306  void add_a_string_transput_buffer (NODE_T * p, int k, BYTE_T * ref)
 307  {
 308    A68G_REF row = *(A68G_REF *) ref;
 309    CHECK_INIT (p, INITIALISED (&row), M_ROWS);
 310    A68G_ARRAY *arr; A68G_TUPLE *tup;
 311    GET_DESCRIPTOR (arr, tup, &row);
 312    if (ROW_SIZE (tup) > 0) {
 313      BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
 314      for (int i = LWB (tup); i <= UPB (tup); i++) {
 315        int addr = INDEX_1_DIM (arr, tup, i);
 316        A68G_CHAR *ch = (A68G_CHAR *) & (base_address[addr]);
 317        CHECK_INIT (p, INITIALISED (ch), M_CHAR);
 318        plusab_transput_buffer (p, k, (char) VALUE (ch));
 319      }
 320    }
 321  }
 322  
 323  //! @brief Pop A68 string and add to buffer.
 324  
 325  void add_string_from_stack_transput_buffer (NODE_T * p, int k)
 326  {
 327    DECREMENT_STACK_POINTER (p, A68G_REF_SIZE);
 328    add_a_string_transput_buffer (p, k, STACK_TOP);
 329  }
 330  
 331  //! @brief Pop first character from transput buffer.
 332  
 333  char pop_char_transput_buffer (int k)
 334  {
 335    char *sb = get_transput_buffer (k);
 336    int n = get_transput_buffer_index (k);
 337    if (n <= 0) {
 338      return NULL_CHAR;
 339    } else {
 340      char ch = sb[0];
 341      MOVE (&sb[0], &sb[1], n);
 342      set_transput_buffer_index (k, n - 1);
 343      return ch;
 344    }
 345  }
 346  
 347  //! @brief Add C string to A68 string.
 348  
 349  void add_c_string_to_a_string (NODE_T * p, A68G_REF ref_str, char *s)
 350  {
 351    size_t len_2 = strlen (s);
 352  // left part.
 353    CHECK_REF (p, ref_str, M_REF_STRING);
 354    A68G_REF a = *DEREF (A68G_REF, &ref_str);
 355    CHECK_INIT (p, INITIALISED (&a), M_STRING);
 356    A68G_ARRAY *arr_1; A68G_TUPLE *tup_1;
 357    GET_DESCRIPTOR (arr_1, tup_1, &a);
 358    size_t len_1 = ROW_SIZE (tup_1);
 359  // Sum string.
 360    A68G_REF c = heap_generator (p, M_STRING, DESCRIPTOR_SIZE (1));
 361    A68G_REF d = heap_generator_2 (p, M_STRING, len_1 + len_2, SIZE (M_CHAR));
 362  // Calculate again in case garbage collection moved data.
 363  // GC should not move volatile data, but there you are.
 364    GET_DESCRIPTOR (arr_1, tup_1, &a);
 365  // Make descriptor of new string.
 366    A68G_ARRAY *arr_3; A68G_TUPLE *tup_3;
 367    GET_DESCRIPTOR (arr_3, tup_3, &c);
 368    DIM (arr_3) = 1;
 369    MOID (arr_3) = M_CHAR;
 370    ELEM_SIZE (arr_3) = SIZE (M_CHAR);
 371    SLICE_OFFSET (arr_3) = 0;
 372    FIELD_OFFSET (arr_3) = 0;
 373    ARRAY (arr_3) = d;
 374    LWB (tup_3) = 1;
 375    UPB (tup_3) = len_1 + len_2;
 376    SHIFT (tup_3) = LWB (tup_3);
 377    SPAN (tup_3) = 1;
 378  // add strings.
 379    BYTE_T *b_1 = (ROW_SIZE (tup_1) > 0 ? DEREF (BYTE_T, &ARRAY (arr_1)) : NO_BYTE);
 380    BYTE_T *b_3 = DEREF (BYTE_T, &ARRAY (arr_3));
 381    int u = 0;
 382    for (int v = LWB (tup_1); v <= UPB (tup_1); v++) {
 383      MOVE ((BYTE_T *) & b_3[u], (BYTE_T *) & b_1[INDEX_1_DIM (arr_1, tup_1, v)], SIZE (M_CHAR));
 384      u += SIZE (M_CHAR);
 385    }
 386    for (int v = 0; v < len_2; v++) {
 387      A68G_CHAR ch;
 388      STATUS (&ch) = INIT_MASK;
 389      VALUE (&ch) = s[v];
 390      MOVE ((BYTE_T *) & b_3[u], (BYTE_T *) & ch, SIZE (M_CHAR));
 391      u += SIZE (M_CHAR);
 392    }
 393    *DEREF (A68G_REF, &ref_str) = c;
 394  }
 395  
 396  //! @brief Purge buffer for file.
 397  
 398  void write_purge_buffer (NODE_T * p, A68G_REF ref_file, int k)
 399  {
 400    A68G_FILE *file = FILE_DEREF (&ref_file);
 401    if (IS_NIL (STRING (file))) {
 402      if (!(FD (file) == A68G_STDOUT && A68G (halt_typing))) {
 403        WRITE (FD (file), get_transput_buffer (k));
 404      }
 405    } else {
 406      add_c_string_to_a_string (p, STRING (file), get_transput_buffer (k));
 407    }
 408    reset_transput_buffer (k);
 409  }
 410  
 411  // Routines that involve the A68 expression stack.
 412  
 413  //! @brief Allocate a temporary string on the stack.
 414  
 415  char *stack_string (NODE_T * p, size_t size)
 416  {
 417    char *new_str = (char *) STACK_TOP;
 418    INCREMENT_STACK_POINTER (p, size);
 419    if (A68G_SP > A68G (expr_stack_limit)) {
 420      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);
 421      exit_genie (p, A68G_RUNTIME_ERROR);
 422    }
 423    FILL (new_str, NULL_CHAR, size);
 424    return new_str;
 425  }
 426  
 427  // Transput basic RTS routines.
 428  
 429  //! @brief REF FILE standin
 430  
 431  void genie_stand_in (NODE_T * p)
 432  {
 433    PUSH_REF (p, A68G (stand_in));
 434  }
 435  
 436  //! @brief REF FILE standout
 437  
 438  void genie_stand_out (NODE_T * p)
 439  {
 440    PUSH_REF (p, A68G (stand_out));
 441  }
 442  
 443  //! @brief REF FILE standback
 444  
 445  void genie_stand_back (NODE_T * p)
 446  {
 447    PUSH_REF (p, A68G (stand_back));
 448  }
 449  
 450  //! @brief REF FILE standerror
 451  
 452  void genie_stand_error (NODE_T * p)
 453  {
 454    PUSH_REF (p, A68G (stand_error));
 455  }
 456  
 457  //! @brief CHAR error char
 458  
 459  void genie_error_char (NODE_T * p)
 460  {
 461    PUSH_VALUE (p, ERROR_CHAR, A68G_CHAR);
 462  }
 463  
 464  //! @brief CHAR exp char
 465  
 466  void genie_exp_char (NODE_T * p)
 467  {
 468    PUSH_VALUE (p, EXPONENT_CHAR, A68G_CHAR);
 469  }
 470  
 471  //! @brief CHAR flip char
 472  
 473  void genie_flip_char (NODE_T * p)
 474  {
 475    PUSH_VALUE (p, FLIP_CHAR, A68G_CHAR);
 476  }
 477  
 478  //! @brief CHAR flop char
 479  
 480  void genie_flop_char (NODE_T * p)
 481  {
 482    PUSH_VALUE (p, FLOP_CHAR, A68G_CHAR);
 483  }
 484  
 485  //! @brief CHAR null char
 486  
 487  void genie_null_char (NODE_T * p)
 488  {
 489    PUSH_VALUE (p, NULL_CHAR, A68G_CHAR);
 490  }
 491  
 492  //! @brief CHAR blank
 493  
 494  void genie_blank_char (NODE_T * p)
 495  {
 496    PUSH_VALUE (p, BLANK_CHAR, A68G_CHAR);
 497  }
 498  
 499  //! @brief CHAR newline char
 500  
 501  void genie_newline_char (NODE_T * p)
 502  {
 503    PUSH_VALUE (p, NEWLINE_CHAR, A68G_CHAR);
 504  }
 505  
 506  //! @brief CHAR formfeed char
 507  
 508  void genie_formfeed_char (NODE_T * p)
 509  {
 510    PUSH_VALUE (p, FORMFEED_CHAR, A68G_CHAR);
 511  }
 512  
 513  //! @brief CHAR tab char
 514  
 515  void genie_tab_char (NODE_T * p)
 516  {
 517    PUSH_VALUE (p, TAB_CHAR, A68G_CHAR);
 518  }
 519  
 520  //! @brief CHANNEL standin channel
 521  
 522  void genie_stand_in_channel (NODE_T * p)
 523  {
 524    PUSH_OBJECT (p, A68G (stand_in_channel), A68G_CHANNEL);
 525  }
 526  
 527  //! @brief CHANNEL standout channel
 528  
 529  void genie_stand_out_channel (NODE_T * p)
 530  {
 531    PUSH_OBJECT (p, A68G (stand_out_channel), A68G_CHANNEL);
 532  }
 533  
 534  //! @brief CHANNEL stand draw channel
 535  
 536  void genie_stand_draw_channel (NODE_T * p)
 537  {
 538    PUSH_OBJECT (p, A68G (stand_draw_channel), A68G_CHANNEL);
 539  }
 540  
 541  //! @brief CHANNEL standback channel
 542  
 543  void genie_stand_back_channel (NODE_T * p)
 544  {
 545    PUSH_OBJECT (p, A68G (stand_back_channel), A68G_CHANNEL);
 546  }
 547  
 548  //! @brief CHANNEL standerror channel
 549  
 550  void genie_stand_error_channel (NODE_T * p)
 551  {
 552    PUSH_OBJECT (p, A68G (stand_error_channel), A68G_CHANNEL);
 553  }
 554  
 555  //! @brief PROC STRING program idf
 556  
 557  void genie_program_idf (NODE_T * p)
 558  {
 559    PUSH_REF (p, c_to_a_string (p, FILE_SOURCE_NAME (&A68G_JOB), DEFAULT_WIDTH));
 560  }
 561  
 562  // FILE and CHANNEL initialisations.
 563  
 564  //! @brief Set_default_event_procedure.
 565  
 566  void set_default_event_procedure (A68G_PROCEDURE * z)
 567  {
 568    STATUS (z) = INIT_MASK;
 569    NODE (&(BODY (z))) = NO_NODE;
 570    ENVIRON (z) = 0;
 571  }
 572  
 573  //! @brief Initialise channel.
 574  
 575  void init_channel (A68G_CHANNEL * chan, BOOL_T r, BOOL_T s, BOOL_T g, BOOL_T p, BOOL_T b, BOOL_T d)
 576  {
 577    STATUS (chan) = INIT_MASK;
 578    RESET (chan) = r;
 579    SET (chan) = s;
 580    GET (chan) = g;
 581    PUT (chan) = p;
 582    BIN (chan) = b;
 583    DRAW (chan) = d;
 584    COMPRESS (chan) = A68G_TRUE;
 585  }
 586  
 587  //! @brief Set default event handlers.
 588  
 589  void set_default_event_procedures (A68G_FILE * f)
 590  {
 591    set_default_event_procedure (&(FILE_END_MENDED (f)));
 592    set_default_event_procedure (&(PAGE_END_MENDED (f)));
 593    set_default_event_procedure (&(LINE_END_MENDED (f)));
 594    set_default_event_procedure (&(VALUE_ERROR_MENDED (f)));
 595    set_default_event_procedure (&(OPEN_ERROR_MENDED (f)));
 596    set_default_event_procedure (&(TRANSPUT_ERROR_MENDED (f)));
 597    set_default_event_procedure (&(FORMAT_END_MENDED (f)));
 598    set_default_event_procedure (&(FORMAT_ERROR_MENDED (f)));
 599  }
 600  
 601  //! @brief Set up a REF FILE object.
 602  
 603  void init_file (NODE_T * p, A68G_REF * ref_file, A68G_CHANNEL c, FILE_T s, BOOL_T rm, BOOL_T wm, BOOL_T cm, char *env)
 604  {
 605    char *filename = (env == NO_TEXT ? NO_TEXT : getenv (env));
 606    *ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
 607    BLOCK_GC_HANDLE (ref_file);
 608    A68G_FILE *f = FILE_DEREF (ref_file);
 609    STATUS (f) = INIT_MASK;
 610    TERMINATOR (f) = nil_ref;
 611    CHANNEL (f) = c;
 612    if (filename != NO_TEXT && strlen (filename) > 0) {
 613      size_t len = 1 + strlen (filename);
 614      IDENTIFICATION (f) = heap_generator (p, M_C_STRING, len);
 615      BLOCK_GC_HANDLE (&(IDENTIFICATION (f)));
 616      a68g_bufcpy (DEREF (char, &IDENTIFICATION (f)), filename, len);
 617      FD (f) = A68G_NO_FILE;
 618      READ_MOOD (f) = A68G_FALSE;
 619      WRITE_MOOD (f) = A68G_FALSE;
 620      CHAR_MOOD (f) = A68G_FALSE;
 621      DRAW_MOOD (f) = A68G_FALSE;
 622    } else {
 623      IDENTIFICATION (f) = nil_ref;
 624      FD (f) = s;
 625      READ_MOOD (f) = rm;
 626      WRITE_MOOD (f) = wm;
 627      CHAR_MOOD (f) = cm;
 628      DRAW_MOOD (f) = A68G_FALSE;
 629    }
 630    TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p);
 631    reset_transput_buffer (TRANSPUT_BUFFER (f));
 632    END_OF_FILE (f) = A68G_FALSE;
 633    TMP_FILE (f) = A68G_FALSE;
 634    OPENED (f) = A68G_TRUE;
 635    APPEND (f) = A68G_FALSE;
 636    OPEN_EXCLUSIVE (f) = A68G_FALSE;
 637    FORMAT (f) = nil_format;
 638    STRING (f) = nil_ref;
 639    STRPOS (f) = 0;
 640    FILE_ENTRY (f) = -1;
 641    set_default_event_procedures (f);
 642  }
 643  
 644  //! @brief Initialise the transput RTL.
 645  
 646  void genie_init_transput (NODE_T * p)
 647  {
 648    init_transput_buffers (p);
 649  // Channels.
 650    init_channel (&(A68G (stand_in_channel)), A68G_FALSE, A68G_FALSE, A68G_TRUE, A68G_FALSE, A68G_FALSE, A68G_FALSE);
 651    init_channel (&(A68G (stand_out_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_TRUE, A68G_FALSE, A68G_FALSE);
 652    init_channel (&(A68G (stand_back_channel)), A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_FALSE);
 653    init_channel (&(A68G (stand_error_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_TRUE, A68G_FALSE, A68G_FALSE);
 654    init_channel (&(A68G (associate_channel)), A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_FALSE);
 655    init_channel (&(A68G (skip_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE);
 656    #if defined (HAVE_GNU_PLOTUTILS)
 657      init_channel (&(A68G (stand_draw_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_TRUE);
 658    #else
 659      init_channel (&(A68G (stand_draw_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_TRUE);
 660    #endif
 661  // Files.
 662    init_file (p, &(A68G (stand_in)), A68G (stand_in_channel), A68G_STDIN, A68G_TRUE, A68G_FALSE, A68G_TRUE, "A68G_STANDIN");
 663    init_file (p, &(A68G (stand_out)), A68G (stand_out_channel), A68G_STDOUT, A68G_FALSE, A68G_TRUE, A68G_TRUE, "A68G_STANDOUT");
 664    init_file (p, &(A68G (stand_back)), A68G (stand_back_channel), A68G_NO_FILE, A68G_FALSE, A68G_FALSE, A68G_FALSE, NO_TEXT);
 665    init_file (p, &(A68G (stand_error)), A68G (stand_error_channel), A68G_STDERR, A68G_FALSE, A68G_TRUE, A68G_TRUE, "A68G_STANDERROR");
 666    init_file (p, &(A68G (skip_file)), A68G (skip_channel), A68G_NO_FILE, A68G_FALSE, A68G_FALSE, A68G_FALSE, NO_TEXT);
 667  }
 668  
 669  //! @brief PROC (REF FILE) STRING idf
 670  
 671  void genie_idf (NODE_T * p)
 672  {
 673    A68G_REF ref_file;
 674    POP_REF (p, &ref_file);
 675    CHECK_REF (p, ref_file, M_REF_FILE);
 676    ref_file = *(A68G_REF *) STACK_TOP;
 677    A68G_REF ref_filename = IDENTIFICATION (FILE_DEREF (&ref_file));
 678    CHECK_REF (p, ref_filename, M_ROWS);
 679    char *filename = DEREF (char, &ref_filename);
 680    PUSH_REF (p, c_to_a_string (p, filename, DEFAULT_WIDTH));
 681  }
 682  
 683  //! @brief PROC (REF FILE) STRING term
 684  
 685  void genie_term (NODE_T * p)
 686  {
 687    A68G_REF ref_file;
 688    POP_REF (p, &ref_file);
 689    CHECK_REF (p, ref_file, M_REF_FILE);
 690    ref_file = *(A68G_REF *) STACK_TOP;
 691    A68G_REF ref_term = TERMINATOR (FILE_DEREF (&ref_file));
 692    CHECK_REF (p, ref_term, M_ROWS);
 693    char *term = DEREF (char, &ref_term);
 694    PUSH_REF (p, c_to_a_string (p, term, DEFAULT_WIDTH));
 695  }
 696  
 697  //! @brief PROC (REF FILE, STRING) VOID make term
 698  
 699  void genie_make_term (NODE_T * p)
 700  {
 701    A68G_REF ref_file, str;
 702    POP_REF (p, &str);
 703    POP_REF (p, &ref_file);
 704    CHECK_REF (p, ref_file, M_REF_FILE);
 705    ref_file = *(A68G_REF *) STACK_TOP;
 706    A68G_FILE *file = FILE_DEREF (&ref_file);
 707  // Don't check initialisation so we can "make term" before opening.
 708    size_t size = a68g_string_size (p, str);
 709    if (INITIALISED (&(TERMINATOR (file))) && !IS_NIL (TERMINATOR (file))) {
 710      UNBLOCK_GC_HANDLE (&(TERMINATOR (file)));
 711    }
 712    TERMINATOR (file) = heap_generator (p, M_C_STRING, 1 + size);
 713    BLOCK_GC_HANDLE (&(TERMINATOR (file)));
 714    ASSERT (a_to_c_string (p, DEREF (char, &TERMINATOR (file)), str) != NO_TEXT);
 715  }
 716  
 717  //! @brief PROC (REF FILE) BOOL put possible
 718  
 719  void genie_put_possible (NODE_T * p)
 720  {
 721    A68G_REF ref_file;
 722    POP_REF (p, &ref_file);
 723    CHECK_REF (p, ref_file, M_REF_FILE);
 724    A68G_FILE *file = FILE_DEREF (&ref_file);
 725    CHECK_INIT (p, INITIALISED (file), M_FILE);
 726    PUSH_VALUE (p, PUT (&CHANNEL (file)), A68G_BOOL);
 727  }
 728  
 729  //! @brief PROC (REF FILE) BOOL get possible
 730  
 731  void genie_get_possible (NODE_T * p)
 732  {
 733    A68G_REF ref_file;
 734    POP_REF (p, &ref_file);
 735    CHECK_REF (p, ref_file, M_REF_FILE);
 736    A68G_FILE *file = FILE_DEREF (&ref_file);
 737    CHECK_INIT (p, INITIALISED (file), M_FILE);
 738    PUSH_VALUE (p, GET (&CHANNEL (file)), A68G_BOOL);
 739  }
 740  
 741  //! @brief PROC (REF FILE) BOOL bin possible
 742  
 743  void genie_bin_possible (NODE_T * p)
 744  {
 745    A68G_REF ref_file;
 746    POP_REF (p, &ref_file);
 747    CHECK_REF (p, ref_file, M_REF_FILE);
 748    A68G_FILE *file = FILE_DEREF (&ref_file);
 749    CHECK_INIT (p, INITIALISED (file), M_FILE);
 750    PUSH_VALUE (p, BIN (&CHANNEL (file)), A68G_BOOL);
 751  }
 752  
 753  //! @brief PROC (REF FILE) BOOL set possible
 754  
 755  void genie_set_possible (NODE_T * p)
 756  {
 757    A68G_REF ref_file;
 758    POP_REF (p, &ref_file);
 759    CHECK_REF (p, ref_file, M_REF_FILE);
 760    A68G_FILE *file = FILE_DEREF (&ref_file);
 761    CHECK_INIT (p, INITIALISED (file), M_FILE);
 762    PUSH_VALUE (p, SET (&CHANNEL (file)), A68G_BOOL);
 763  }
 764  
 765  //! @brief PROC (REF FILE) BOOL reidf possible
 766  
 767  void genie_reidf_possible (NODE_T * p)
 768  {
 769    A68G_REF ref_file;
 770    POP_REF (p, &ref_file);
 771    CHECK_REF (p, ref_file, M_REF_FILE);
 772    A68G_FILE *file = FILE_DEREF (&ref_file);
 773    CHECK_INIT (p, INITIALISED (file), M_FILE);
 774    PUSH_VALUE (p, A68G_FALSE, A68G_BOOL);
 775  }
 776  
 777  //! @brief PROC (REF FILE) BOOL reset possible
 778  
 779  void genie_reset_possible (NODE_T * p)
 780  {
 781    A68G_REF ref_file;
 782    POP_REF (p, &ref_file);
 783    CHECK_REF (p, ref_file, M_REF_FILE);
 784    A68G_FILE *file = FILE_DEREF (&ref_file);
 785    CHECK_INIT (p, INITIALISED (file), M_FILE);
 786    PUSH_VALUE (p, RESET (&CHANNEL (file)), A68G_BOOL);
 787  }
 788  
 789  //! @brief PROC (REF FILE) BOOL compressible
 790  
 791  void genie_compressible (NODE_T * p)
 792  {
 793    A68G_REF ref_file;
 794    A68G_FILE *file;
 795    POP_REF (p, &ref_file);
 796    CHECK_REF (p, ref_file, M_REF_FILE);
 797    file = FILE_DEREF (&ref_file);
 798    CHECK_INIT (p, INITIALISED (file), M_FILE);
 799    PUSH_VALUE (p, COMPRESS (&CHANNEL (file)), A68G_BOOL);
 800  }
 801  
 802  //! @brief PROC (REF FILE) BOOL draw possible
 803  
 804  void genie_draw_possible (NODE_T * p)
 805  {
 806    A68G_REF ref_file;
 807    POP_REF (p, &ref_file);
 808    CHECK_REF (p, ref_file, M_REF_FILE);
 809    A68G_FILE *file = FILE_DEREF (&ref_file);
 810    CHECK_INIT (p, INITIALISED (file), M_FILE);
 811    PUSH_VALUE (p, DRAW (&CHANNEL (file)), A68G_BOOL);
 812  }
 813  
 814  //! @brief PROC (REF FILE, STRING, CHANNEL) INT open
 815  
 816  void genie_open (NODE_T * p)
 817  {
 818    A68G_CHANNEL channel;
 819    POP_OBJECT (p, &channel, A68G_CHANNEL);
 820    A68G_REF ref_iden;
 821    POP_REF (p, &ref_iden);
 822    CHECK_REF (p, ref_iden, M_REF_STRING);
 823    A68G_REF ref_file;
 824    POP_REF (p, &ref_file);
 825    CHECK_REF (p, ref_file, M_REF_FILE);
 826    A68G_FILE *file = FILE_DEREF (&ref_file);
 827    STATUS (file) = INIT_MASK;
 828    FILE_ENTRY (file) = -1;
 829    CHANNEL (file) = channel;
 830    OPENED (file) = A68G_TRUE;
 831    APPEND (file) = A68G_FALSE;
 832    OPEN_EXCLUSIVE (file) = A68G_FALSE;
 833    READ_MOOD (file) = A68G_FALSE;
 834    WRITE_MOOD (file) = A68G_FALSE;
 835    CHAR_MOOD (file) = A68G_FALSE;
 836    DRAW_MOOD (file) = A68G_FALSE;
 837    TMP_FILE (file) = A68G_FALSE;
 838    size_t size = a68g_string_size (p, ref_iden);
 839    if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
 840      UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
 841    }
 842    IDENTIFICATION (file) = heap_generator (p, M_C_STRING, 1 + size);
 843    BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
 844    ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT);
 845    TERMINATOR (file) = nil_ref;
 846    FORMAT (file) = nil_format;
 847    FD (file) = A68G_NO_FILE;
 848    if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
 849      UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
 850    }
 851    STRING (file) = nil_ref;
 852    STRPOS (file) = 0;
 853    DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
 854    STREAM (&DEVICE (file)) = NO_STREAM;
 855    set_default_event_procedures (file);
 856    {
 857      struct stat status;
 858      if (stat (DEREF (char, &IDENTIFICATION (file)), &status) == 0) {
 859        PUSH_VALUE (p, (S_ISREG (ST_MODE (&status)) != 0 ? 0 : ENOENT), A68G_INT);
 860      } else {
 861        PUSH_VALUE (p, errno, A68G_INT);
 862      }
 863      errno = 0;
 864    }
 865  }
 866  
 867  //! @brief PROC (REF FILE, STRING, CHANNEL) INT append
 868  
 869  void genie_append (NODE_T * p)
 870  {
 871    A68G_CHANNEL channel;
 872    POP_OBJECT (p, &channel, A68G_CHANNEL);
 873    A68G_REF ref_iden;
 874    POP_REF (p, &ref_iden);
 875    CHECK_REF (p, ref_iden, M_REF_STRING);
 876    A68G_REF ref_file;
 877    POP_REF (p, &ref_file);
 878    CHECK_REF (p, ref_file, M_REF_FILE);
 879    A68G_FILE *file = FILE_DEREF (&ref_file);
 880    STATUS (file) = INIT_MASK;
 881    FILE_ENTRY (file) = -1;
 882    CHANNEL (file) = channel;
 883    OPENED (file) = A68G_TRUE;
 884    APPEND (file) = A68G_TRUE;
 885    OPEN_EXCLUSIVE (file) = A68G_FALSE;
 886    READ_MOOD (file) = A68G_FALSE;
 887    WRITE_MOOD (file) = A68G_FALSE;
 888    CHAR_MOOD (file) = A68G_FALSE;
 889    DRAW_MOOD (file) = A68G_FALSE;
 890    TMP_FILE (file) = A68G_FALSE;
 891    size_t size = a68g_string_size (p, ref_iden);
 892    if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
 893      UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
 894    }
 895    IDENTIFICATION (file) = heap_generator (p, M_C_STRING, 1 + size);
 896    BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
 897    ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT);
 898    TERMINATOR (file) = nil_ref;
 899    FORMAT (file) = nil_format;
 900    FD (file) = A68G_NO_FILE;
 901    if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
 902      UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
 903    }
 904    STRING (file) = nil_ref;
 905    STRPOS (file) = 0;
 906    DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
 907    STREAM (&DEVICE (file)) = NO_STREAM;
 908    set_default_event_procedures (file);
 909    {
 910      struct stat status;
 911      if (stat (DEREF (char, &IDENTIFICATION (file)), &status) == 0) {
 912        PUSH_VALUE (p, (S_ISREG (ST_MODE (&status)) != 0 ? 0 : ENOENT), A68G_INT);
 913      } else {
 914        PUSH_VALUE (p, errno, A68G_INT);
 915      }
 916      errno = 0;
 917    }
 918  }
 919  
 920  //! @brief PROC (REF FILE, STRING, CHANNEL) INT establish
 921  
 922  void genie_establish (NODE_T * p)
 923  {
 924    A68G_CHANNEL channel;
 925    POP_OBJECT (p, &channel, A68G_CHANNEL);
 926    A68G_REF ref_iden;
 927    POP_REF (p, &ref_iden);
 928    CHECK_REF (p, ref_iden, M_REF_STRING);
 929    A68G_REF ref_file;
 930    POP_REF (p, &ref_file);
 931    CHECK_REF (p, ref_file, M_REF_FILE);
 932    A68G_FILE *file = FILE_DEREF (&ref_file);
 933    STATUS (file) = INIT_MASK;
 934    FILE_ENTRY (file) = -1;
 935    CHANNEL (file) = channel;
 936    OPENED (file) = A68G_TRUE;
 937    APPEND (file) = A68G_FALSE;
 938    OPEN_EXCLUSIVE (file) = A68G_TRUE;
 939    READ_MOOD (file) = A68G_FALSE;
 940    WRITE_MOOD (file) = A68G_FALSE;
 941    CHAR_MOOD (file) = A68G_FALSE;
 942    DRAW_MOOD (file) = A68G_FALSE;
 943    TMP_FILE (file) = A68G_FALSE;
 944    if (!PUT (&CHANNEL (file))) {
 945      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
 946      exit_genie (p, A68G_RUNTIME_ERROR);
 947    }
 948    size_t size = a68g_string_size (p, ref_iden);
 949    if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
 950      UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
 951    }
 952    IDENTIFICATION (file) = heap_generator (p, M_C_STRING, 1 + size);
 953    BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
 954    ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT);
 955    TERMINATOR (file) = nil_ref;
 956    FORMAT (file) = nil_format;
 957    FD (file) = A68G_NO_FILE;
 958    if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
 959      UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
 960    }
 961    STRING (file) = nil_ref;
 962    STRPOS (file) = 0;
 963    DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
 964    STREAM (&DEVICE (file)) = NO_STREAM;
 965    set_default_event_procedures (file);
 966    PUSH_VALUE (p, 0, A68G_INT);
 967  }
 968  
 969  //! @brief PROC (REF FILE, CHANNEL) INT create
 970  
 971  void genie_create (NODE_T * p)
 972  {
 973    A68G_CHANNEL channel;
 974    POP_OBJECT (p, &channel, A68G_CHANNEL);
 975    A68G_REF ref_file;
 976    POP_REF (p, &ref_file);
 977    CHECK_REF (p, ref_file, M_REF_FILE);
 978    A68G_FILE *file = FILE_DEREF (&ref_file);
 979    STATUS (file) = INIT_MASK;
 980    FILE_ENTRY (file) = -1;
 981    CHANNEL (file) = channel;
 982    OPENED (file) = A68G_TRUE;
 983    APPEND (file) = A68G_FALSE;
 984    OPEN_EXCLUSIVE (file) = A68G_FALSE;
 985    READ_MOOD (file) = A68G_FALSE;
 986    WRITE_MOOD (file) = A68G_FALSE;
 987    CHAR_MOOD (file) = A68G_FALSE;
 988    DRAW_MOOD (file) = A68G_FALSE;
 989    TMP_FILE (file) = A68G_TRUE;
 990    if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
 991      UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
 992    }
 993    IDENTIFICATION (file) = nil_ref;
 994    TERMINATOR (file) = nil_ref;
 995    FORMAT (file) = nil_format;
 996    FD (file) = A68G_NO_FILE;
 997    if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
 998      UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
 999    }
1000    STRING (file) = nil_ref;
1001    STRPOS (file) = 0;
1002    DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1003    STREAM (&DEVICE (file)) = NO_STREAM;
1004    set_default_event_procedures (file);
1005    PUSH_VALUE (p, 0, A68G_INT);
1006  }
1007  
1008  //! @brief PROC (REF FILE, REF STRING) VOID associate
1009  
1010  void genie_associate (NODE_T * p)
1011  {
1012    A68G_REF ref_string;
1013    POP_REF (p, &ref_string);
1014    CHECK_REF (p, ref_string, M_REF_STRING);
1015    A68G_REF ref_file;
1016    POP_REF (p, &ref_file);
1017    CHECK_REF (p, ref_file, M_REF_FILE);
1018    if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) {
1019      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, M_REF_STRING);
1020      exit_genie (p, A68G_RUNTIME_ERROR);
1021    } else if (IS_IN_FRAME (&ref_file) && IS_IN_FRAME (&ref_string)) {
1022      if (REF_SCOPE (&ref_string) > REF_SCOPE (&ref_file)) {
1023        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, M_REF_STRING);
1024        exit_genie (p, A68G_RUNTIME_ERROR);
1025      }
1026    }
1027    A68G_FILE *file = FILE_DEREF (&ref_file);
1028    STATUS (file) = INIT_MASK;
1029    FILE_ENTRY (file) = -1;
1030    CHANNEL (file) = A68G (associate_channel);
1031    OPENED (file) = A68G_TRUE;
1032    APPEND (file) = A68G_FALSE;
1033    OPEN_EXCLUSIVE (file) = A68G_FALSE;
1034    READ_MOOD (file) = A68G_FALSE;
1035    WRITE_MOOD (file) = A68G_FALSE;
1036    CHAR_MOOD (file) = A68G_FALSE;
1037    DRAW_MOOD (file) = A68G_FALSE;
1038    TMP_FILE (file) = A68G_FALSE;
1039    if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
1040      UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
1041    }
1042    IDENTIFICATION (file) = nil_ref;
1043    TERMINATOR (file) = nil_ref;
1044    FORMAT (file) = nil_format;
1045    FD (file) = A68G_NO_FILE;
1046    if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
1047      UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
1048    }
1049    STRING (file) = ref_string;
1050    BLOCK_GC_HANDLE ((A68G_REF *) (&(STRING (file))));
1051    STRPOS (file) = 0;
1052    DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1053    STREAM (&DEVICE (file)) = NO_STREAM;
1054    set_default_event_procedures (file);
1055  }
1056  
1057  //! @brief PROC (REF FILE) VOID close
1058  
1059  void genie_close (NODE_T * p)
1060  {
1061    A68G_REF ref_file;
1062    POP_REF (p, &ref_file);
1063    CHECK_REF (p, ref_file, M_REF_FILE);
1064    A68G_FILE *file = FILE_DEREF (&ref_file);
1065    CHECK_INIT (p, INITIALISED (file), M_FILE);
1066    if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
1067      return;
1068    }
1069    DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1070    #if defined (HAVE_GNU_PLOTUTILS)
1071      if (DEVICE_OPENED (&DEVICE (file))) {
1072        ASSERT (close_device (p, file) == A68G_TRUE);
1073        STREAM (&DEVICE (file)) = NO_STREAM;
1074        return;
1075      }
1076    #endif
1077    FD (file) = A68G_NO_FILE;
1078    OPENED (file) = A68G_FALSE;
1079    unblock_transput_buffer (TRANSPUT_BUFFER (file));
1080    set_default_event_procedures (file);
1081    free_file_entry (p, FILE_ENTRY (file));
1082  }
1083  
1084  //! @brief PROC (REF FILE) VOID lock
1085  
1086  void genie_lock (NODE_T * p)
1087  {
1088    A68G_REF ref_file;
1089    POP_REF (p, &ref_file);
1090    CHECK_REF (p, ref_file, M_REF_FILE);
1091    A68G_FILE *file = FILE_DEREF (&ref_file);
1092    CHECK_INIT (p, INITIALISED (file), M_FILE);
1093    if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
1094      return;
1095    }
1096    DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1097    #if defined (HAVE_GNU_PLOTUTILS)
1098      if (DEVICE_OPENED (&DEVICE (file))) {
1099        ASSERT (close_device (p, file) == A68G_TRUE);
1100        STREAM (&DEVICE (file)) = NO_STREAM;
1101        return;
1102      }
1103    #endif
1104    #if defined (BUILD_UNIX)
1105      errno = 0;
1106      ASSERT (fchmod (FD (file), (mode_t) 0x0) != -1);
1107    #endif
1108    if (FD (file) != A68G_NO_FILE && close (FD (file)) == -1) {
1109      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_LOCK);
1110      exit_genie (p, A68G_RUNTIME_ERROR);
1111    } else {
1112      FD (file) = A68G_NO_FILE;
1113      OPENED (file) = A68G_FALSE;
1114      unblock_transput_buffer (TRANSPUT_BUFFER (file));
1115      set_default_event_procedures (file);
1116    }
1117    free_file_entry (p, FILE_ENTRY (file));
1118  }
1119  
1120  //! @brief PROC (REF FILE) VOID erase
1121  
1122  void genie_erase (NODE_T * p)
1123  {
1124    A68G_REF ref_file;
1125    POP_REF (p, &ref_file);
1126    CHECK_REF (p, ref_file, M_REF_FILE);
1127    A68G_FILE *file = FILE_DEREF (&ref_file);
1128    CHECK_INIT (p, INITIALISED (file), M_FILE);
1129    if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
1130      return;
1131    }
1132    DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1133    #if defined (HAVE_GNU_PLOTUTILS)
1134      if (DEVICE_OPENED (&DEVICE (file))) {
1135        ASSERT (close_device (p, file) == A68G_TRUE);
1136        STREAM (&DEVICE (file)) = NO_STREAM;
1137        return;
1138      }
1139    #endif
1140    if (FD (file) != A68G_NO_FILE && close (FD (file)) == -1) {
1141      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH);
1142      exit_genie (p, A68G_RUNTIME_ERROR);
1143    } else {
1144      unblock_transput_buffer (TRANSPUT_BUFFER (file));
1145      set_default_event_procedures (file);
1146    }
1147  // Remove the file.
1148    if (!IS_NIL (IDENTIFICATION (file))) {
1149      char *filename;
1150      CHECK_INIT (p, INITIALISED (&(IDENTIFICATION (file))), M_ROWS);
1151      filename = DEREF (char, &IDENTIFICATION (file));
1152      if (remove (filename) != 0) {
1153        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH);
1154        exit_genie (p, A68G_RUNTIME_ERROR);
1155      }
1156      UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
1157      IDENTIFICATION (file) = nil_ref;
1158    }
1159    init_file_entry (FILE_ENTRY (file));
1160  }
1161  
1162  //! @brief PROC (REF FILE) VOID backspace
1163  
1164  void genie_backspace (NODE_T * p)
1165  {
1166    ADDR_T pop_sp = A68G_SP;
1167    PUSH_VALUE (p, -1, A68G_INT);
1168    genie_set (p);
1169    A68G_SP = pop_sp;
1170  }
1171  
1172  //! @brief PROC (REF FILE, INT) INT set
1173  
1174  void genie_set (NODE_T * p)
1175  {
1176    A68G_INT pos;
1177    POP_OBJECT (p, &pos, A68G_INT);
1178    A68G_REF ref_file;
1179    POP_REF (p, &ref_file);
1180    CHECK_REF (p, ref_file, M_REF_FILE);
1181    A68G_FILE *file = FILE_DEREF (&ref_file);
1182    CHECK_INIT (p, INITIALISED (file), M_FILE);
1183    if (!OPENED (file)) {
1184      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1185      exit_genie (p, A68G_RUNTIME_ERROR);
1186    }
1187    if (!SET (&CHANNEL (file))) {
1188      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CANT_SET);
1189      exit_genie (p, A68G_RUNTIME_ERROR);
1190    }
1191    if (!IS_NIL (STRING (file))) {
1192      A68G_REF z = *DEREF (A68G_REF, &STRING (file));
1193      size_t size;
1194  // Circumvent buffering problems.
1195      STRPOS (file) -= get_transput_buffer_index (TRANSPUT_BUFFER (file));
1196      ASSERT (STRPOS (file) > 0);
1197      reset_transput_buffer (TRANSPUT_BUFFER (file));
1198  // Now set.
1199      CHECK_INT_ADDITION (p, STRPOS (file), VALUE (&pos));
1200      STRPOS (file) += VALUE (&pos);
1201      A68G_ARRAY *arr; A68G_TUPLE *tup;
1202      GET_DESCRIPTOR (arr, tup, &z);
1203      size = ROW_SIZE (tup);
1204      if (size <= 0 || STRPOS (file) < 0 || STRPOS (file) >= size) {
1205        A68G_BOOL res;
1206        on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1207        POP_OBJECT (p, &res, A68G_BOOL);
1208        if (VALUE (&res) == A68G_FALSE) {
1209          diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1210          exit_genie (p, A68G_RUNTIME_ERROR);
1211        }
1212      }
1213      PUSH_VALUE (p, STRPOS (file), A68G_INT);
1214    } else if (FD (file) == A68G_NO_FILE) {
1215      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_RESET);
1216      exit_genie (p, A68G_RUNTIME_ERROR);
1217    } else {
1218      errno = 0;
1219      a68g_off_t curpos = (a68g_off_t) lseek (FD (file), 0, SEEK_CUR);
1220      a68g_off_t maxpos = (a68g_off_t) lseek (FD (file), 0, SEEK_END);
1221  // Circumvent buffering problems.
1222      int reserve = get_transput_buffer_index (TRANSPUT_BUFFER (file));
1223      curpos -= (a68g_off_t) reserve;
1224      a68g_off_t res = (a68g_off_t) lseek (FD (file), -reserve, SEEK_CUR);
1225      ASSERT (res != (a68g_off_t) -1 && errno == 0);
1226      reset_transput_buffer (TRANSPUT_BUFFER (file));
1227  // Now set.
1228      CHECK_INT_ADDITION (p, curpos, VALUE (&pos));
1229      curpos += VALUE (&pos);
1230      if (curpos < 0 || curpos >= maxpos) {
1231        A68G_BOOL ret;
1232        on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1233        POP_OBJECT (p, &ret, A68G_BOOL);
1234        if (VALUE (&ret) == A68G_FALSE) {
1235          diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1236          exit_genie (p, A68G_RUNTIME_ERROR);
1237        }
1238        PUSH_VALUE (p, (INT_T) lseek (FD (file), 0, SEEK_CUR), A68G_INT);
1239      } else {
1240        res = lseek (FD (file), curpos, SEEK_SET);
1241        if (res == -1 || errno != 0) {
1242          diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_SET);
1243          exit_genie (p, A68G_RUNTIME_ERROR);
1244        }
1245        PUSH_VALUE (p, (int) res, A68G_INT);
1246      }
1247    }
1248  }
1249  
1250  //! @brief PROC (REF FILE) VOID reset
1251  
1252  void genie_reset (NODE_T * p)
1253  {
1254    A68G_REF ref_file;
1255    POP_REF (p, &ref_file);
1256    CHECK_REF (p, ref_file, M_REF_FILE);
1257    A68G_FILE *file = FILE_DEREF (&ref_file);
1258    CHECK_INIT (p, INITIALISED (file), M_FILE);
1259    if (!OPENED (file)) {
1260      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1261      exit_genie (p, A68G_RUNTIME_ERROR);
1262    }
1263    if (!RESET (&CHANNEL (file))) {
1264      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CANT_RESET);
1265      exit_genie (p, A68G_RUNTIME_ERROR);
1266    }
1267    if (IS_NIL (STRING (file))) {
1268      close_file_entry (p, FILE_ENTRY (file));
1269    } else {
1270      STRPOS (file) = 0;
1271    }
1272    READ_MOOD (file) = A68G_FALSE;
1273    WRITE_MOOD (file) = A68G_FALSE;
1274    CHAR_MOOD (file) = A68G_FALSE;
1275    DRAW_MOOD (file) = A68G_FALSE;
1276    FD (file) = A68G_NO_FILE;
1277  //  set_default_event_procedures (file);.
1278  }
1279  
1280  //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on file end
1281  
1282  void genie_on_file_end (NODE_T * p)
1283  {
1284    A68G_PROCEDURE z;
1285    POP_PROCEDURE (p, &z);
1286    A68G_REF ref_file;
1287    POP_REF (p, &ref_file);
1288    CHECK_REF (p, ref_file, M_REF_FILE);
1289    A68G_FILE *file = FILE_DEREF (&ref_file);
1290    CHECK_INIT (p, INITIALISED (file), M_FILE);
1291    FILE_END_MENDED (file) = z;
1292  }
1293  
1294  //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on page end
1295  
1296  void genie_on_page_end (NODE_T * p)
1297  {
1298    A68G_PROCEDURE z;
1299    POP_PROCEDURE (p, &z);
1300    A68G_REF ref_file;
1301    POP_REF (p, &ref_file);
1302    CHECK_REF (p, ref_file, M_REF_FILE);
1303    A68G_FILE *file = FILE_DEREF (&ref_file);
1304    CHECK_INIT (p, INITIALISED (file), M_FILE);
1305    PAGE_END_MENDED (file) = z;
1306  }
1307  
1308  //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on line end
1309  
1310  void genie_on_line_end (NODE_T * p)
1311  {
1312    A68G_PROCEDURE z;
1313    POP_PROCEDURE (p, &z);
1314    A68G_REF ref_file;
1315    POP_REF (p, &ref_file);
1316    CHECK_REF (p, ref_file, M_REF_FILE);
1317    A68G_FILE *file = FILE_DEREF (&ref_file);
1318    CHECK_INIT (p, INITIALISED (file), M_FILE);
1319    LINE_END_MENDED (file) = z;
1320  }
1321  
1322  //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format end
1323  
1324  void genie_on_format_end (NODE_T * p)
1325  {
1326    A68G_PROCEDURE z;
1327    POP_PROCEDURE (p, &z);
1328    A68G_REF ref_file;
1329    POP_REF (p, &ref_file);
1330    CHECK_REF (p, ref_file, M_REF_FILE);
1331    A68G_FILE *file = FILE_DEREF (&ref_file);
1332    CHECK_INIT (p, INITIALISED (file), M_FILE);
1333    FORMAT_END_MENDED (file) = z;
1334  }
1335  
1336  //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format error
1337  
1338  void genie_on_format_error (NODE_T * p)
1339  {
1340    A68G_PROCEDURE z;
1341    POP_PROCEDURE (p, &z);
1342    A68G_REF ref_file;
1343    POP_REF (p, &ref_file);
1344    CHECK_REF (p, ref_file, M_REF_FILE);
1345    A68G_FILE *file = FILE_DEREF (&ref_file);
1346    CHECK_INIT (p, INITIALISED (file), M_FILE);
1347    FORMAT_ERROR_MENDED (file) = z;
1348  }
1349  
1350  //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on value error
1351  
1352  void genie_on_value_error (NODE_T * p)
1353  {
1354    A68G_PROCEDURE z;
1355    POP_PROCEDURE (p, &z);
1356    A68G_REF ref_file;
1357    POP_REF (p, &ref_file);
1358    CHECK_REF (p, ref_file, M_REF_FILE);
1359    A68G_FILE *file = FILE_DEREF (&ref_file);
1360    CHECK_INIT (p, INITIALISED (file), M_FILE);
1361    VALUE_ERROR_MENDED (file) = z;
1362  }
1363  
1364  //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on open error
1365  
1366  void genie_on_open_error (NODE_T * p)
1367  {
1368    A68G_PROCEDURE z;
1369    POP_PROCEDURE (p, &z);
1370    A68G_REF ref_file;
1371    POP_REF (p, &ref_file);
1372    CHECK_REF (p, ref_file, M_REF_FILE);
1373    A68G_FILE *file = FILE_DEREF (&ref_file);
1374    CHECK_INIT (p, INITIALISED (file), M_FILE);
1375    OPEN_ERROR_MENDED (file) = z;
1376  }
1377  
1378  //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on transput error
1379  
1380  void genie_on_transput_error (NODE_T * p)
1381  {
1382    A68G_PROCEDURE z;
1383    POP_PROCEDURE (p, &z);
1384    A68G_REF ref_file;
1385    POP_REF (p, &ref_file);
1386    CHECK_REF (p, ref_file, M_REF_FILE);
1387    A68G_FILE *file = FILE_DEREF (&ref_file);
1388    CHECK_INIT (p, INITIALISED (file), M_FILE);
1389    TRANSPUT_ERROR_MENDED (file) = z;
1390  }
1391  
1392  //! @brief Invoke event routine.
1393  
1394  void on_event_handler (NODE_T * p, A68G_PROCEDURE z, A68G_REF ref_file)
1395  {
1396    if (NODE (&(BODY (&z))) == NO_NODE) {
1397  // Default procedure.
1398      PUSH_VALUE (p, A68G_FALSE, A68G_BOOL);
1399    } else {
1400      ADDR_T pop_sp = A68G_SP, pop_fp = A68G_FP;
1401      PUSH_REF (p, ref_file);
1402      genie_call_event_routine (p, M_PROC_REF_FILE_BOOL, &z, pop_sp, pop_fp);
1403    }
1404  }
1405  
1406  //! @brief Handle end-of-file event.
1407  
1408  void end_of_file_error (NODE_T * p, A68G_REF ref_file)
1409  {
1410    on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1411    A68G_BOOL z;
1412    POP_OBJECT (p, &z, A68G_BOOL);
1413    if (VALUE (&z) == A68G_FALSE) {
1414      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1415      exit_genie (p, A68G_RUNTIME_ERROR);
1416    }
1417  }
1418  
1419  //! @brief Handle file-open-error event.
1420  
1421  void open_error (NODE_T * p, A68G_REF ref_file, char *mode)
1422  {
1423    on_event_handler (p, OPEN_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file);
1424    A68G_BOOL z;
1425    POP_OBJECT (p, &z, A68G_BOOL);
1426    if (VALUE (&z) == A68G_FALSE) {
1427      CHECK_REF (p, ref_file, M_REF_FILE);
1428      A68G_FILE *file = FILE_DEREF (&ref_file);
1429      CHECK_INIT (p, INITIALISED (file), M_FILE);
1430      char *filename;
1431      if (!IS_NIL (IDENTIFICATION (file))) {
1432        filename = DEREF (char, &IDENTIFICATION (FILE_DEREF (&ref_file)));
1433      } else {
1434        filename = "(missing filename)";
1435      }
1436      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CANNOT_OPEN_FOR, filename, mode);
1437      exit_genie (p, A68G_RUNTIME_ERROR);
1438    }
1439  }
1440  
1441  //! @brief Handle value error event.
1442  
1443  void value_error (NODE_T * p, MOID_T * m, A68G_REF ref_file)
1444  {
1445    A68G_FILE *f = FILE_DEREF (&ref_file);
1446    if (END_OF_FILE (f)) {
1447      end_of_file_error (p, ref_file);
1448    } else {
1449      on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file);
1450      A68G_BOOL z;
1451      POP_OBJECT (p, &z, A68G_BOOL);
1452      if (VALUE (&z) == A68G_FALSE) {
1453        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m);
1454        exit_genie (p, A68G_RUNTIME_ERROR);
1455      }
1456    }
1457  }
1458  
1459  //! @brief Handle value_error event.
1460  
1461  void value_sign_error (NODE_T * p, MOID_T * m, A68G_REF ref_file)
1462  {
1463    A68G_FILE *f = FILE_DEREF (&ref_file);
1464    if (END_OF_FILE (f)) {
1465      end_of_file_error (p, ref_file);
1466    } else {
1467      on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file);
1468      A68G_BOOL z;
1469      POP_OBJECT (p, &z, A68G_BOOL);
1470      if (VALUE (&z) == A68G_FALSE) {
1471        diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT_SIGN, m);
1472        exit_genie (p, A68G_RUNTIME_ERROR);
1473      }
1474    }
1475  }
1476  
1477  //! @brief Handle transput-error event.
1478  
1479  void transput_error (NODE_T * p, A68G_REF ref_file, MOID_T * m)
1480  {
1481    on_event_handler (p, TRANSPUT_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file);
1482    A68G_BOOL z;
1483    POP_OBJECT (p, &z, A68G_BOOL);
1484    if (VALUE (&z) == A68G_FALSE) {
1485      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m);
1486      exit_genie (p, A68G_RUNTIME_ERROR);
1487    }
1488  }
1489  
1490  // Implementation of put and get.
1491  
1492  //! @brief Get next char from file.
1493  
1494  int char_scanner (A68G_FILE * f)
1495  {
1496    if (get_transput_buffer_index (TRANSPUT_BUFFER (f)) > 0) {
1497  // There are buffered characters.
1498      END_OF_FILE (f) = A68G_FALSE;
1499      return pop_char_transput_buffer (TRANSPUT_BUFFER (f));
1500    } else if (IS_NIL (STRING (f))) {
1501  // Fetch next CHAR from the FILE.
1502      char ch;
1503      ssize_t chars_read = io_read_conv (FD (f), &ch, 1);
1504      if (chars_read == 1) {
1505        END_OF_FILE (f) = A68G_FALSE;
1506        return ch;
1507      } else {
1508        END_OF_FILE (f) = A68G_TRUE;
1509        return EOF_CHAR;
1510      }
1511    } else {
1512  // File is associated with a STRING. Give next CHAR. 
1513  // When we're outside the STRING give EOF_CHAR. 
1514      A68G_REF z = *DEREF (A68G_REF, &STRING (f)); A68G_ARRAY *arr; A68G_TUPLE *tup;
1515      GET_DESCRIPTOR (arr, tup, &z);
1516      int k = STRPOS (f) + LWB (tup);
1517      if (ROW_SIZE (tup) <= 0 || k < LWB (tup) || k > UPB (tup)) {
1518        END_OF_FILE (f) = A68G_TRUE;
1519        return EOF_CHAR;
1520      } else {
1521        BYTE_T *base = DEREF (BYTE_T, &ARRAY (arr));
1522        A68G_CHAR *ch = (A68G_CHAR *) & (base[INDEX_1_DIM (arr, tup, k)]);
1523        STRPOS (f)++;
1524        return VALUE (ch);
1525      }
1526    }
1527  }
1528  
1529  //! @brief Push back look-ahead character to file.
1530  
1531  void unchar_scanner (NODE_T * p, A68G_FILE * f, char ch)
1532  {
1533    END_OF_FILE (f) = A68G_FALSE;
1534    plusab_transput_buffer (p, TRANSPUT_BUFFER (f), ch);
1535  }
1536  
1537  //! @brief PROC (REF FILE) BOOL eof
1538  
1539  void genie_eof (NODE_T * p)
1540  {
1541    A68G_REF ref_file;
1542    POP_REF (p, &ref_file);
1543    CHECK_REF (p, ref_file, M_REF_FILE);
1544    A68G_FILE *file = FILE_DEREF (&ref_file);
1545    CHECK_INIT (p, INITIALISED (file), M_FILE);
1546    if (!OPENED (file)) {
1547      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1548      exit_genie (p, A68G_RUNTIME_ERROR);
1549    }
1550    if (DRAW_MOOD (file)) {
1551      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1552      exit_genie (p, A68G_RUNTIME_ERROR);
1553    }
1554    if (WRITE_MOOD (file)) {
1555      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1556      exit_genie (p, A68G_RUNTIME_ERROR);
1557    } else if (READ_MOOD (file)) {
1558      int ch = char_scanner (file);
1559      PUSH_VALUE (p, (BOOL_T) ((ch == EOF_CHAR || END_OF_FILE (file)) ? A68G_TRUE : A68G_FALSE), A68G_BOOL);
1560      unchar_scanner (p, file, (char) ch);
1561    } else {
1562      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1563      exit_genie (p, A68G_RUNTIME_ERROR);
1564    }
1565  }
1566  
1567  //! @brief PROC (REF FILE) BOOL eoln
1568  
1569  void genie_eoln (NODE_T * p)
1570  {
1571    A68G_REF ref_file;
1572    POP_REF (p, &ref_file);
1573    CHECK_REF (p, ref_file, M_REF_FILE);
1574    A68G_FILE *file = FILE_DEREF (&ref_file);
1575    CHECK_INIT (p, INITIALISED (file), M_FILE);
1576    if (!OPENED (file)) {
1577      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1578      exit_genie (p, A68G_RUNTIME_ERROR);
1579    }
1580    if (DRAW_MOOD (file)) {
1581      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1582      exit_genie (p, A68G_RUNTIME_ERROR);
1583    }
1584    if (WRITE_MOOD (file)) {
1585      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1586      exit_genie (p, A68G_RUNTIME_ERROR);
1587    } else if (READ_MOOD (file)) {
1588      int ch = char_scanner (file);
1589      if (END_OF_FILE (file)) {
1590        end_of_file_error (p, ref_file);
1591      }
1592      PUSH_VALUE (p, (BOOL_T) (ch == NEWLINE_CHAR ? A68G_TRUE : A68G_FALSE), A68G_BOOL);
1593      unchar_scanner (p, file, (char) ch);
1594    } else {
1595      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1596      exit_genie (p, A68G_RUNTIME_ERROR);
1597    }
1598  }
1599  
1600  //! @brief PROC (REF FILE) VOID new line
1601  
1602  void genie_new_line (NODE_T * p)
1603  {
1604    A68G_REF ref_file;
1605    POP_REF (p, &ref_file);
1606    CHECK_REF (p, ref_file, M_REF_FILE);
1607    A68G_FILE *file = FILE_DEREF (&ref_file);
1608    CHECK_INIT (p, INITIALISED (file), M_FILE);
1609    if (!OPENED (file)) {
1610      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1611      exit_genie (p, A68G_RUNTIME_ERROR);
1612    }
1613    if (DRAW_MOOD (file)) {
1614      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1615      exit_genie (p, A68G_RUNTIME_ERROR);
1616    }
1617    if (WRITE_MOOD (file)) {
1618      on_event_handler (p, LINE_END_MENDED (file), ref_file);
1619      if (IS_NIL (STRING (file))) {
1620        WRITE (FD (file), NEWLINE_STRING);
1621      } else {
1622        add_c_string_to_a_string (p, STRING (file), NEWLINE_STRING);
1623      }
1624    } else if (READ_MOOD (file)) {
1625      BOOL_T siga = A68G_TRUE;
1626      while (siga) {
1627        int ch;
1628        if (END_OF_FILE (file)) {
1629          end_of_file_error (p, ref_file);
1630        }
1631        ch = char_scanner (file);
1632        siga = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1633      }
1634    } else {
1635      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1636      exit_genie (p, A68G_RUNTIME_ERROR);
1637    }
1638  }
1639  
1640  //! @brief PROC (REF FILE) VOID new page
1641  
1642  void genie_new_page (NODE_T * p)
1643  {
1644    A68G_REF ref_file;
1645    POP_REF (p, &ref_file);
1646    CHECK_REF (p, ref_file, M_REF_FILE);
1647    A68G_FILE *file = FILE_DEREF (&ref_file);
1648    CHECK_INIT (p, INITIALISED (file), M_FILE);
1649    if (!OPENED (file)) {
1650      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1651      exit_genie (p, A68G_RUNTIME_ERROR);
1652    }
1653    if (DRAW_MOOD (file)) {
1654      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1655      exit_genie (p, A68G_RUNTIME_ERROR);
1656    }
1657    if (WRITE_MOOD (file)) {
1658      on_event_handler (p, PAGE_END_MENDED (file), ref_file);
1659      if (IS_NIL (STRING (file))) {
1660        WRITE (FD (file), "\f");
1661      } else {
1662        add_c_string_to_a_string (p, STRING (file), "\f");
1663      }
1664    } else if (READ_MOOD (file)) {
1665      BOOL_T siga = A68G_TRUE;
1666      while (siga) {
1667        if (END_OF_FILE (file)) {
1668          end_of_file_error (p, ref_file);
1669        }
1670        int ch = char_scanner (file);
1671        siga = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1672      }
1673    } else {
1674      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1675      exit_genie (p, A68G_RUNTIME_ERROR);
1676    }
1677  }
1678  
1679  //! @brief PROC (REF FILE) VOID space
1680  
1681  void genie_space (NODE_T * p)
1682  {
1683    A68G_REF ref_file;
1684    POP_REF (p, &ref_file);
1685    CHECK_REF (p, ref_file, M_REF_FILE);
1686    A68G_FILE *file = FILE_DEREF (&ref_file);
1687    CHECK_INIT (p, INITIALISED (file), M_FILE);
1688    if (!OPENED (file)) {
1689      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1690      exit_genie (p, A68G_RUNTIME_ERROR);
1691    }
1692    if (DRAW_MOOD (file)) {
1693      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1694      exit_genie (p, A68G_RUNTIME_ERROR);
1695    }
1696    if (WRITE_MOOD (file)) {
1697      WRITE (FD (file), " ");
1698    } else if (READ_MOOD (file)) {
1699      if (!END_OF_FILE (file)) {
1700        (void) char_scanner (file);
1701      }
1702    } else {
1703      diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1704      exit_genie (p, A68G_RUNTIME_ERROR);
1705    }
1706  }
     


© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)