rts-internal.c

     
   1  //! @file rts-internal.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-transput.h"
  30  
  31  // These routines use A68G's RR transput routines,
  32  // essentially mimicking code of the form
  33  //    PROC puts = (REF STRING s, [] SIMPLOUT items) VOID:
  34  //         BEGIN FILE f;
  35  //               associate (f, s);
  36  //               put (f, items);
  37  //               close (f)
  38  //         END 
  39  // which is not the most efficient, though practical.
  40  
  41  static void associate (A68_FILE *f, A68_REF s)
  42  {
  43    STATUS (f) = INIT_MASK;
  44    FILE_ENTRY (f) = -1;
  45    CHANNEL (f) = A68 (associate_channel);
  46    OPENED (f) = A68_TRUE;
  47    OPEN_EXCLUSIVE (f) = A68_FALSE;
  48    READ_MOOD (f) = A68_FALSE;
  49    WRITE_MOOD (f) = A68_FALSE;
  50    CHAR_MOOD (f) = A68_FALSE;
  51    DRAW_MOOD (f) = A68_FALSE;
  52    TMP_FILE (f) = A68_FALSE;
  53    IDENTIFICATION (f) = nil_ref;
  54    TERMINATOR (f) = nil_ref;
  55    FORMAT (f) = nil_format;
  56    FD (f) = A68_NO_FILE;
  57    STRING (f) = s;
  58    STRPOS (f) = 0;
  59    DEVICE_MADE (&DEVICE (f)) = A68_FALSE;
  60    STREAM (&DEVICE (f)) = NO_STREAM;
  61    set_default_event_procedures (f);
  62  }
  63  
  64  //! @brief PROC (REF STRING, [] SIMPLIN) VOID gets
  65  
  66  void genie_get_text (NODE_T * p)
  67  {
  68  // Block GC momentarily.
  69    A68_GC (sema)++;
  70  // Pop [] SIMPLIN.
  71    A68_REF row; 
  72    POP_REF (p, &row);
  73    CHECK_REF (p, row, M_ROW_SIMPLIN);
  74  // Pop REF STRING.
  75    A68_REF ref_string;
  76    POP_REF (p, &ref_string);
  77    CHECK_REF (p, ref_string, M_REF_STRING);
  78  // Associate a temp file with argument string.
  79    A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
  80    A68_FILE *file = FILE_DEREF (&ref_file);
  81    associate (file, ref_string);
  82    open_for_reading (p, ref_file);
  83  // Read.
  84    A68_ARRAY *arr; A68_TUPLE *tup;
  85    GET_DESCRIPTOR (arr, tup, &row);
  86    int elems = ROW_SIZE (tup);
  87    if (elems > 0) {
  88      BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
  89      int elem_index = 0;
  90      for (int k = 0; k < elems; k++) {
  91        A68_UNION *z = (A68_UNION *) & base_address[elem_index];
  92        MOID_T *mode = (MOID_T *) (VALUE (z));
  93        BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
  94        genie_read_standard (p, mode, item, ref_file);
  95        elem_index += SIZE (M_SIMPLIN);
  96      }
  97    }
  98  // Discard temp file.
  99    unblock_transput_buffer (TRANSPUT_BUFFER (file));
 100    A68_GC (sema)--;
 101  }
 102  
 103  //! @brief PROC (REF STRING, [] SIMPLOUT) VOID puts
 104  
 105  void genie_put_text (NODE_T * p)
 106  {
 107  // Block GC momentarily.
 108    A68_GC (sema)++;
 109  // Pop [] SIMPLOUT.
 110    A68_REF row; 
 111    POP_REF (p, &row);
 112    CHECK_REF (p, row, M_ROW_SIMPLOUT);
 113  // Pop REF STRING.
 114    A68_REF ref_string;
 115    POP_REF (p, &ref_string);
 116    CHECK_REF (p, ref_string, M_REF_STRING);
 117  // Associate a temp file with argument string.
 118    A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
 119    A68_FILE *file = FILE_DEREF (&ref_file);
 120    associate (file, ref_string);
 121    open_for_writing (p, ref_file);
 122  // Write.
 123    A68_ARRAY *arr; A68_TUPLE *tup;
 124    GET_DESCRIPTOR (arr, tup, &row);
 125    int elems = ROW_SIZE (tup);
 126    if (elems > 0) {
 127      reset_transput_buffer (UNFORMATTED_BUFFER);
 128      BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
 129      int elem_index = 0;
 130      for (int k = 0; k < elems; k++) {
 131        A68_UNION *z = (A68_UNION *) & base_address[elem_index];
 132        MOID_T *mode = (MOID_T *) (VALUE (z));
 133        BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
 134        genie_write_standard (p, mode, item, ref_file);
 135        elem_index += SIZE (M_SIMPLOUT);
 136      }
 137      * DEREF (A68_REF, &ref_string) = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
 138    }
 139  // Discard temp file.
 140    unblock_transput_buffer (TRANSPUT_BUFFER (file));
 141    A68_GC (sema)--;
 142  }
 143  
 144  //! @brief PROC (REF STRING, [] SIMPLIN) VOID getsf
 145  
 146  void genie_getf_text (NODE_T * p)
 147  {
 148  // Block GC momentarily.
 149    A68_GC (sema)++;
 150  // Pop [] SIMPLIN.
 151    A68_REF row; 
 152    POP_REF (p, &row);
 153    CHECK_REF (p, row, M_ROW_SIMPLIN);
 154  // Pop REF STRING.
 155    A68_REF ref_string;
 156    POP_REF (p, &ref_string);
 157    CHECK_REF (p, ref_string, M_REF_STRING);
 158  // Associate a temp file with argument string.
 159    A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
 160    A68_FILE *file = FILE_DEREF (&ref_file);
 161    associate (file, ref_string);
 162    open_for_reading (p, ref_file);
 163  // Save stack state since formats have frames.
 164    ADDR_T pop_fp = FRAME_POINTER (file);
 165    ADDR_T pop_sp = STACK_POINTER (file);
 166    FRAME_POINTER (file) = A68_FP;
 167    STACK_POINTER (file) = A68_SP;
 168  // Process [] SIMPLIN.
 169    if (BODY (&FORMAT (file)) != NO_NODE) {
 170      open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
 171    }
 172    int formats = 0;
 173  // Read.
 174    A68_ARRAY *arr; A68_TUPLE *tup;
 175    GET_DESCRIPTOR (arr, tup, &row);
 176    int elems = ROW_SIZE (tup);
 177    if (elems > 0) {
 178      BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
 179      int elem_index = 0;
 180      for (int k = 0; k < elems; k++) {
 181        A68_UNION *z = (A68_UNION *) & base_address[elem_index];
 182        MOID_T *mode = (MOID_T *) (VALUE (z));
 183        BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
 184        genie_read_standard_format (p, mode, item, ref_file, &formats);
 185        elem_index += SIZE (M_SIMPLIN);
 186      }
 187    }
 188  // Empty the format to purge insertions.
 189    purge_format_read (p, ref_file);
 190    BODY (&FORMAT (file)) = NO_NODE;
 191  // Forget about active formats.
 192    A68_FP = FRAME_POINTER (file);
 193    A68_SP = STACK_POINTER (file);
 194    FRAME_POINTER (file) = pop_fp;
 195    STACK_POINTER (file) = pop_sp;
 196  // Discard temp file.
 197    unblock_transput_buffer (TRANSPUT_BUFFER (file));
 198    A68_GC (sema)--;
 199  }
 200  
 201  //! @brief PROC (REF STRING, [] SIMPLOUT) VOID putsf
 202  
 203  void genie_putf_text (NODE_T * p)
 204  {
 205  // Block GC momentarily.
 206    A68_GC (sema)++;
 207  // Pop [] SIMPLOUT.
 208    A68_REF row; 
 209    POP_REF (p, &row);
 210    CHECK_REF (p, row, M_ROW_SIMPLOUT);
 211  // Pop REF STRING.
 212    A68_REF ref_string;
 213    POP_REF (p, &ref_string);
 214    CHECK_REF (p, ref_string, M_REF_STRING);
 215  // Associate a temp file with argument string.
 216    A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
 217    A68_FILE *file = FILE_DEREF (&ref_file);
 218    associate (file, ref_string);
 219    open_for_writing (p, ref_file);
 220  // Save stack state since formats have frames.
 221    ADDR_T pop_fp = FRAME_POINTER (file);
 222    ADDR_T pop_sp = STACK_POINTER (file);
 223    FRAME_POINTER (file) = A68_FP;
 224    STACK_POINTER (file) = A68_SP;
 225  // Process [] SIMPLIN.
 226    if (BODY (&FORMAT (file)) != NO_NODE) {
 227      open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
 228    }
 229    int formats = 0;
 230  // Write.
 231    A68_ARRAY *arr; A68_TUPLE *tup;
 232    GET_DESCRIPTOR (arr, tup, &row);
 233    int elems = ROW_SIZE (tup);
 234    if (elems > 0) {
 235      reset_transput_buffer (FORMATTED_BUFFER);
 236      BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
 237      int elem_index = 0;
 238      for (int k = 0; k < elems; k++) {
 239        A68_UNION *z = (A68_UNION *) & base_address[elem_index];
 240        MOID_T *mode = (MOID_T *) (VALUE (z));
 241        BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
 242        genie_write_standard_format (p, mode, item, ref_file, &formats);
 243        elem_index += SIZE (M_SIMPLOUT);
 244      }
 245      * DEREF (A68_REF, &ref_string) = c_to_a_string (p, get_transput_buffer (FORMATTED_BUFFER), DEFAULT_WIDTH);
 246    }
 247  // Empty the format to purge insertions.
 248    purge_format_write (p, ref_file);
 249    write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
 250    BODY (&FORMAT (file)) = NO_NODE;
 251  // Forget about active formats.
 252    A68_FP = FRAME_POINTER (file);
 253    A68_SP = STACK_POINTER (file);
 254    FRAME_POINTER (file) = pop_fp;
 255    STACK_POINTER (file) = pop_sp;
 256  // Discard temp file.
 257    unblock_transput_buffer (TRANSPUT_BUFFER (file));
 258    A68_GC (sema)--;
 259  }
 260  
 261  //! @brief PROC (REF STRING, [] SIMPLOUT) REF STRING string
 262  
 263  void genie_string (NODE_T * p)
 264  {
 265  // Block GC momentarily.
 266    A68_GC (sema)++;
 267  // Pop [] SIMPLOUT.
 268    A68_REF row; 
 269    POP_REF (p, &row);
 270    CHECK_REF (p, row, M_ROW_SIMPLOUT);
 271  // Pop REF STRING.
 272    A68_REF ref_string;
 273    POP_REF (p, &ref_string);
 274    CHECK_REF (p, ref_string, M_REF_STRING);
 275  // Associate a temp file with argument string.
 276    A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
 277    A68_FILE *file = FILE_DEREF (&ref_file);
 278    associate (file, ref_string);
 279    open_for_writing (p, ref_file);
 280  // Write.
 281    A68_ARRAY *arr; A68_TUPLE *tup;
 282    GET_DESCRIPTOR (arr, tup, &row);
 283    int elems = ROW_SIZE (tup);
 284    if (elems > 0) {
 285      reset_transput_buffer (UNFORMATTED_BUFFER);
 286      BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
 287      int elem_index = 0;
 288      for (int k = 0; k < elems; k++) {
 289        A68_UNION *z = (A68_UNION *) & base_address[elem_index];
 290        MOID_T *mode = (MOID_T *) (VALUE (z));
 291        BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
 292        genie_write_standard (p, mode, item, ref_file);
 293        elem_index += SIZE (M_SIMPLOUT);
 294      }
 295      * DEREF (A68_REF, &ref_string) = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
 296    }
 297    PUSH_REF (p, ref_string);
 298  // Discard temp file.
 299    unblock_transput_buffer (TRANSPUT_BUFFER (file));
 300    A68_GC (sema)--;
 301  }
 302  
 303  //! @brief PROC (REF STRING, [] SIMPLOUT) REF STRING stringf
 304  
 305  void genie_stringf (NODE_T * p)
 306  {
 307  // Block GC momentarily.
 308    A68_GC (sema)++;
 309  // Pop [] SIMPLOUT.
 310    A68_REF row; 
 311    POP_REF (p, &row);
 312    CHECK_REF (p, row, M_ROW_SIMPLOUT);
 313  // Pop REF STRING.
 314    A68_REF ref_string;
 315    POP_REF (p, &ref_string);
 316    CHECK_REF (p, ref_string, M_REF_STRING);
 317  // Associate a temp file with argument string.
 318    A68_REF ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
 319    A68_FILE *file = FILE_DEREF (&ref_file);
 320    associate (file, ref_string);
 321    open_for_writing (p, ref_file);
 322  // Save stack state since formats have frames.
 323    ADDR_T pop_fp = FRAME_POINTER (file);
 324    ADDR_T pop_sp = STACK_POINTER (file);
 325    FRAME_POINTER (file) = A68_FP;
 326    STACK_POINTER (file) = A68_SP;
 327  // Process [] SIMPLIN.
 328    if (BODY (&FORMAT (file)) != NO_NODE) {
 329      open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
 330    }
 331    int formats = 0;
 332  // Write.
 333    A68_ARRAY *arr; A68_TUPLE *tup;
 334    GET_DESCRIPTOR (arr, tup, &row);
 335    int elems = ROW_SIZE (tup);
 336    if (elems > 0) {
 337      reset_transput_buffer (FORMATTED_BUFFER);
 338      BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
 339      int elem_index = 0;
 340      for (int k = 0; k < elems; k++) {
 341        A68_UNION *z = (A68_UNION *) & base_address[elem_index];
 342        MOID_T *mode = (MOID_T *) (VALUE (z));
 343        BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
 344        genie_write_standard_format (p, mode, item, ref_file, &formats);
 345        elem_index += SIZE (M_SIMPLOUT);
 346      }
 347      * DEREF (A68_REF, &ref_string) = c_to_a_string (p, get_transput_buffer (FORMATTED_BUFFER), DEFAULT_WIDTH);
 348    }
 349  // Empty the format to purge insertions.
 350    purge_format_write (p, ref_file);
 351    write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
 352    BODY (&FORMAT (file)) = NO_NODE;
 353  // Forget about active formats.
 354    A68_FP = FRAME_POINTER (file);
 355    A68_SP = STACK_POINTER (file);
 356    FRAME_POINTER (file) = pop_fp;
 357    STACK_POINTER (file) = pop_sp;
 358    PUSH_REF (p, ref_string);
 359  // Discard temp file.
 360    unblock_transput_buffer (TRANSPUT_BUFFER (file));
 361    A68_GC (sema)--;
 362  }