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 }
