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