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