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