genie-unix.c

     
   1  //! @file genie-unix.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  //! Low-level UNIX routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-prelude.h"
  29  #include "a68g-mp.h"
  30  #include "a68g-physics.h"
  31  #include "a68g-numbers.h"
  32  #include "a68g-optimiser.h"
  33  #include "a68g-double.h"
  34  #include "a68g-transput.h"
  35  
  36  #define VECTOR_SIZE 512
  37  #define FD_READ 0
  38  #define FD_WRITE 1
  39  
  40  #if defined (HAVE_DIRENT_H)
  41  
  42  //! @brief PROC (STRING) [] STRING directory
  43  
  44  void genie_directory (NODE_T * p)
  45  {
  46    A68_REF name;
  47    char *buffer;
  48    errno = 0;
  49    POP_REF (p, &name);
  50    CHECK_INIT (p, INITIALISED (&name), M_STRING);
  51    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__);
  52    if (buffer == NO_TEXT) {
  53      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
  54      exit_genie (p, A68_RUNTIME_ERROR);
  55      PUSH_VALUE (p, A68_MAX_INT, A68_INT);
  56    } else {
  57      char *dir_name = a_to_c_string (p, buffer, name);
  58      A68_REF z, row;
  59      A68_ARRAY arr;
  60      A68_TUPLE tup;
  61      int k, n = 0;
  62      A68_REF *base;
  63      DIR *dir;
  64      struct dirent *entry;
  65      dir = opendir (dir_name);
  66      if (dir == NULL) {
  67        diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
  68        exit_genie (p, A68_RUNTIME_ERROR);
  69      }
  70      do {
  71        entry = readdir (dir);
  72        if (errno != 0) {
  73          diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
  74          exit_genie (p, A68_RUNTIME_ERROR);
  75        }
  76        if (entry != NULL) {
  77          n++;
  78        }
  79      } while (entry != NULL);
  80      rewinddir (dir);
  81      if (errno != 0) {
  82        diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
  83        exit_genie (p, A68_RUNTIME_ERROR);
  84      }
  85      NEW_ROW_1D (z, row, arr, tup, M_ROW_STRING, M_STRING, n);
  86      base = DEREF (A68_REF, &row);
  87      for (k = 0; k < n; k++) {
  88        entry = readdir (dir);
  89        if (errno != 0) {
  90          diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
  91          exit_genie (p, A68_RUNTIME_ERROR);
  92        }
  93        base[k] = c_to_a_string (p, D_NAME (entry), DEFAULT_WIDTH);
  94      }
  95      if (closedir (dir) != 0) {
  96        diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
  97        exit_genie (p, A68_RUNTIME_ERROR);
  98      }
  99      PUSH_REF (p, z);
 100      a68_free (buffer);
 101    }
 102  }
 103  
 104  #endif
 105  
 106  //! @brief PROC [] INT utc time
 107  
 108  void genie_utctime (NODE_T * p)
 109  {
 110    time_t dt;
 111    if (time (&dt) == (time_t) - 1) {
 112      (void) empty_row (p, M_ROW_INT);
 113    } else {
 114      A68_REF row;
 115      ADDR_T sp = A68_SP;
 116      struct tm *tod = gmtime (&dt);
 117      PUSH_VALUE (p, TM_YEAR (tod) + 1900, A68_INT);
 118      PUSH_VALUE (p, TM_MON (tod) + 1, A68_INT);
 119      PUSH_VALUE (p, TM_MDAY (tod), A68_INT);
 120      PUSH_VALUE (p, TM_HOUR (tod), A68_INT);
 121      PUSH_VALUE (p, TM_MIN (tod), A68_INT);
 122      PUSH_VALUE (p, TM_SEC (tod), A68_INT);
 123      PUSH_VALUE (p, TM_WDAY (tod) + 1, A68_INT);
 124      PUSH_VALUE (p, TM_ISDST (tod), A68_INT);
 125      row = genie_make_row (p, M_INT, 8, sp);
 126      A68_SP = sp;
 127      PUSH_REF (p, row);
 128    }
 129  }
 130  
 131  //! @brief PROC [] INT local time
 132  
 133  void genie_localtime (NODE_T * p)
 134  {
 135    time_t dt;
 136    if (time (&dt) == (time_t) - 1) {
 137      (void) empty_row (p, M_ROW_INT);
 138    } else {
 139      A68_REF row;
 140      ADDR_T sp = A68_SP;
 141      struct tm *tod = localtime (&dt);
 142      PUSH_VALUE (p, TM_YEAR (tod) + 1900, A68_INT);
 143      PUSH_VALUE (p, TM_MON (tod) + 1, A68_INT);
 144      PUSH_VALUE (p, TM_MDAY (tod), A68_INT);
 145      PUSH_VALUE (p, TM_HOUR (tod), A68_INT);
 146      PUSH_VALUE (p, TM_MIN (tod), A68_INT);
 147      PUSH_VALUE (p, TM_SEC (tod), A68_INT);
 148      PUSH_VALUE (p, TM_WDAY (tod) + 1, A68_INT);
 149      PUSH_VALUE (p, TM_ISDST (tod), A68_INT);
 150      row = genie_make_row (p, M_INT, 8, sp);
 151      A68_SP = sp;
 152      PUSH_REF (p, row);
 153    }
 154  }
 155  
 156  //! @brief PROC INT rows
 157  
 158  void genie_rows (NODE_T * p)
 159  {
 160    errno = 0;
 161    PUSH_VALUE (p, A68 (term_heigth), A68_INT);
 162  }
 163  
 164  //! @brief PROC INT columns
 165  
 166  void genie_columns (NODE_T * p)
 167  {
 168    errno = 0;
 169    PUSH_VALUE (p, A68 (term_width), A68_INT);
 170  }
 171  
 172  //! @brief PROC INT argc
 173  
 174  void genie_argc (NODE_T * p)
 175  {
 176    errno = 0;
 177    PUSH_VALUE (p, A68 (argc), A68_INT);
 178  }
 179  
 180  //! @brief PROC (INT) STRING argv
 181  
 182  void genie_argv (NODE_T * p)
 183  {
 184    A68_INT a68_index;
 185    errno = 0;
 186    POP_OBJECT (p, &a68_index, A68_INT);
 187    if (VALUE (&a68_index) >= 1 && VALUE (&a68_index) <= A68 (argc)) {
 188      char *q = A68 (argv)[VALUE (&a68_index) - 1];
 189      int n = (int) strlen (q);
 190  // Allow for spaces ending in # to have A68 comment syntax with '#!'.
 191      while (n > 0 && (IS_SPACE (q[n - 1]) || q[n - 1] == '#')) {
 192        q[--n] = NULL_CHAR;
 193      }
 194      PUSH_REF (p, c_to_a_string (p, q, DEFAULT_WIDTH));
 195    } else {
 196      PUSH_REF (p, empty_string (p));
 197    }
 198  }
 199  
 200  //! @brief Find good argument
 201  
 202  int find_good_arg (void)
 203  {
 204    int i;
 205    for (i = 0; i < A68 (argc); i++) {
 206      char *q = A68 (argv)[i];
 207      if (strncmp (q, "--script", 8) == 0) {
 208        return i + 1;
 209      }
 210      if (strncmp (q, "--run-script", 12) == 0) {
 211        return i + 1;
 212      }
 213      if (strcmp (q, "--") == 0) {
 214        return i;
 215      }
 216      if (strcmp (q, "--exit") == 0) {
 217        return i;
 218      }
 219    }
 220    return 0;
 221  }
 222  
 223  //! @brief PROC INT a68g argc
 224  
 225  void genie_a68_argc (NODE_T * p)
 226  {
 227    errno = 0;
 228    PUSH_VALUE (p, A68 (argc) - find_good_arg (), A68_INT);
 229  }
 230  
 231  //! @brief PROC (INT) STRING a68_argv
 232  
 233  void genie_a68_argv (NODE_T * p)
 234  {
 235    A68_INT a68_index;
 236    int k;
 237    errno = 0;
 238    POP_OBJECT (p, &a68_index, A68_INT);
 239    k = VALUE (&a68_index);
 240    if (k > 1) {
 241      k += find_good_arg ();
 242    }
 243    if (k >= 1 && k <= A68 (argc)) {
 244      char *q = A68 (argv)[k - 1];
 245      int n = (int) strlen (q);
 246  // Allow for spaces ending in # to have A68 comment syntax with '#!'.
 247      while (n > 0 && (IS_SPACE (q[n - 1]) || q[n - 1] == '#')) {
 248        q[--n] = NULL_CHAR;
 249      }
 250      PUSH_REF (p, c_to_a_string (p, q, DEFAULT_WIDTH));
 251    } else {
 252      PUSH_REF (p, empty_string (p));
 253    }
 254  }
 255  
 256  //! @brief PROC STRING pwd
 257  
 258  void genie_pwd (NODE_T * p)
 259  {
 260    size_t size = BUFFER_SIZE;
 261    char *buffer = NO_TEXT;
 262    BOOL_T cont = A68_TRUE;
 263    errno = 0;
 264    while (cont) {
 265      buffer = (char *) a68_alloc (size, __func__, __LINE__);
 266      if (buffer == NO_TEXT) {
 267        diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 268        exit_genie (p, A68_RUNTIME_ERROR);
 269      }
 270      if (getcwd (buffer, size) == buffer) {
 271        cont = A68_FALSE;
 272      } else {
 273        a68_free (buffer);
 274        cont = (BOOL_T) (errno == 0);
 275        size *= 2;
 276      }
 277    }
 278    if (buffer != NO_TEXT && errno == 0) {
 279      PUSH_REF (p, c_to_a_string (p, buffer, DEFAULT_WIDTH));
 280      a68_free (buffer);
 281    } else {
 282      PUSH_REF (p, empty_string (p));
 283    }
 284  }
 285  
 286  //! @brief PROC (STRING) INT cd
 287  
 288  void genie_cd (NODE_T * p)
 289  {
 290    A68_REF dir;
 291    char *buffer;
 292    errno = 0;
 293    POP_REF (p, &dir);
 294    CHECK_INIT (p, INITIALISED (&dir), M_STRING);
 295    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, dir)), __func__, __LINE__);
 296    if (buffer == NO_TEXT) {
 297      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 298      exit_genie (p, A68_RUNTIME_ERROR);
 299    } else {
 300      int rc = chdir (a_to_c_string (p, buffer, dir));
 301      if (rc == 0) {
 302        PUSH_VALUE (p, 0, A68_INT);
 303      } else {
 304        diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS);
 305        exit_genie (p, A68_RUNTIME_ERROR);
 306      }
 307      a68_free (buffer);
 308    }
 309  }
 310  
 311  //! @brief PROC (STRING) BITS
 312  
 313  void genie_file_mode (NODE_T * p)
 314  {
 315    A68_REF name;
 316    char *buffer;
 317    errno = 0;
 318    POP_REF (p, &name);
 319    CHECK_INIT (p, INITIALISED (&name), M_STRING);
 320    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__);
 321    if (buffer == NO_TEXT) {
 322      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 323      exit_genie (p, A68_RUNTIME_ERROR);
 324    } else {
 325      struct stat status;
 326      if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
 327        PUSH_VALUE (p, (unt) (ST_MODE (&status)), A68_BITS);
 328      } else {
 329        PUSH_VALUE (p, 0x0, A68_BITS);
 330      }
 331      a68_free (buffer);
 332    }
 333  }
 334  
 335  //! @brief PROC (STRING) BOOL file is block device
 336  
 337  void genie_file_is_block_device (NODE_T * p)
 338  {
 339    A68_REF name;
 340    char *buffer;
 341    errno = 0;
 342    POP_REF (p, &name);
 343    CHECK_INIT (p, INITIALISED (&name), M_STRING);
 344    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__);
 345    if (buffer == NO_TEXT) {
 346      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 347      exit_genie (p, A68_RUNTIME_ERROR);
 348    } else {
 349      struct stat status;
 350      if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
 351        PUSH_VALUE (p, (BOOL_T) (S_ISBLK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
 352      } else {
 353        PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 354      }
 355      a68_free (buffer);
 356    }
 357  }
 358  
 359  //! @brief PROC (STRING) BOOL file is char device
 360  
 361  void genie_file_is_char_device (NODE_T * p)
 362  {
 363    A68_REF name;
 364    char *buffer;
 365    errno = 0;
 366    POP_REF (p, &name);
 367    CHECK_INIT (p, INITIALISED (&name), M_STRING);
 368    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__);
 369    if (buffer == NO_TEXT) {
 370      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 371      exit_genie (p, A68_RUNTIME_ERROR);
 372    } else {
 373      struct stat status;
 374      if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
 375        PUSH_VALUE (p, (BOOL_T) (S_ISCHR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
 376      } else {
 377        PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 378      }
 379      a68_free (buffer);
 380    }
 381  }
 382  
 383  //! @brief PROC (STRING) BOOL file is directory
 384  
 385  void genie_file_is_directory (NODE_T * p)
 386  {
 387    A68_REF name;
 388    char *buffer;
 389    errno = 0;
 390    POP_REF (p, &name);
 391    CHECK_INIT (p, INITIALISED (&name), M_STRING);
 392    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__);
 393    if (buffer == NO_TEXT) {
 394      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 395      exit_genie (p, A68_RUNTIME_ERROR);
 396    } else {
 397      struct stat status;
 398      if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
 399        PUSH_VALUE (p, (BOOL_T) (S_ISDIR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
 400      } else {
 401        PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 402      }
 403      a68_free (buffer);
 404    }
 405  }
 406  
 407  //! @brief PROC (STRING) BOOL file is regular
 408  
 409  void genie_file_is_regular (NODE_T * p)
 410  {
 411    A68_REF name;
 412    char *buffer;
 413    errno = 0;
 414    POP_REF (p, &name);
 415    CHECK_INIT (p, INITIALISED (&name), M_STRING);
 416    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__);
 417    if (buffer == NO_TEXT) {
 418      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 419      exit_genie (p, A68_RUNTIME_ERROR);
 420    } else {
 421      struct stat status;
 422      if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
 423        PUSH_VALUE (p, (BOOL_T) (S_ISREG (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
 424      } else {
 425        PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 426      }
 427      a68_free (buffer);
 428    }
 429  }
 430  
 431  #if defined (S_ISFIFO)
 432  
 433  //! @brief PROC (STRING) BOOL file is fifo
 434  
 435  void genie_file_is_fifo (NODE_T * p)
 436  {
 437    A68_REF name;
 438    char *buffer;
 439    errno = 0;
 440    POP_REF (p, &name);
 441    CHECK_INIT (p, INITIALISED (&name), M_STRING);
 442    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__);
 443    if (buffer == NO_TEXT) {
 444      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 445      exit_genie (p, A68_RUNTIME_ERROR);
 446    } else {
 447      struct stat status;
 448      if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
 449        PUSH_VALUE (p, (BOOL_T) (S_ISFIFO (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
 450      } else {
 451        PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 452      }
 453      a68_free (buffer);
 454    }
 455  }
 456  
 457  #endif
 458  
 459  #if defined (S_ISLNK)
 460  
 461  //! @brief PROC (STRING) BOOL file is link
 462  
 463  void genie_file_is_link (NODE_T * p)
 464  {
 465    A68_REF name;
 466    char *buffer;
 467    errno = 0;
 468    POP_REF (p, &name);
 469    CHECK_INIT (p, INITIALISED (&name), M_STRING);
 470    buffer = (char *) a68_alloc ((size_t) (1 + a68_string_size (p, name)), __func__, __LINE__);
 471    if (buffer == NO_TEXT) {
 472      diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
 473      exit_genie (p, A68_RUNTIME_ERROR);
 474    } else {
 475      struct stat status;
 476      if (stat (a_to_c_string (p, buffer, name), &status) == 0) {
 477        PUSH_VALUE (p, (BOOL_T) (S_ISLNK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL);
 478      } else {
 479        PUSH_VALUE (p, A68_FALSE, A68_BOOL);
 480      }
 481      a68_free (buffer);
 482    }
 483  }
 484  
 485  #endif
 486  
 487  //! @brief Convert [] STRING row to char *vec[].
 488  
 489  void convert_string_vector (NODE_T * p, char *vec[], A68_REF row)
 490  {
 491    BYTE_T *z = ADDRESS (&row);
 492    A68_ARRAY *arr = (A68_ARRAY *) & z[0];
 493    A68_TUPLE *tup = (A68_TUPLE *) & z[SIZE_ALIGNED (A68_ARRAY)];
 494    int k = 0;
 495    if (get_row_size (tup, DIM (arr)) > 0) {
 496      BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
 497      BOOL_T done = A68_FALSE;
 498      initialise_internal_index (tup, DIM (arr));
 499      while (!done) {
 500        ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
 501        ADDR_T elem_addr = (a68_index + SLICE_OFFSET (arr)) * ELEM_SIZE (arr) + FIELD_OFFSET (arr);
 502        BYTE_T *elem = &base_addr[elem_addr];
 503        int size = a68_string_size (p, *(A68_REF *) elem);
 504        CHECK_INIT (p, INITIALISED ((A68_REF *) elem), M_STRING);
 505        vec[k] = (char *) get_heap_space ((size_t) (1 + size));
 506        ASSERT (a_to_c_string (p, vec[k], *(A68_REF *) elem) != NO_TEXT);
 507        if (k == VECTOR_SIZE - 1) {
 508          diagnostic (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_ARGUMENTS);
 509          exit_genie (p, A68_RUNTIME_ERROR);
 510        }
 511        if (strlen (vec[k]) > 0) {
 512          k++;
 513        }
 514        done = increment_internal_index (tup, DIM (arr));
 515      }
 516    }
 517    vec[k] = NO_TEXT;
 518  }
 519  
 520  //! @brief Free char *vec[].
 521  
 522  void free_vector (char *vec[])
 523  {
 524    int k = 0;
 525    while (vec[k] != NO_TEXT) {
 526      a68_free (vec[k]);
 527      k++;
 528    }
 529  }
 530  
 531  //! @brief Reset error number.
 532  
 533  void genie_reset_errno (NODE_T * p)
 534  {
 535    (void) *p;
 536    errno = 0;
 537  }
 538  
 539  //! @brief Error number.
 540  
 541  void genie_errno (NODE_T * p)
 542  {
 543    PUSH_VALUE (p, errno, A68_INT);
 544  }
 545  
 546  //! @brief PROC strerror = (INT) STRING
 547  
 548  void genie_strerror (NODE_T * p)
 549  {
 550    A68_INT i;
 551    POP_OBJECT (p, &i, A68_INT);
 552    PUSH_REF (p, c_to_a_string (p, strerror (VALUE (&i)), DEFAULT_WIDTH));
 553  }
 554  
 555  //! @brief Set up file for usage in pipe.
 556  
 557  void set_up_file (NODE_T * p, A68_REF * z, int fd, A68_CHANNEL chan, BOOL_T r_mood, BOOL_T w_mood, int pid)
 558  {
 559    A68_FILE *f;
 560    *z = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
 561    f = FILE_DEREF (z);
 562    STATUS (f) = (STATUS_MASK_T) ((pid < 0) ? 0 : INIT_MASK);
 563    IDENTIFICATION (f) = nil_ref;
 564    TERMINATOR (f) = nil_ref;
 565    CHANNEL (f) = chan;
 566    FD (f) = fd;
 567    STREAM (&DEVICE (f)) = NO_STREAM;
 568    OPENED (f) = A68_TRUE;
 569    OPEN_EXCLUSIVE (f) = A68_FALSE;
 570    READ_MOOD (f) = r_mood;
 571    WRITE_MOOD (f) = w_mood;
 572    CHAR_MOOD (f) = A68_TRUE;
 573    DRAW_MOOD (f) = A68_FALSE;
 574    FORMAT (f) = nil_format;
 575    TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p);
 576    STRING (f) = nil_ref;
 577    reset_transput_buffer (TRANSPUT_BUFFER (f));
 578    set_default_event_procedures (f);
 579  }
 580  
 581  //! @brief Create and push a pipe.
 582  
 583  void genie_mkpipe (NODE_T * p, int fd_r, int fd_w, int pid)
 584  {
 585    A68_REF r, w;
 586    errno = 0;
 587  // Set up pipe.
 588    set_up_file (p, &r, fd_r, A68 (stand_in_channel), A68_TRUE, A68_FALSE, pid);
 589    set_up_file (p, &w, fd_w, A68 (stand_out_channel), A68_FALSE, A68_TRUE, pid);
 590  // push pipe.
 591    PUSH_REF (p, r);
 592    PUSH_REF (p, w);
 593    PUSH_VALUE (p, pid, A68_INT);
 594  }
 595  
 596  //! @brief Push an environment string.
 597  
 598  void genie_getenv (NODE_T * p)
 599  {
 600    A68_REF a_env;
 601    char *val, *z, *z_env;
 602    errno = 0;
 603    POP_REF (p, &a_env);
 604    CHECK_INIT (p, INITIALISED (&a_env), M_STRING);
 605    z_env = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_env)));
 606    z = a_to_c_string (p, z_env, a_env);
 607    val = getenv (z);
 608    if (val == NO_TEXT) {
 609      a_env = empty_string (p);
 610    } else {
 611      a_env = tmp_to_a68_string (p, val);
 612    }
 613    PUSH_REF (p, a_env);
 614  }
 615  
 616  //! @brief PROC fork = INT
 617  
 618  void genie_fork (NODE_T * p)
 619  {
 620  #if defined (BUILD_WIN32)
 621    PUSH_VALUE (p, -1, A68_INT);
 622  #else
 623    int pid;
 624    errno = 0;
 625    pid = (int) fork ();
 626    PUSH_VALUE (p, pid, A68_INT);
 627  #endif
 628  }
 629  
 630  //! @brief PROC execve = (STRING, [] STRING, [] STRING) INT 
 631  
 632  void genie_exec (NODE_T * p)
 633  {
 634    int ret;
 635    A68_REF a_prog, a_args, a_env;
 636    char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE];
 637    errno = 0;
 638  // Pop parameters.
 639    POP_REF (p, &a_env);
 640    POP_REF (p, &a_args);
 641    POP_REF (p, &a_prog);
 642  // Convert strings and hasta el infinito.
 643    prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog)));
 644    ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT);
 645    convert_string_vector (p, argv, a_args);
 646    convert_string_vector (p, envp, a_env);
 647    if (argv[0] == NO_TEXT) {
 648      diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT);
 649      exit_genie (p, A68_RUNTIME_ERROR);
 650    }
 651    ret = execve (prog, argv, envp);
 652  // execve only returns if it fails.
 653    free_vector (argv);
 654    free_vector (envp);
 655    a68_free (prog);
 656    PUSH_VALUE (p, ret, A68_INT);
 657  }
 658  
 659  //! @brief PROC execve child = (STRING, [] STRING, [] STRING) INT
 660  
 661  void genie_exec_sub (NODE_T * p)
 662  {
 663    int pid;
 664    A68_REF a_prog, a_args, a_env;
 665    errno = 0;
 666  // Pop parameters.
 667    POP_REF (p, &a_env);
 668    POP_REF (p, &a_args);
 669    POP_REF (p, &a_prog);
 670  // Now create the pipes and fork.
 671  #if defined (BUILD_WIN32)
 672    pid = -1;
 673    (void) pid;
 674    PUSH_VALUE (p, -1, A68_INT);
 675    return;
 676  #else
 677    pid = (int) fork ();
 678    if (pid == -1) {
 679      PUSH_VALUE (p, -1, A68_INT);
 680    } else if (pid == 0) {
 681  // Child process.
 682      char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE];
 683  // Convert  strings.
 684      prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog)));
 685      ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT);
 686      convert_string_vector (p, argv, a_args);
 687      convert_string_vector (p, envp, a_env);
 688      if (argv[0] == NO_TEXT) {
 689        diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT);
 690        exit_genie (p, A68_RUNTIME_ERROR);
 691      }
 692      (void) execve (prog, argv, envp);
 693  // execve only returns if it fails - end child process.
 694      a68_exit (EXIT_FAILURE);
 695      PUSH_VALUE (p, 0, A68_INT);
 696    } else {
 697  // parent process.
 698      PUSH_VALUE (p, pid, A68_INT);
 699    }
 700  #endif
 701  }
 702  
 703  //! @brief PROC execve child pipe = (STRING, [] STRING, [] STRING) PIPE
 704  
 705  void genie_exec_sub_pipeline (NODE_T * p)
 706  {
 707  // Child redirects STDIN and STDOUT.
 708  // Return a PIPE that contains the descriptors for the parent.
 709  // 
 710  //        pipe ptoc
 711  //        ->W...R->
 712  //  PARENT         CHILD
 713  //        <-R...W<-
 714  //        pipe ctop
 715  
 716    int pid;
 717    A68_REF a_prog, a_args, a_env;
 718    errno = 0;
 719  // Pop parameters.
 720    POP_REF (p, &a_env);
 721    POP_REF (p, &a_args);
 722    POP_REF (p, &a_prog);
 723  #if !defined (BUILD_UNIX)
 724    pid = -1;
 725    (void) pid;
 726    genie_mkpipe (p, -1, -1, -1);
 727    return;
 728  #else
 729  // Create the pipes and fork.
 730    int ptoc_fd[2], ctop_fd[2];
 731    if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) {
 732      genie_mkpipe (p, -1, -1, -1);
 733      return;
 734    }
 735    pid = (int) fork ();
 736    if (pid == -1) {
 737  // Fork failure.
 738      genie_mkpipe (p, -1, -1, -1);
 739      return;
 740    }
 741    if (pid == 0) {
 742  // Child process.
 743      char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE];
 744  // Convert  strings.
 745      prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog)));
 746      ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT);
 747      convert_string_vector (p, argv, a_args);
 748      convert_string_vector (p, envp, a_env);
 749  // Set up redirection.
 750      ASSERT (close (ctop_fd[FD_READ]) == 0);
 751      ASSERT (close (ptoc_fd[FD_WRITE]) == 0);
 752      ASSERT (close (STDIN_FILENO) == 0);
 753      ASSERT (close (STDOUT_FILENO) == 0);
 754      ASSERT (dup2 (ptoc_fd[FD_READ], STDIN_FILENO) != -1);
 755      ASSERT (dup2 (ctop_fd[FD_WRITE], STDOUT_FILENO) != -1);
 756      if (argv[0] == NO_TEXT) {
 757        diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT);
 758        exit_genie (p, A68_RUNTIME_ERROR);
 759      }
 760      (void) execve (prog, argv, envp);
 761  // execve only returns if it fails - end child process.
 762      a68_exit (EXIT_FAILURE);
 763      genie_mkpipe (p, -1, -1, -1);
 764    } else {
 765  // Parent process.
 766      ASSERT (close (ptoc_fd[FD_READ]) == 0);
 767      ASSERT (close (ctop_fd[FD_WRITE]) == 0);
 768      genie_mkpipe (p, ctop_fd[FD_READ], ptoc_fd[FD_WRITE], pid);
 769    }
 770  #endif
 771  }
 772  
 773  //! @brief PROC execve output = (STRING, [] STRING, [] STRING, REF_STRING) INT
 774  
 775  void genie_exec_sub_output (NODE_T * p)
 776  {
 777  // Child redirects STDIN and STDOUT.
 778  // 
 779  //        pipe ptoc
 780  //        ->W...R->
 781  //  PARENT         CHILD
 782  //        <-R...W<-
 783  //       pipe ctop
 784  
 785    int pid;
 786    A68_REF a_prog, a_args, a_env, dest;
 787    errno = 0;
 788  // Pop parameters.
 789    POP_REF (p, &dest);
 790    POP_REF (p, &a_env);
 791    POP_REF (p, &a_args);
 792    POP_REF (p, &a_prog);
 793  #if !defined (BUILD_UNIX)
 794    pid = -1;
 795    (void) pid;
 796    PUSH_VALUE (p, -1, A68_INT);
 797    return;
 798  #else
 799  // Create the pipes and fork.
 800    int ptoc_fd[2], ctop_fd[2];
 801    if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) {
 802      PUSH_VALUE (p, -1, A68_INT);
 803      return;
 804    }
 805    pid = (int) fork ();
 806    if (pid == -1) {
 807  // Fork failure.
 808      PUSH_VALUE (p, -1, A68_INT);
 809      return;
 810    }
 811    if (pid == 0) {
 812  // Child process.
 813      char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE];
 814  // Convert  strings.
 815      prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog)));
 816      ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT);
 817      convert_string_vector (p, argv, a_args);
 818      convert_string_vector (p, envp, a_env);
 819  // Set up redirection.
 820      ASSERT (close (ctop_fd[FD_READ]) == 0);
 821      ASSERT (close (ptoc_fd[FD_WRITE]) == 0);
 822      ASSERT (close (STDIN_FILENO) == 0);
 823      ASSERT (close (STDOUT_FILENO) == 0);
 824      ASSERT (dup2 (ptoc_fd[FD_READ], STDIN_FILENO) != -1);
 825      ASSERT (dup2 (ctop_fd[FD_WRITE], STDOUT_FILENO) != -1);
 826      if (argv[0] == NO_TEXT) {
 827        diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT);
 828        exit_genie (p, A68_RUNTIME_ERROR);
 829      }
 830      (void) execve (prog, argv, envp);
 831  // execve only returns if it fails - end child process.
 832      a68_exit (EXIT_FAILURE);
 833      PUSH_VALUE (p, -1, A68_INT);
 834    } else {
 835  // Parent process.
 836      char ch;
 837      int pipe_read, ret, status;
 838      ASSERT (close (ptoc_fd[FD_READ]) == 0);
 839      ASSERT (close (ctop_fd[FD_WRITE]) == 0);
 840      reset_transput_buffer (INPUT_BUFFER);
 841      do {
 842        pipe_read = (int) io_read_conv (ctop_fd[FD_READ], &ch, 1);
 843        if (pipe_read > 0) {
 844          plusab_transput_buffer (p, INPUT_BUFFER, ch);
 845        }
 846      } while (pipe_read > 0);
 847      do {
 848        ret = (int) waitpid ((a68_pid_t) pid, &status, 0);
 849      } while (ret == -1 && errno == EINTR);
 850      if (ret != pid) {
 851        status = -1;
 852      }
 853      if (!IS_NIL (dest)) {
 854        *DEREF (A68_REF, &dest) = c_to_a_string (p, get_transput_buffer (INPUT_BUFFER), get_transput_buffer_index (INPUT_BUFFER));
 855      }
 856      ASSERT (close (ptoc_fd[FD_WRITE]) == 0);
 857      ASSERT (close (ctop_fd[FD_READ]) == 0);
 858      PUSH_VALUE (p, ret, A68_INT);
 859    }
 860  #endif
 861  }
 862  
 863  //! @brief PROC create pipe = PIPE
 864  
 865  void genie_create_pipe (NODE_T * p)
 866  {
 867    errno = 0;
 868    genie_stand_in (p);
 869    genie_stand_out (p);
 870    PUSH_VALUE (p, -1, A68_INT);
 871  }
 872  
 873  //! @brief PROC wait pid = (INT) VOID
 874  
 875  void genie_waitpid (NODE_T * p)
 876  {
 877    A68_INT k;
 878    errno = 0;
 879    POP_OBJECT (p, &k, A68_INT);
 880  #if defined (BUILD_UNIX)
 881    ASSERT (waitpid ((a68_pid_t) VALUE (&k), NULL, 0) != -1);
 882  #endif
 883  }