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 null char
486
487 void genie_null_char (NODE_T * p)
488 {
489 PUSH_VALUE (p, NULL_CHAR, A68G_CHAR);
490 }
491
492 //! @brief CHAR blank
493
494 void genie_blank_char (NODE_T * p)
495 {
496 PUSH_VALUE (p, BLANK_CHAR, A68G_CHAR);
497 }
498
499 //! @brief CHAR newline char
500
501 void genie_newline_char (NODE_T * p)
502 {
503 PUSH_VALUE (p, NEWLINE_CHAR, A68G_CHAR);
504 }
505
506 //! @brief CHAR formfeed char
507
508 void genie_formfeed_char (NODE_T * p)
509 {
510 PUSH_VALUE (p, FORMFEED_CHAR, A68G_CHAR);
511 }
512
513 //! @brief CHAR tab char
514
515 void genie_tab_char (NODE_T * p)
516 {
517 PUSH_VALUE (p, TAB_CHAR, A68G_CHAR);
518 }
519
520 //! @brief CHANNEL standin channel
521
522 void genie_stand_in_channel (NODE_T * p)
523 {
524 PUSH_OBJECT (p, A68G (stand_in_channel), A68G_CHANNEL);
525 }
526
527 //! @brief CHANNEL standout channel
528
529 void genie_stand_out_channel (NODE_T * p)
530 {
531 PUSH_OBJECT (p, A68G (stand_out_channel), A68G_CHANNEL);
532 }
533
534 //! @brief CHANNEL stand draw channel
535
536 void genie_stand_draw_channel (NODE_T * p)
537 {
538 PUSH_OBJECT (p, A68G (stand_draw_channel), A68G_CHANNEL);
539 }
540
541 //! @brief CHANNEL standback channel
542
543 void genie_stand_back_channel (NODE_T * p)
544 {
545 PUSH_OBJECT (p, A68G (stand_back_channel), A68G_CHANNEL);
546 }
547
548 //! @brief CHANNEL standerror channel
549
550 void genie_stand_error_channel (NODE_T * p)
551 {
552 PUSH_OBJECT (p, A68G (stand_error_channel), A68G_CHANNEL);
553 }
554
555 //! @brief PROC STRING program idf
556
557 void genie_program_idf (NODE_T * p)
558 {
559 PUSH_REF (p, c_to_a_string (p, FILE_SOURCE_NAME (&A68G_JOB), DEFAULT_WIDTH));
560 }
561
562 // FILE and CHANNEL initialisations.
563
564 //! @brief Set_default_event_procedure.
565
566 void set_default_event_procedure (A68G_PROCEDURE * z)
567 {
568 STATUS (z) = INIT_MASK;
569 NODE (&(BODY (z))) = NO_NODE;
570 ENVIRON (z) = 0;
571 }
572
573 //! @brief Initialise channel.
574
575 void init_channel (A68G_CHANNEL * chan, BOOL_T r, BOOL_T s, BOOL_T g, BOOL_T p, BOOL_T b, BOOL_T d)
576 {
577 STATUS (chan) = INIT_MASK;
578 RESET (chan) = r;
579 SET (chan) = s;
580 GET (chan) = g;
581 PUT (chan) = p;
582 BIN (chan) = b;
583 DRAW (chan) = d;
584 COMPRESS (chan) = A68G_TRUE;
585 }
586
587 //! @brief Set default event handlers.
588
589 void set_default_event_procedures (A68G_FILE * f)
590 {
591 set_default_event_procedure (&(FILE_END_MENDED (f)));
592 set_default_event_procedure (&(PAGE_END_MENDED (f)));
593 set_default_event_procedure (&(LINE_END_MENDED (f)));
594 set_default_event_procedure (&(VALUE_ERROR_MENDED (f)));
595 set_default_event_procedure (&(OPEN_ERROR_MENDED (f)));
596 set_default_event_procedure (&(TRANSPUT_ERROR_MENDED (f)));
597 set_default_event_procedure (&(FORMAT_END_MENDED (f)));
598 set_default_event_procedure (&(FORMAT_ERROR_MENDED (f)));
599 }
600
601 //! @brief Set up a REF FILE object.
602
603 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)
604 {
605 char *filename = (env == NO_TEXT ? NO_TEXT : getenv (env));
606 *ref_file = heap_generator (p, M_REF_FILE, SIZE (M_FILE));
607 BLOCK_GC_HANDLE (ref_file);
608 A68G_FILE *f = FILE_DEREF (ref_file);
609 STATUS (f) = INIT_MASK;
610 TERMINATOR (f) = nil_ref;
611 CHANNEL (f) = c;
612 if (filename != NO_TEXT && strlen (filename) > 0) {
613 size_t len = 1 + strlen (filename);
614 IDENTIFICATION (f) = heap_generator (p, M_C_STRING, len);
615 BLOCK_GC_HANDLE (&(IDENTIFICATION (f)));
616 a68g_bufcpy (DEREF (char, &IDENTIFICATION (f)), filename, len);
617 FD (f) = A68G_NO_FILE;
618 READ_MOOD (f) = A68G_FALSE;
619 WRITE_MOOD (f) = A68G_FALSE;
620 CHAR_MOOD (f) = A68G_FALSE;
621 DRAW_MOOD (f) = A68G_FALSE;
622 } else {
623 IDENTIFICATION (f) = nil_ref;
624 FD (f) = s;
625 READ_MOOD (f) = rm;
626 WRITE_MOOD (f) = wm;
627 CHAR_MOOD (f) = cm;
628 DRAW_MOOD (f) = A68G_FALSE;
629 }
630 TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p);
631 reset_transput_buffer (TRANSPUT_BUFFER (f));
632 END_OF_FILE (f) = A68G_FALSE;
633 TMP_FILE (f) = A68G_FALSE;
634 OPENED (f) = A68G_TRUE;
635 APPEND (f) = A68G_FALSE;
636 OPEN_EXCLUSIVE (f) = A68G_FALSE;
637 FORMAT (f) = nil_format;
638 STRING (f) = nil_ref;
639 STRPOS (f) = 0;
640 FILE_ENTRY (f) = -1;
641 set_default_event_procedures (f);
642 }
643
644 //! @brief Initialise the transput RTL.
645
646 void genie_init_transput (NODE_T * p)
647 {
648 init_transput_buffers (p);
649 // Channels.
650 init_channel (&(A68G (stand_in_channel)), A68G_FALSE, A68G_FALSE, A68G_TRUE, A68G_FALSE, A68G_FALSE, A68G_FALSE);
651 init_channel (&(A68G (stand_out_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_TRUE, A68G_FALSE, A68G_FALSE);
652 init_channel (&(A68G (stand_back_channel)), A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_FALSE);
653 init_channel (&(A68G (stand_error_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_TRUE, A68G_FALSE, A68G_FALSE);
654 init_channel (&(A68G (associate_channel)), A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_TRUE, A68G_FALSE);
655 init_channel (&(A68G (skip_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE);
656 #if defined (HAVE_GNU_PLOTUTILS)
657 init_channel (&(A68G (stand_draw_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_TRUE);
658 #else
659 init_channel (&(A68G (stand_draw_channel)), A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_FALSE, A68G_TRUE);
660 #endif
661 // Files.
662 init_file (p, &(A68G (stand_in)), A68G (stand_in_channel), A68G_STDIN, A68G_TRUE, A68G_FALSE, A68G_TRUE, "A68G_STANDIN");
663 init_file (p, &(A68G (stand_out)), A68G (stand_out_channel), A68G_STDOUT, A68G_FALSE, A68G_TRUE, A68G_TRUE, "A68G_STANDOUT");
664 init_file (p, &(A68G (stand_back)), A68G (stand_back_channel), A68G_NO_FILE, A68G_FALSE, A68G_FALSE, A68G_FALSE, NO_TEXT);
665 init_file (p, &(A68G (stand_error)), A68G (stand_error_channel), A68G_STDERR, A68G_FALSE, A68G_TRUE, A68G_TRUE, "A68G_STANDERROR");
666 init_file (p, &(A68G (skip_file)), A68G (skip_channel), A68G_NO_FILE, A68G_FALSE, A68G_FALSE, A68G_FALSE, NO_TEXT);
667 }
668
669 //! @brief PROC (REF FILE) STRING idf
670
671 void genie_idf (NODE_T * p)
672 {
673 A68G_REF ref_file;
674 POP_REF (p, &ref_file);
675 CHECK_REF (p, ref_file, M_REF_FILE);
676 ref_file = *(A68G_REF *) STACK_TOP;
677 A68G_REF ref_filename = IDENTIFICATION (FILE_DEREF (&ref_file));
678 CHECK_REF (p, ref_filename, M_ROWS);
679 char *filename = DEREF (char, &ref_filename);
680 PUSH_REF (p, c_to_a_string (p, filename, DEFAULT_WIDTH));
681 }
682
683 //! @brief PROC (REF FILE) STRING term
684
685 void genie_term (NODE_T * p)
686 {
687 A68G_REF ref_file;
688 POP_REF (p, &ref_file);
689 CHECK_REF (p, ref_file, M_REF_FILE);
690 ref_file = *(A68G_REF *) STACK_TOP;
691 A68G_REF ref_term = TERMINATOR (FILE_DEREF (&ref_file));
692 CHECK_REF (p, ref_term, M_ROWS);
693 char *term = DEREF (char, &ref_term);
694 PUSH_REF (p, c_to_a_string (p, term, DEFAULT_WIDTH));
695 }
696
697 //! @brief PROC (REF FILE, STRING) VOID make term
698
699 void genie_make_term (NODE_T * p)
700 {
701 A68G_REF ref_file, str;
702 POP_REF (p, &str);
703 POP_REF (p, &ref_file);
704 CHECK_REF (p, ref_file, M_REF_FILE);
705 ref_file = *(A68G_REF *) STACK_TOP;
706 A68G_FILE *file = FILE_DEREF (&ref_file);
707 // Don't check initialisation so we can "make term" before opening.
708 size_t size = a68g_string_size (p, str);
709 if (INITIALISED (&(TERMINATOR (file))) && !IS_NIL (TERMINATOR (file))) {
710 UNBLOCK_GC_HANDLE (&(TERMINATOR (file)));
711 }
712 TERMINATOR (file) = heap_generator (p, M_C_STRING, 1 + size);
713 BLOCK_GC_HANDLE (&(TERMINATOR (file)));
714 ASSERT (a_to_c_string (p, DEREF (char, &TERMINATOR (file)), str) != NO_TEXT);
715 }
716
717 //! @brief PROC (REF FILE) BOOL put possible
718
719 void genie_put_possible (NODE_T * p)
720 {
721 A68G_REF ref_file;
722 POP_REF (p, &ref_file);
723 CHECK_REF (p, ref_file, M_REF_FILE);
724 A68G_FILE *file = FILE_DEREF (&ref_file);
725 CHECK_INIT (p, INITIALISED (file), M_FILE);
726 PUSH_VALUE (p, PUT (&CHANNEL (file)), A68G_BOOL);
727 }
728
729 //! @brief PROC (REF FILE) BOOL get possible
730
731 void genie_get_possible (NODE_T * p)
732 {
733 A68G_REF ref_file;
734 POP_REF (p, &ref_file);
735 CHECK_REF (p, ref_file, M_REF_FILE);
736 A68G_FILE *file = FILE_DEREF (&ref_file);
737 CHECK_INIT (p, INITIALISED (file), M_FILE);
738 PUSH_VALUE (p, GET (&CHANNEL (file)), A68G_BOOL);
739 }
740
741 //! @brief PROC (REF FILE) BOOL bin possible
742
743 void genie_bin_possible (NODE_T * p)
744 {
745 A68G_REF ref_file;
746 POP_REF (p, &ref_file);
747 CHECK_REF (p, ref_file, M_REF_FILE);
748 A68G_FILE *file = FILE_DEREF (&ref_file);
749 CHECK_INIT (p, INITIALISED (file), M_FILE);
750 PUSH_VALUE (p, BIN (&CHANNEL (file)), A68G_BOOL);
751 }
752
753 //! @brief PROC (REF FILE) BOOL set possible
754
755 void genie_set_possible (NODE_T * p)
756 {
757 A68G_REF ref_file;
758 POP_REF (p, &ref_file);
759 CHECK_REF (p, ref_file, M_REF_FILE);
760 A68G_FILE *file = FILE_DEREF (&ref_file);
761 CHECK_INIT (p, INITIALISED (file), M_FILE);
762 PUSH_VALUE (p, SET (&CHANNEL (file)), A68G_BOOL);
763 }
764
765 //! @brief PROC (REF FILE) BOOL reidf possible
766
767 void genie_reidf_possible (NODE_T * p)
768 {
769 A68G_REF ref_file;
770 POP_REF (p, &ref_file);
771 CHECK_REF (p, ref_file, M_REF_FILE);
772 A68G_FILE *file = FILE_DEREF (&ref_file);
773 CHECK_INIT (p, INITIALISED (file), M_FILE);
774 PUSH_VALUE (p, A68G_FALSE, A68G_BOOL);
775 }
776
777 //! @brief PROC (REF FILE) BOOL reset possible
778
779 void genie_reset_possible (NODE_T * p)
780 {
781 A68G_REF ref_file;
782 POP_REF (p, &ref_file);
783 CHECK_REF (p, ref_file, M_REF_FILE);
784 A68G_FILE *file = FILE_DEREF (&ref_file);
785 CHECK_INIT (p, INITIALISED (file), M_FILE);
786 PUSH_VALUE (p, RESET (&CHANNEL (file)), A68G_BOOL);
787 }
788
789 //! @brief PROC (REF FILE) BOOL compressible
790
791 void genie_compressible (NODE_T * p)
792 {
793 A68G_REF ref_file;
794 A68G_FILE *file;
795 POP_REF (p, &ref_file);
796 CHECK_REF (p, ref_file, M_REF_FILE);
797 file = FILE_DEREF (&ref_file);
798 CHECK_INIT (p, INITIALISED (file), M_FILE);
799 PUSH_VALUE (p, COMPRESS (&CHANNEL (file)), A68G_BOOL);
800 }
801
802 //! @brief PROC (REF FILE) BOOL draw possible
803
804 void genie_draw_possible (NODE_T * p)
805 {
806 A68G_REF ref_file;
807 POP_REF (p, &ref_file);
808 CHECK_REF (p, ref_file, M_REF_FILE);
809 A68G_FILE *file = FILE_DEREF (&ref_file);
810 CHECK_INIT (p, INITIALISED (file), M_FILE);
811 PUSH_VALUE (p, DRAW (&CHANNEL (file)), A68G_BOOL);
812 }
813
814 //! @brief PROC (REF FILE, STRING, CHANNEL) INT open
815
816 void genie_open (NODE_T * p)
817 {
818 A68G_CHANNEL channel;
819 POP_OBJECT (p, &channel, A68G_CHANNEL);
820 A68G_REF ref_iden;
821 POP_REF (p, &ref_iden);
822 CHECK_REF (p, ref_iden, M_REF_STRING);
823 A68G_REF ref_file;
824 POP_REF (p, &ref_file);
825 CHECK_REF (p, ref_file, M_REF_FILE);
826 A68G_FILE *file = FILE_DEREF (&ref_file);
827 STATUS (file) = INIT_MASK;
828 FILE_ENTRY (file) = -1;
829 CHANNEL (file) = channel;
830 OPENED (file) = A68G_TRUE;
831 APPEND (file) = A68G_FALSE;
832 OPEN_EXCLUSIVE (file) = A68G_FALSE;
833 READ_MOOD (file) = A68G_FALSE;
834 WRITE_MOOD (file) = A68G_FALSE;
835 CHAR_MOOD (file) = A68G_FALSE;
836 DRAW_MOOD (file) = A68G_FALSE;
837 TMP_FILE (file) = A68G_FALSE;
838 size_t size = a68g_string_size (p, ref_iden);
839 if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
840 UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
841 }
842 IDENTIFICATION (file) = heap_generator (p, M_C_STRING, 1 + size);
843 BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
844 ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT);
845 TERMINATOR (file) = nil_ref;
846 FORMAT (file) = nil_format;
847 FD (file) = A68G_NO_FILE;
848 if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
849 UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
850 }
851 STRING (file) = nil_ref;
852 STRPOS (file) = 0;
853 DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
854 STREAM (&DEVICE (file)) = NO_STREAM;
855 set_default_event_procedures (file);
856 {
857 struct stat status;
858 if (stat (DEREF (char, &IDENTIFICATION (file)), &status) == 0) {
859 PUSH_VALUE (p, (S_ISREG (ST_MODE (&status)) != 0 ? 0 : ENOENT), A68G_INT);
860 } else {
861 PUSH_VALUE (p, errno, A68G_INT);
862 }
863 errno = 0;
864 }
865 }
866
867 //! @brief PROC (REF FILE, STRING, CHANNEL) INT append
868
869 void genie_append (NODE_T * p)
870 {
871 A68G_CHANNEL channel;
872 POP_OBJECT (p, &channel, A68G_CHANNEL);
873 A68G_REF ref_iden;
874 POP_REF (p, &ref_iden);
875 CHECK_REF (p, ref_iden, M_REF_STRING);
876 A68G_REF ref_file;
877 POP_REF (p, &ref_file);
878 CHECK_REF (p, ref_file, M_REF_FILE);
879 A68G_FILE *file = FILE_DEREF (&ref_file);
880 STATUS (file) = INIT_MASK;
881 FILE_ENTRY (file) = -1;
882 CHANNEL (file) = channel;
883 OPENED (file) = A68G_TRUE;
884 APPEND (file) = A68G_TRUE;
885 OPEN_EXCLUSIVE (file) = A68G_FALSE;
886 READ_MOOD (file) = A68G_FALSE;
887 WRITE_MOOD (file) = A68G_FALSE;
888 CHAR_MOOD (file) = A68G_FALSE;
889 DRAW_MOOD (file) = A68G_FALSE;
890 TMP_FILE (file) = A68G_FALSE;
891 size_t size = a68g_string_size (p, ref_iden);
892 if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
893 UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
894 }
895 IDENTIFICATION (file) = heap_generator (p, M_C_STRING, 1 + size);
896 BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
897 ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT);
898 TERMINATOR (file) = nil_ref;
899 FORMAT (file) = nil_format;
900 FD (file) = A68G_NO_FILE;
901 if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
902 UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
903 }
904 STRING (file) = nil_ref;
905 STRPOS (file) = 0;
906 DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
907 STREAM (&DEVICE (file)) = NO_STREAM;
908 set_default_event_procedures (file);
909 {
910 struct stat status;
911 if (stat (DEREF (char, &IDENTIFICATION (file)), &status) == 0) {
912 PUSH_VALUE (p, (S_ISREG (ST_MODE (&status)) != 0 ? 0 : ENOENT), A68G_INT);
913 } else {
914 PUSH_VALUE (p, errno, A68G_INT);
915 }
916 errno = 0;
917 }
918 }
919
920 //! @brief PROC (REF FILE, STRING, CHANNEL) INT establish
921
922 void genie_establish (NODE_T * p)
923 {
924 A68G_CHANNEL channel;
925 POP_OBJECT (p, &channel, A68G_CHANNEL);
926 A68G_REF ref_iden;
927 POP_REF (p, &ref_iden);
928 CHECK_REF (p, ref_iden, M_REF_STRING);
929 A68G_REF ref_file;
930 POP_REF (p, &ref_file);
931 CHECK_REF (p, ref_file, M_REF_FILE);
932 A68G_FILE *file = FILE_DEREF (&ref_file);
933 STATUS (file) = INIT_MASK;
934 FILE_ENTRY (file) = -1;
935 CHANNEL (file) = channel;
936 OPENED (file) = A68G_TRUE;
937 APPEND (file) = A68G_FALSE;
938 OPEN_EXCLUSIVE (file) = A68G_TRUE;
939 READ_MOOD (file) = A68G_FALSE;
940 WRITE_MOOD (file) = A68G_FALSE;
941 CHAR_MOOD (file) = A68G_FALSE;
942 DRAW_MOOD (file) = A68G_FALSE;
943 TMP_FILE (file) = A68G_FALSE;
944 if (!PUT (&CHANNEL (file))) {
945 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
946 exit_genie (p, A68G_RUNTIME_ERROR);
947 }
948 size_t size = a68g_string_size (p, ref_iden);
949 if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
950 UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
951 }
952 IDENTIFICATION (file) = heap_generator (p, M_C_STRING, 1 + size);
953 BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
954 ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT);
955 TERMINATOR (file) = nil_ref;
956 FORMAT (file) = nil_format;
957 FD (file) = A68G_NO_FILE;
958 if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
959 UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
960 }
961 STRING (file) = nil_ref;
962 STRPOS (file) = 0;
963 DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
964 STREAM (&DEVICE (file)) = NO_STREAM;
965 set_default_event_procedures (file);
966 PUSH_VALUE (p, 0, A68G_INT);
967 }
968
969 //! @brief PROC (REF FILE, CHANNEL) INT create
970
971 void genie_create (NODE_T * p)
972 {
973 A68G_CHANNEL channel;
974 POP_OBJECT (p, &channel, A68G_CHANNEL);
975 A68G_REF ref_file;
976 POP_REF (p, &ref_file);
977 CHECK_REF (p, ref_file, M_REF_FILE);
978 A68G_FILE *file = FILE_DEREF (&ref_file);
979 STATUS (file) = INIT_MASK;
980 FILE_ENTRY (file) = -1;
981 CHANNEL (file) = channel;
982 OPENED (file) = A68G_TRUE;
983 APPEND (file) = A68G_FALSE;
984 OPEN_EXCLUSIVE (file) = A68G_FALSE;
985 READ_MOOD (file) = A68G_FALSE;
986 WRITE_MOOD (file) = A68G_FALSE;
987 CHAR_MOOD (file) = A68G_FALSE;
988 DRAW_MOOD (file) = A68G_FALSE;
989 TMP_FILE (file) = A68G_TRUE;
990 if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
991 UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
992 }
993 IDENTIFICATION (file) = nil_ref;
994 TERMINATOR (file) = nil_ref;
995 FORMAT (file) = nil_format;
996 FD (file) = A68G_NO_FILE;
997 if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
998 UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
999 }
1000 STRING (file) = nil_ref;
1001 STRPOS (file) = 0;
1002 DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1003 STREAM (&DEVICE (file)) = NO_STREAM;
1004 set_default_event_procedures (file);
1005 PUSH_VALUE (p, 0, A68G_INT);
1006 }
1007
1008 //! @brief PROC (REF FILE, REF STRING) VOID associate
1009
1010 void genie_associate (NODE_T * p)
1011 {
1012 A68G_REF ref_string;
1013 POP_REF (p, &ref_string);
1014 CHECK_REF (p, ref_string, M_REF_STRING);
1015 A68G_REF ref_file;
1016 POP_REF (p, &ref_file);
1017 CHECK_REF (p, ref_file, M_REF_FILE);
1018 if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) {
1019 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, M_REF_STRING);
1020 exit_genie (p, A68G_RUNTIME_ERROR);
1021 } else if (IS_IN_FRAME (&ref_file) && IS_IN_FRAME (&ref_string)) {
1022 if (REF_SCOPE (&ref_string) > REF_SCOPE (&ref_file)) {
1023 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, M_REF_STRING);
1024 exit_genie (p, A68G_RUNTIME_ERROR);
1025 }
1026 }
1027 A68G_FILE *file = FILE_DEREF (&ref_file);
1028 STATUS (file) = INIT_MASK;
1029 FILE_ENTRY (file) = -1;
1030 CHANNEL (file) = A68G (associate_channel);
1031 OPENED (file) = A68G_TRUE;
1032 APPEND (file) = A68G_FALSE;
1033 OPEN_EXCLUSIVE (file) = A68G_FALSE;
1034 READ_MOOD (file) = A68G_FALSE;
1035 WRITE_MOOD (file) = A68G_FALSE;
1036 CHAR_MOOD (file) = A68G_FALSE;
1037 DRAW_MOOD (file) = A68G_FALSE;
1038 TMP_FILE (file) = A68G_FALSE;
1039 if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) {
1040 UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
1041 }
1042 IDENTIFICATION (file) = nil_ref;
1043 TERMINATOR (file) = nil_ref;
1044 FORMAT (file) = nil_format;
1045 FD (file) = A68G_NO_FILE;
1046 if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) {
1047 UNBLOCK_GC_HANDLE (DEREF (A68G_REF, &STRING (file)));
1048 }
1049 STRING (file) = ref_string;
1050 BLOCK_GC_HANDLE ((A68G_REF *) (&(STRING (file))));
1051 STRPOS (file) = 0;
1052 DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1053 STREAM (&DEVICE (file)) = NO_STREAM;
1054 set_default_event_procedures (file);
1055 }
1056
1057 //! @brief PROC (REF FILE) VOID close
1058
1059 void genie_close (NODE_T * p)
1060 {
1061 A68G_REF ref_file;
1062 POP_REF (p, &ref_file);
1063 CHECK_REF (p, ref_file, M_REF_FILE);
1064 A68G_FILE *file = FILE_DEREF (&ref_file);
1065 CHECK_INIT (p, INITIALISED (file), M_FILE);
1066 if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
1067 return;
1068 }
1069 DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1070 #if defined (HAVE_GNU_PLOTUTILS)
1071 if (DEVICE_OPENED (&DEVICE (file))) {
1072 ASSERT (close_device (p, file) == A68G_TRUE);
1073 STREAM (&DEVICE (file)) = NO_STREAM;
1074 return;
1075 }
1076 #endif
1077 FD (file) = A68G_NO_FILE;
1078 OPENED (file) = A68G_FALSE;
1079 unblock_transput_buffer (TRANSPUT_BUFFER (file));
1080 set_default_event_procedures (file);
1081 free_file_entry (p, FILE_ENTRY (file));
1082 }
1083
1084 //! @brief PROC (REF FILE) VOID lock
1085
1086 void genie_lock (NODE_T * p)
1087 {
1088 A68G_REF ref_file;
1089 POP_REF (p, &ref_file);
1090 CHECK_REF (p, ref_file, M_REF_FILE);
1091 A68G_FILE *file = FILE_DEREF (&ref_file);
1092 CHECK_INIT (p, INITIALISED (file), M_FILE);
1093 if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
1094 return;
1095 }
1096 DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1097 #if defined (HAVE_GNU_PLOTUTILS)
1098 if (DEVICE_OPENED (&DEVICE (file))) {
1099 ASSERT (close_device (p, file) == A68G_TRUE);
1100 STREAM (&DEVICE (file)) = NO_STREAM;
1101 return;
1102 }
1103 #endif
1104 #if defined (BUILD_UNIX)
1105 errno = 0;
1106 ASSERT (fchmod (FD (file), (mode_t) 0x0) != -1);
1107 #endif
1108 if (FD (file) != A68G_NO_FILE && close (FD (file)) == -1) {
1109 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_LOCK);
1110 exit_genie (p, A68G_RUNTIME_ERROR);
1111 } else {
1112 FD (file) = A68G_NO_FILE;
1113 OPENED (file) = A68G_FALSE;
1114 unblock_transput_buffer (TRANSPUT_BUFFER (file));
1115 set_default_event_procedures (file);
1116 }
1117 free_file_entry (p, FILE_ENTRY (file));
1118 }
1119
1120 //! @brief PROC (REF FILE) VOID erase
1121
1122 void genie_erase (NODE_T * p)
1123 {
1124 A68G_REF ref_file;
1125 POP_REF (p, &ref_file);
1126 CHECK_REF (p, ref_file, M_REF_FILE);
1127 A68G_FILE *file = FILE_DEREF (&ref_file);
1128 CHECK_INIT (p, INITIALISED (file), M_FILE);
1129 if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) {
1130 return;
1131 }
1132 DEVICE_MADE (&DEVICE (file)) = A68G_FALSE;
1133 #if defined (HAVE_GNU_PLOTUTILS)
1134 if (DEVICE_OPENED (&DEVICE (file))) {
1135 ASSERT (close_device (p, file) == A68G_TRUE);
1136 STREAM (&DEVICE (file)) = NO_STREAM;
1137 return;
1138 }
1139 #endif
1140 if (FD (file) != A68G_NO_FILE && close (FD (file)) == -1) {
1141 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH);
1142 exit_genie (p, A68G_RUNTIME_ERROR);
1143 } else {
1144 unblock_transput_buffer (TRANSPUT_BUFFER (file));
1145 set_default_event_procedures (file);
1146 }
1147 // Remove the file.
1148 if (!IS_NIL (IDENTIFICATION (file))) {
1149 char *filename;
1150 CHECK_INIT (p, INITIALISED (&(IDENTIFICATION (file))), M_ROWS);
1151 filename = DEREF (char, &IDENTIFICATION (file));
1152 if (remove (filename) != 0) {
1153 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH);
1154 exit_genie (p, A68G_RUNTIME_ERROR);
1155 }
1156 UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
1157 IDENTIFICATION (file) = nil_ref;
1158 }
1159 init_file_entry (FILE_ENTRY (file));
1160 }
1161
1162 //! @brief PROC (REF FILE) VOID backspace
1163
1164 void genie_backspace (NODE_T * p)
1165 {
1166 ADDR_T pop_sp = A68G_SP;
1167 PUSH_VALUE (p, -1, A68G_INT);
1168 genie_set (p);
1169 A68G_SP = pop_sp;
1170 }
1171
1172 //! @brief PROC (REF FILE, INT) INT set
1173
1174 void genie_set (NODE_T * p)
1175 {
1176 A68G_INT pos;
1177 POP_OBJECT (p, &pos, A68G_INT);
1178 A68G_REF ref_file;
1179 POP_REF (p, &ref_file);
1180 CHECK_REF (p, ref_file, M_REF_FILE);
1181 A68G_FILE *file = FILE_DEREF (&ref_file);
1182 CHECK_INIT (p, INITIALISED (file), M_FILE);
1183 if (!OPENED (file)) {
1184 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1185 exit_genie (p, A68G_RUNTIME_ERROR);
1186 }
1187 if (!SET (&CHANNEL (file))) {
1188 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CANT_SET);
1189 exit_genie (p, A68G_RUNTIME_ERROR);
1190 }
1191 if (!IS_NIL (STRING (file))) {
1192 A68G_REF z = *DEREF (A68G_REF, &STRING (file));
1193 // Circumvent buffering problems.
1194 STRPOS (file) -= get_transput_buffer_index (TRANSPUT_BUFFER (file));
1195 ASSERT (STRPOS (file) > 0);
1196 reset_transput_buffer (TRANSPUT_BUFFER (file));
1197 // Now set.
1198 CHECK_INT_ADDITION (p, STRPOS (file), VALUE (&pos));
1199 STRPOS (file) += VALUE (&pos);
1200 A68G_ARRAY *arr; A68G_TUPLE *tup;
1201 GET_DESCRIPTOR (arr, tup, &z);
1202 size_t size = ROW_SIZE (tup);
1203 if (size == 0 || STRPOS (file) < 0 || STRPOS (file) >= size) {
1204 A68G_BOOL res;
1205 on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1206 POP_OBJECT (p, &res, A68G_BOOL);
1207 if (VALUE (&res) == A68G_FALSE) {
1208 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1209 exit_genie (p, A68G_RUNTIME_ERROR);
1210 }
1211 }
1212 PUSH_VALUE (p, STRPOS (file), A68G_INT);
1213 } else if (FD (file) == A68G_NO_FILE) {
1214 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_RESET);
1215 exit_genie (p, A68G_RUNTIME_ERROR);
1216 } else {
1217 errno = 0;
1218 a68g_off_t curpos = (a68g_off_t) lseek (FD (file), 0, SEEK_CUR);
1219 a68g_off_t maxpos = (a68g_off_t) lseek (FD (file), 0, SEEK_END);
1220 // Circumvent buffering problems.
1221 int reserve = get_transput_buffer_index (TRANSPUT_BUFFER (file));
1222 curpos -= (a68g_off_t) reserve;
1223 a68g_off_t res = (a68g_off_t) lseek (FD (file), -reserve, SEEK_CUR);
1224 ASSERT (res != (a68g_off_t) -1 && errno == 0);
1225 reset_transput_buffer (TRANSPUT_BUFFER (file));
1226 // Now set.
1227 CHECK_INT_ADDITION (p, curpos, VALUE (&pos));
1228 curpos += VALUE (&pos);
1229 if (curpos < 0 || curpos >= maxpos) {
1230 A68G_BOOL ret;
1231 on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1232 POP_OBJECT (p, &ret, A68G_BOOL);
1233 if (VALUE (&ret) == A68G_FALSE) {
1234 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1235 exit_genie (p, A68G_RUNTIME_ERROR);
1236 }
1237 PUSH_VALUE (p, (INT_T) lseek (FD (file), 0, SEEK_CUR), A68G_INT);
1238 } else {
1239 res = lseek (FD (file), curpos, SEEK_SET);
1240 if (res == -1 || errno != 0) {
1241 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_SET);
1242 exit_genie (p, A68G_RUNTIME_ERROR);
1243 }
1244 PUSH_VALUE (p, (int) res, A68G_INT);
1245 }
1246 }
1247 }
1248
1249 //! @brief PROC (REF FILE) VOID reset
1250
1251 void genie_reset (NODE_T * p)
1252 {
1253 A68G_REF ref_file;
1254 POP_REF (p, &ref_file);
1255 CHECK_REF (p, ref_file, M_REF_FILE);
1256 A68G_FILE *file = FILE_DEREF (&ref_file);
1257 CHECK_INIT (p, INITIALISED (file), M_FILE);
1258 if (!OPENED (file)) {
1259 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1260 exit_genie (p, A68G_RUNTIME_ERROR);
1261 }
1262 if (!RESET (&CHANNEL (file))) {
1263 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CANT_RESET);
1264 exit_genie (p, A68G_RUNTIME_ERROR);
1265 }
1266 if (IS_NIL (STRING (file))) {
1267 close_file_entry (p, FILE_ENTRY (file));
1268 } else {
1269 STRPOS (file) = 0;
1270 }
1271 READ_MOOD (file) = A68G_FALSE;
1272 WRITE_MOOD (file) = A68G_FALSE;
1273 CHAR_MOOD (file) = A68G_FALSE;
1274 DRAW_MOOD (file) = A68G_FALSE;
1275 FD (file) = A68G_NO_FILE;
1276 // set_default_event_procedures (file);.
1277 }
1278
1279 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on file end
1280
1281 void genie_on_file_end (NODE_T * p)
1282 {
1283 A68G_PROCEDURE z;
1284 POP_PROCEDURE (p, &z);
1285 A68G_REF ref_file;
1286 POP_REF (p, &ref_file);
1287 CHECK_REF (p, ref_file, M_REF_FILE);
1288 A68G_FILE *file = FILE_DEREF (&ref_file);
1289 CHECK_INIT (p, INITIALISED (file), M_FILE);
1290 FILE_END_MENDED (file) = z;
1291 }
1292
1293 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on page end
1294
1295 void genie_on_page_end (NODE_T * p)
1296 {
1297 A68G_PROCEDURE z;
1298 POP_PROCEDURE (p, &z);
1299 A68G_REF ref_file;
1300 POP_REF (p, &ref_file);
1301 CHECK_REF (p, ref_file, M_REF_FILE);
1302 A68G_FILE *file = FILE_DEREF (&ref_file);
1303 CHECK_INIT (p, INITIALISED (file), M_FILE);
1304 PAGE_END_MENDED (file) = z;
1305 }
1306
1307 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on line end
1308
1309 void genie_on_line_end (NODE_T * p)
1310 {
1311 A68G_PROCEDURE z;
1312 POP_PROCEDURE (p, &z);
1313 A68G_REF ref_file;
1314 POP_REF (p, &ref_file);
1315 CHECK_REF (p, ref_file, M_REF_FILE);
1316 A68G_FILE *file = FILE_DEREF (&ref_file);
1317 CHECK_INIT (p, INITIALISED (file), M_FILE);
1318 LINE_END_MENDED (file) = z;
1319 }
1320
1321 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format end
1322
1323 void genie_on_format_end (NODE_T * p)
1324 {
1325 A68G_PROCEDURE z;
1326 POP_PROCEDURE (p, &z);
1327 A68G_REF ref_file;
1328 POP_REF (p, &ref_file);
1329 CHECK_REF (p, ref_file, M_REF_FILE);
1330 A68G_FILE *file = FILE_DEREF (&ref_file);
1331 CHECK_INIT (p, INITIALISED (file), M_FILE);
1332 FORMAT_END_MENDED (file) = z;
1333 }
1334
1335 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format error
1336
1337 void genie_on_format_error (NODE_T * p)
1338 {
1339 A68G_PROCEDURE z;
1340 POP_PROCEDURE (p, &z);
1341 A68G_REF ref_file;
1342 POP_REF (p, &ref_file);
1343 CHECK_REF (p, ref_file, M_REF_FILE);
1344 A68G_FILE *file = FILE_DEREF (&ref_file);
1345 CHECK_INIT (p, INITIALISED (file), M_FILE);
1346 FORMAT_ERROR_MENDED (file) = z;
1347 }
1348
1349 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on value error
1350
1351 void genie_on_value_error (NODE_T * p)
1352 {
1353 A68G_PROCEDURE z;
1354 POP_PROCEDURE (p, &z);
1355 A68G_REF ref_file;
1356 POP_REF (p, &ref_file);
1357 CHECK_REF (p, ref_file, M_REF_FILE);
1358 A68G_FILE *file = FILE_DEREF (&ref_file);
1359 CHECK_INIT (p, INITIALISED (file), M_FILE);
1360 VALUE_ERROR_MENDED (file) = z;
1361 }
1362
1363 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on open error
1364
1365 void genie_on_open_error (NODE_T * p)
1366 {
1367 A68G_PROCEDURE z;
1368 POP_PROCEDURE (p, &z);
1369 A68G_REF ref_file;
1370 POP_REF (p, &ref_file);
1371 CHECK_REF (p, ref_file, M_REF_FILE);
1372 A68G_FILE *file = FILE_DEREF (&ref_file);
1373 CHECK_INIT (p, INITIALISED (file), M_FILE);
1374 OPEN_ERROR_MENDED (file) = z;
1375 }
1376
1377 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on transput error
1378
1379 void genie_on_transput_error (NODE_T * p)
1380 {
1381 A68G_PROCEDURE z;
1382 POP_PROCEDURE (p, &z);
1383 A68G_REF ref_file;
1384 POP_REF (p, &ref_file);
1385 CHECK_REF (p, ref_file, M_REF_FILE);
1386 A68G_FILE *file = FILE_DEREF (&ref_file);
1387 CHECK_INIT (p, INITIALISED (file), M_FILE);
1388 TRANSPUT_ERROR_MENDED (file) = z;
1389 }
1390
1391 //! @brief Invoke event routine.
1392
1393 void on_event_handler (NODE_T * p, A68G_PROCEDURE z, A68G_REF ref_file)
1394 {
1395 if (NODE (&(BODY (&z))) == NO_NODE) {
1396 // Default procedure.
1397 PUSH_VALUE (p, A68G_FALSE, A68G_BOOL);
1398 } else {
1399 ADDR_T pop_sp = A68G_SP, pop_fp = A68G_FP;
1400 PUSH_REF (p, ref_file);
1401 genie_call_event_routine (p, M_PROC_REF_FILE_BOOL, &z, pop_sp, pop_fp);
1402 }
1403 }
1404
1405 //! @brief Handle end-of-file event.
1406
1407 void end_of_file_error (NODE_T * p, A68G_REF ref_file)
1408 {
1409 on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1410 A68G_BOOL z;
1411 POP_OBJECT (p, &z, A68G_BOOL);
1412 if (VALUE (&z) == A68G_FALSE) {
1413 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1414 exit_genie (p, A68G_RUNTIME_ERROR);
1415 }
1416 }
1417
1418 //! @brief Handle file-open-error event.
1419
1420 void open_error (NODE_T * p, A68G_REF ref_file, char *mode)
1421 {
1422 on_event_handler (p, OPEN_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file);
1423 A68G_BOOL z;
1424 POP_OBJECT (p, &z, A68G_BOOL);
1425 if (VALUE (&z) == A68G_FALSE) {
1426 CHECK_REF (p, ref_file, M_REF_FILE);
1427 A68G_FILE *file = FILE_DEREF (&ref_file);
1428 CHECK_INIT (p, INITIALISED (file), M_FILE);
1429 char *filename;
1430 if (!IS_NIL (IDENTIFICATION (file))) {
1431 filename = DEREF (char, &IDENTIFICATION (FILE_DEREF (&ref_file)));
1432 } else {
1433 filename = "(missing filename)";
1434 }
1435 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CANNOT_OPEN_FOR, filename, mode);
1436 exit_genie (p, A68G_RUNTIME_ERROR);
1437 }
1438 }
1439
1440 //! @brief Handle value error event.
1441
1442 void value_error (NODE_T * p, MOID_T * m, A68G_REF ref_file)
1443 {
1444 A68G_FILE *f = FILE_DEREF (&ref_file);
1445 if (END_OF_FILE (f)) {
1446 end_of_file_error (p, ref_file);
1447 } else {
1448 on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file);
1449 A68G_BOOL z;
1450 POP_OBJECT (p, &z, A68G_BOOL);
1451 if (VALUE (&z) == A68G_FALSE) {
1452 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m);
1453 exit_genie (p, A68G_RUNTIME_ERROR);
1454 }
1455 }
1456 }
1457
1458 //! @brief Handle value_error event.
1459
1460 void value_sign_error (NODE_T * p, MOID_T * m, A68G_REF ref_file)
1461 {
1462 A68G_FILE *f = FILE_DEREF (&ref_file);
1463 if (END_OF_FILE (f)) {
1464 end_of_file_error (p, ref_file);
1465 } else {
1466 on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file);
1467 A68G_BOOL z;
1468 POP_OBJECT (p, &z, A68G_BOOL);
1469 if (VALUE (&z) == A68G_FALSE) {
1470 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT_SIGN, m);
1471 exit_genie (p, A68G_RUNTIME_ERROR);
1472 }
1473 }
1474 }
1475
1476 //! @brief Handle transput-error event.
1477
1478 void transput_error (NODE_T * p, A68G_REF ref_file, MOID_T * m)
1479 {
1480 on_event_handler (p, TRANSPUT_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file);
1481 A68G_BOOL z;
1482 POP_OBJECT (p, &z, A68G_BOOL);
1483 if (VALUE (&z) == A68G_FALSE) {
1484 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m);
1485 exit_genie (p, A68G_RUNTIME_ERROR);
1486 }
1487 }
1488
1489 // Implementation of put and get.
1490
1491 //! @brief Get next char from file.
1492
1493 int char_scanner (A68G_FILE * f)
1494 {
1495 if (FD (f) == A68G_STDIN && A68G (stdin_is_raw)) {
1496 return peek_char (A68G_PEEK_READ);
1497 } else if (get_transput_buffer_index (TRANSPUT_BUFFER (f)) > 0) {
1498 // There are buffered characters.
1499 END_OF_FILE (f) = A68G_FALSE;
1500 return pop_char_transput_buffer (TRANSPUT_BUFFER (f));
1501 } else if (IS_NIL (STRING (f))) {
1502 // Fetch next CHAR from the FILE.
1503 char ch;
1504 ssize_t chars_read = io_read_conv (FD (f), &ch, 1);
1505 if (chars_read == 1) {
1506 END_OF_FILE (f) = A68G_FALSE;
1507 return ch;
1508 } else {
1509 END_OF_FILE (f) = A68G_TRUE;
1510 return EOF_CHAR;
1511 }
1512 } else {
1513 // File is associated with a STRING. Give next CHAR.
1514 // When we're outside the STRING give EOF_CHAR.
1515 A68G_REF z = *DEREF (A68G_REF, &STRING (f)); A68G_ARRAY *arr; A68G_TUPLE *tup;
1516 GET_DESCRIPTOR (arr, tup, &z);
1517 int k = STRPOS (f) + LWB (tup);
1518 if (ROW_SIZE (tup) <= 0 || k < LWB (tup) || k > UPB (tup)) {
1519 END_OF_FILE (f) = A68G_TRUE;
1520 return EOF_CHAR;
1521 } else {
1522 BYTE_T *base = DEREF (BYTE_T, &ARRAY (arr));
1523 A68G_CHAR *ch = (A68G_CHAR *) & (base[INDEX_1_DIM (arr, tup, k)]);
1524 STRPOS (f)++;
1525 return VALUE (ch);
1526 }
1527 }
1528 }
1529
1530 //! @brief Push back look-ahead character to file.
1531
1532 void unchar_scanner (NODE_T * p, A68G_FILE * f, char ch)
1533 {
1534 END_OF_FILE (f) = A68G_FALSE;
1535 plusab_transput_buffer (p, TRANSPUT_BUFFER (f), ch);
1536 }
1537
1538 //! @brief PROC (REF FILE) BOOL eof
1539
1540 void genie_eof (NODE_T * p)
1541 {
1542 A68G_REF ref_file;
1543 POP_REF (p, &ref_file);
1544 CHECK_REF (p, ref_file, M_REF_FILE);
1545 A68G_FILE *file = FILE_DEREF (&ref_file);
1546 CHECK_INIT (p, INITIALISED (file), M_FILE);
1547 if (!OPENED (file)) {
1548 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1549 exit_genie (p, A68G_RUNTIME_ERROR);
1550 }
1551 if (DRAW_MOOD (file)) {
1552 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1553 exit_genie (p, A68G_RUNTIME_ERROR);
1554 }
1555 if (WRITE_MOOD (file)) {
1556 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1557 exit_genie (p, A68G_RUNTIME_ERROR);
1558 } else if (READ_MOOD (file)) {
1559 int ch = char_scanner (file);
1560 PUSH_VALUE (p, (BOOL_T) ((ch == EOF_CHAR || END_OF_FILE (file)) ? A68G_TRUE : A68G_FALSE), A68G_BOOL);
1561 unchar_scanner (p, file, (char) ch);
1562 } else {
1563 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1564 exit_genie (p, A68G_RUNTIME_ERROR);
1565 }
1566 }
1567
1568 //! @brief PROC (REF FILE) BOOL eoln
1569
1570 void genie_eoln (NODE_T * p)
1571 {
1572 A68G_REF ref_file;
1573 POP_REF (p, &ref_file);
1574 CHECK_REF (p, ref_file, M_REF_FILE);
1575 A68G_FILE *file = FILE_DEREF (&ref_file);
1576 CHECK_INIT (p, INITIALISED (file), M_FILE);
1577 if (!OPENED (file)) {
1578 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1579 exit_genie (p, A68G_RUNTIME_ERROR);
1580 }
1581 if (DRAW_MOOD (file)) {
1582 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1583 exit_genie (p, A68G_RUNTIME_ERROR);
1584 }
1585 if (WRITE_MOOD (file)) {
1586 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1587 exit_genie (p, A68G_RUNTIME_ERROR);
1588 } else if (READ_MOOD (file)) {
1589 int ch = char_scanner (file);
1590 if (END_OF_FILE (file)) {
1591 end_of_file_error (p, ref_file);
1592 }
1593 PUSH_VALUE (p, (BOOL_T) (ch == NEWLINE_CHAR ? A68G_TRUE : A68G_FALSE), A68G_BOOL);
1594 unchar_scanner (p, file, (char) ch);
1595 } else {
1596 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1597 exit_genie (p, A68G_RUNTIME_ERROR);
1598 }
1599 }
1600
1601 //! @brief PROC (REF FILE) VOID new line
1602
1603 void genie_new_line (NODE_T * p)
1604 {
1605 A68G_REF ref_file;
1606 POP_REF (p, &ref_file);
1607 CHECK_REF (p, ref_file, M_REF_FILE);
1608 A68G_FILE *file = FILE_DEREF (&ref_file);
1609 CHECK_INIT (p, INITIALISED (file), M_FILE);
1610 if (!OPENED (file)) {
1611 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1612 exit_genie (p, A68G_RUNTIME_ERROR);
1613 }
1614 if (DRAW_MOOD (file)) {
1615 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1616 exit_genie (p, A68G_RUNTIME_ERROR);
1617 }
1618 if (WRITE_MOOD (file)) {
1619 on_event_handler (p, LINE_END_MENDED (file), ref_file);
1620 if (IS_NIL (STRING (file))) {
1621 WRITE (FD (file), NEWLINE_STRING);
1622 } else {
1623 add_c_string_to_a_string (p, STRING (file), NEWLINE_STRING);
1624 }
1625 } else if (READ_MOOD (file)) {
1626 BOOL_T siga = A68G_TRUE;
1627 while (siga) {
1628 int ch;
1629 if (END_OF_FILE (file)) {
1630 end_of_file_error (p, ref_file);
1631 }
1632 ch = char_scanner (file);
1633 siga = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1634 }
1635 } else {
1636 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1637 exit_genie (p, A68G_RUNTIME_ERROR);
1638 }
1639 }
1640
1641 //! @brief PROC (REF FILE) VOID new page
1642
1643 void genie_new_page (NODE_T * p)
1644 {
1645 A68G_REF ref_file;
1646 POP_REF (p, &ref_file);
1647 CHECK_REF (p, ref_file, M_REF_FILE);
1648 A68G_FILE *file = FILE_DEREF (&ref_file);
1649 CHECK_INIT (p, INITIALISED (file), M_FILE);
1650 if (!OPENED (file)) {
1651 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1652 exit_genie (p, A68G_RUNTIME_ERROR);
1653 }
1654 if (DRAW_MOOD (file)) {
1655 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1656 exit_genie (p, A68G_RUNTIME_ERROR);
1657 }
1658 if (WRITE_MOOD (file)) {
1659 on_event_handler (p, PAGE_END_MENDED (file), ref_file);
1660 if (IS_NIL (STRING (file))) {
1661 WRITE (FD (file), "\f");
1662 } else {
1663 add_c_string_to_a_string (p, STRING (file), "\f");
1664 }
1665 } else if (READ_MOOD (file)) {
1666 BOOL_T siga = A68G_TRUE;
1667 while (siga) {
1668 if (END_OF_FILE (file)) {
1669 end_of_file_error (p, ref_file);
1670 }
1671 int ch = char_scanner (file);
1672 siga = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1673 }
1674 } else {
1675 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1676 exit_genie (p, A68G_RUNTIME_ERROR);
1677 }
1678 }
1679
1680 //! @brief PROC (REF FILE) VOID space
1681
1682 void genie_space (NODE_T * p)
1683 {
1684 A68G_REF ref_file;
1685 POP_REF (p, &ref_file);
1686 CHECK_REF (p, ref_file, M_REF_FILE);
1687 A68G_FILE *file = FILE_DEREF (&ref_file);
1688 CHECK_INIT (p, INITIALISED (file), M_FILE);
1689 if (!OPENED (file)) {
1690 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1691 exit_genie (p, A68G_RUNTIME_ERROR);
1692 }
1693 if (DRAW_MOOD (file)) {
1694 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1695 exit_genie (p, A68G_RUNTIME_ERROR);
1696 }
1697 if (WRITE_MOOD (file)) {
1698 WRITE (FD (file), " ");
1699 } else if (READ_MOOD (file)) {
1700 if (!END_OF_FILE (file)) {
1701 (void) char_scanner (file);
1702 }
1703 } else {
1704 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1705 exit_genie (p, A68G_RUNTIME_ERROR);
1706 }
1707 }
1708
1709 //! @brief PROC (REF FILE) VOID raw
1710
1711 void genie_kbd_raw (NODE_T * p)
1712 {
1713 A68G_REF ref_file;
1714 POP_REF (p, &ref_file);
1715 CHECK_REF (p, ref_file, M_REF_FILE);
1716 A68G_FILE *file = FILE_DEREF (&ref_file);
1717 CHECK_INIT (p, INITIALISED (file), M_FILE);
1718 if (!OPENED (file)) {
1719 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1720 exit_genie (p, A68G_RUNTIME_ERROR);
1721 }
1722 if (DRAW_MOOD (file)) {
1723 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1724 exit_genie (p, A68G_RUNTIME_ERROR);
1725 }
1726 if (WRITE_MOOD (file)) {
1727 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1728 exit_genie (p, A68G_RUNTIME_ERROR);
1729 }
1730 if (FD (file) == A68G_STDIN) {
1731 READ_MOOD (file) = A68G_TRUE;
1732 peek_char (A68G_PEEK_INIT);
1733 }
1734 }
1735
1736 //! @brief PROC (REF FILE) VOID cooked
1737
1738 void genie_kbd_cooked (NODE_T * p)
1739 {
1740 A68G_REF ref_file;
1741 POP_REF (p, &ref_file);
1742 CHECK_REF (p, ref_file, M_REF_FILE);
1743 A68G_FILE *file = FILE_DEREF (&ref_file);
1744 CHECK_INIT (p, INITIALISED (file), M_FILE);
1745 if (!OPENED (file)) {
1746 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1747 exit_genie (p, A68G_RUNTIME_ERROR);
1748 }
1749 if (DRAW_MOOD (file)) {
1750 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1751 exit_genie (p, A68G_RUNTIME_ERROR);
1752 }
1753 if (WRITE_MOOD (file)) {
1754 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1755 exit_genie (p, A68G_RUNTIME_ERROR);
1756 }
1757 if (READ_MOOD (file)) {
1758 if (FD (file) == A68G_STDIN) {
1759 peek_char (A68G_PEEK_RESET);
1760 }
1761 }
1762 }
|
© 2002-2026 J.M. van der Veer (jmvdveer@xs4all.nl)
|
