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