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-2025 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 MOID (arr_3) = M_CHAR;
370 ELEM_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 size_t size;
1194 // Circumvent buffering problems.
1195 STRPOS (file) -= get_transput_buffer_index (TRANSPUT_BUFFER (file));
1196 ASSERT (STRPOS (file) > 0);
1197 reset_transput_buffer (TRANSPUT_BUFFER (file));
1198 // Now set.
1199 CHECK_INT_ADDITION (p, STRPOS (file), VALUE (&pos));
1200 STRPOS (file) += VALUE (&pos);
1201 A68G_ARRAY *arr; A68G_TUPLE *tup;
1202 GET_DESCRIPTOR (arr, tup, &z);
1203 size = ROW_SIZE (tup);
1204 if (size <= 0 || STRPOS (file) < 0 || STRPOS (file) >= size) {
1205 A68G_BOOL res;
1206 on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1207 POP_OBJECT (p, &res, A68G_BOOL);
1208 if (VALUE (&res) == A68G_FALSE) {
1209 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1210 exit_genie (p, A68G_RUNTIME_ERROR);
1211 }
1212 }
1213 PUSH_VALUE (p, STRPOS (file), A68G_INT);
1214 } else if (FD (file) == A68G_NO_FILE) {
1215 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_RESET);
1216 exit_genie (p, A68G_RUNTIME_ERROR);
1217 } else {
1218 errno = 0;
1219 a68g_off_t curpos = (a68g_off_t) lseek (FD (file), 0, SEEK_CUR);
1220 a68g_off_t maxpos = (a68g_off_t) lseek (FD (file), 0, SEEK_END);
1221 // Circumvent buffering problems.
1222 int reserve = get_transput_buffer_index (TRANSPUT_BUFFER (file));
1223 curpos -= (a68g_off_t) reserve;
1224 a68g_off_t res = (a68g_off_t) lseek (FD (file), -reserve, SEEK_CUR);
1225 ASSERT (res != (a68g_off_t) -1 && errno == 0);
1226 reset_transput_buffer (TRANSPUT_BUFFER (file));
1227 // Now set.
1228 CHECK_INT_ADDITION (p, curpos, VALUE (&pos));
1229 curpos += VALUE (&pos);
1230 if (curpos < 0 || curpos >= maxpos) {
1231 A68G_BOOL ret;
1232 on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1233 POP_OBJECT (p, &ret, A68G_BOOL);
1234 if (VALUE (&ret) == A68G_FALSE) {
1235 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1236 exit_genie (p, A68G_RUNTIME_ERROR);
1237 }
1238 PUSH_VALUE (p, (INT_T) lseek (FD (file), 0, SEEK_CUR), A68G_INT);
1239 } else {
1240 res = lseek (FD (file), curpos, SEEK_SET);
1241 if (res == -1 || errno != 0) {
1242 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_SET);
1243 exit_genie (p, A68G_RUNTIME_ERROR);
1244 }
1245 PUSH_VALUE (p, (int) res, A68G_INT);
1246 }
1247 }
1248 }
1249
1250 //! @brief PROC (REF FILE) VOID reset
1251
1252 void genie_reset (NODE_T * p)
1253 {
1254 A68G_REF ref_file;
1255 POP_REF (p, &ref_file);
1256 CHECK_REF (p, ref_file, M_REF_FILE);
1257 A68G_FILE *file = FILE_DEREF (&ref_file);
1258 CHECK_INIT (p, INITIALISED (file), M_FILE);
1259 if (!OPENED (file)) {
1260 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1261 exit_genie (p, A68G_RUNTIME_ERROR);
1262 }
1263 if (!RESET (&CHANNEL (file))) {
1264 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CANT_RESET);
1265 exit_genie (p, A68G_RUNTIME_ERROR);
1266 }
1267 if (IS_NIL (STRING (file))) {
1268 close_file_entry (p, FILE_ENTRY (file));
1269 } else {
1270 STRPOS (file) = 0;
1271 }
1272 READ_MOOD (file) = A68G_FALSE;
1273 WRITE_MOOD (file) = A68G_FALSE;
1274 CHAR_MOOD (file) = A68G_FALSE;
1275 DRAW_MOOD (file) = A68G_FALSE;
1276 FD (file) = A68G_NO_FILE;
1277 // set_default_event_procedures (file);.
1278 }
1279
1280 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on file end
1281
1282 void genie_on_file_end (NODE_T * p)
1283 {
1284 A68G_PROCEDURE z;
1285 POP_PROCEDURE (p, &z);
1286 A68G_REF ref_file;
1287 POP_REF (p, &ref_file);
1288 CHECK_REF (p, ref_file, M_REF_FILE);
1289 A68G_FILE *file = FILE_DEREF (&ref_file);
1290 CHECK_INIT (p, INITIALISED (file), M_FILE);
1291 FILE_END_MENDED (file) = z;
1292 }
1293
1294 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on page end
1295
1296 void genie_on_page_end (NODE_T * p)
1297 {
1298 A68G_PROCEDURE z;
1299 POP_PROCEDURE (p, &z);
1300 A68G_REF ref_file;
1301 POP_REF (p, &ref_file);
1302 CHECK_REF (p, ref_file, M_REF_FILE);
1303 A68G_FILE *file = FILE_DEREF (&ref_file);
1304 CHECK_INIT (p, INITIALISED (file), M_FILE);
1305 PAGE_END_MENDED (file) = z;
1306 }
1307
1308 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on line end
1309
1310 void genie_on_line_end (NODE_T * p)
1311 {
1312 A68G_PROCEDURE z;
1313 POP_PROCEDURE (p, &z);
1314 A68G_REF ref_file;
1315 POP_REF (p, &ref_file);
1316 CHECK_REF (p, ref_file, M_REF_FILE);
1317 A68G_FILE *file = FILE_DEREF (&ref_file);
1318 CHECK_INIT (p, INITIALISED (file), M_FILE);
1319 LINE_END_MENDED (file) = z;
1320 }
1321
1322 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format end
1323
1324 void genie_on_format_end (NODE_T * p)
1325 {
1326 A68G_PROCEDURE z;
1327 POP_PROCEDURE (p, &z);
1328 A68G_REF ref_file;
1329 POP_REF (p, &ref_file);
1330 CHECK_REF (p, ref_file, M_REF_FILE);
1331 A68G_FILE *file = FILE_DEREF (&ref_file);
1332 CHECK_INIT (p, INITIALISED (file), M_FILE);
1333 FORMAT_END_MENDED (file) = z;
1334 }
1335
1336 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format error
1337
1338 void genie_on_format_error (NODE_T * p)
1339 {
1340 A68G_PROCEDURE z;
1341 POP_PROCEDURE (p, &z);
1342 A68G_REF ref_file;
1343 POP_REF (p, &ref_file);
1344 CHECK_REF (p, ref_file, M_REF_FILE);
1345 A68G_FILE *file = FILE_DEREF (&ref_file);
1346 CHECK_INIT (p, INITIALISED (file), M_FILE);
1347 FORMAT_ERROR_MENDED (file) = z;
1348 }
1349
1350 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on value error
1351
1352 void genie_on_value_error (NODE_T * p)
1353 {
1354 A68G_PROCEDURE z;
1355 POP_PROCEDURE (p, &z);
1356 A68G_REF ref_file;
1357 POP_REF (p, &ref_file);
1358 CHECK_REF (p, ref_file, M_REF_FILE);
1359 A68G_FILE *file = FILE_DEREF (&ref_file);
1360 CHECK_INIT (p, INITIALISED (file), M_FILE);
1361 VALUE_ERROR_MENDED (file) = z;
1362 }
1363
1364 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on open error
1365
1366 void genie_on_open_error (NODE_T * p)
1367 {
1368 A68G_PROCEDURE z;
1369 POP_PROCEDURE (p, &z);
1370 A68G_REF ref_file;
1371 POP_REF (p, &ref_file);
1372 CHECK_REF (p, ref_file, M_REF_FILE);
1373 A68G_FILE *file = FILE_DEREF (&ref_file);
1374 CHECK_INIT (p, INITIALISED (file), M_FILE);
1375 OPEN_ERROR_MENDED (file) = z;
1376 }
1377
1378 //! @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on transput error
1379
1380 void genie_on_transput_error (NODE_T * p)
1381 {
1382 A68G_PROCEDURE z;
1383 POP_PROCEDURE (p, &z);
1384 A68G_REF ref_file;
1385 POP_REF (p, &ref_file);
1386 CHECK_REF (p, ref_file, M_REF_FILE);
1387 A68G_FILE *file = FILE_DEREF (&ref_file);
1388 CHECK_INIT (p, INITIALISED (file), M_FILE);
1389 TRANSPUT_ERROR_MENDED (file) = z;
1390 }
1391
1392 //! @brief Invoke event routine.
1393
1394 void on_event_handler (NODE_T * p, A68G_PROCEDURE z, A68G_REF ref_file)
1395 {
1396 if (NODE (&(BODY (&z))) == NO_NODE) {
1397 // Default procedure.
1398 PUSH_VALUE (p, A68G_FALSE, A68G_BOOL);
1399 } else {
1400 ADDR_T pop_sp = A68G_SP, pop_fp = A68G_FP;
1401 PUSH_REF (p, ref_file);
1402 genie_call_event_routine (p, M_PROC_REF_FILE_BOOL, &z, pop_sp, pop_fp);
1403 }
1404 }
1405
1406 //! @brief Handle end-of-file event.
1407
1408 void end_of_file_error (NODE_T * p, A68G_REF ref_file)
1409 {
1410 on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
1411 A68G_BOOL z;
1412 POP_OBJECT (p, &z, A68G_BOOL);
1413 if (VALUE (&z) == A68G_FALSE) {
1414 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_ENDED);
1415 exit_genie (p, A68G_RUNTIME_ERROR);
1416 }
1417 }
1418
1419 //! @brief Handle file-open-error event.
1420
1421 void open_error (NODE_T * p, A68G_REF ref_file, char *mode)
1422 {
1423 on_event_handler (p, OPEN_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file);
1424 A68G_BOOL z;
1425 POP_OBJECT (p, &z, A68G_BOOL);
1426 if (VALUE (&z) == A68G_FALSE) {
1427 CHECK_REF (p, ref_file, M_REF_FILE);
1428 A68G_FILE *file = FILE_DEREF (&ref_file);
1429 CHECK_INIT (p, INITIALISED (file), M_FILE);
1430 char *filename;
1431 if (!IS_NIL (IDENTIFICATION (file))) {
1432 filename = DEREF (char, &IDENTIFICATION (FILE_DEREF (&ref_file)));
1433 } else {
1434 filename = "(missing filename)";
1435 }
1436 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_CANNOT_OPEN_FOR, filename, mode);
1437 exit_genie (p, A68G_RUNTIME_ERROR);
1438 }
1439 }
1440
1441 //! @brief Handle value error event.
1442
1443 void value_error (NODE_T * p, MOID_T * m, A68G_REF ref_file)
1444 {
1445 A68G_FILE *f = FILE_DEREF (&ref_file);
1446 if (END_OF_FILE (f)) {
1447 end_of_file_error (p, ref_file);
1448 } else {
1449 on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file);
1450 A68G_BOOL z;
1451 POP_OBJECT (p, &z, A68G_BOOL);
1452 if (VALUE (&z) == A68G_FALSE) {
1453 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m);
1454 exit_genie (p, A68G_RUNTIME_ERROR);
1455 }
1456 }
1457 }
1458
1459 //! @brief Handle value_error event.
1460
1461 void value_sign_error (NODE_T * p, MOID_T * m, A68G_REF ref_file)
1462 {
1463 A68G_FILE *f = FILE_DEREF (&ref_file);
1464 if (END_OF_FILE (f)) {
1465 end_of_file_error (p, ref_file);
1466 } else {
1467 on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file);
1468 A68G_BOOL z;
1469 POP_OBJECT (p, &z, A68G_BOOL);
1470 if (VALUE (&z) == A68G_FALSE) {
1471 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT_SIGN, m);
1472 exit_genie (p, A68G_RUNTIME_ERROR);
1473 }
1474 }
1475 }
1476
1477 //! @brief Handle transput-error event.
1478
1479 void transput_error (NODE_T * p, A68G_REF ref_file, MOID_T * m)
1480 {
1481 on_event_handler (p, TRANSPUT_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file);
1482 A68G_BOOL z;
1483 POP_OBJECT (p, &z, A68G_BOOL);
1484 if (VALUE (&z) == A68G_FALSE) {
1485 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m);
1486 exit_genie (p, A68G_RUNTIME_ERROR);
1487 }
1488 }
1489
1490 // Implementation of put and get.
1491
1492 //! @brief Get next char from file.
1493
1494 int char_scanner (A68G_FILE * f)
1495 {
1496 if (get_transput_buffer_index (TRANSPUT_BUFFER (f)) > 0) {
1497 // There are buffered characters.
1498 END_OF_FILE (f) = A68G_FALSE;
1499 return pop_char_transput_buffer (TRANSPUT_BUFFER (f));
1500 } else if (IS_NIL (STRING (f))) {
1501 // Fetch next CHAR from the FILE.
1502 char ch;
1503 ssize_t chars_read = io_read_conv (FD (f), &ch, 1);
1504 if (chars_read == 1) {
1505 END_OF_FILE (f) = A68G_FALSE;
1506 return ch;
1507 } else {
1508 END_OF_FILE (f) = A68G_TRUE;
1509 return EOF_CHAR;
1510 }
1511 } else {
1512 // File is associated with a STRING. Give next CHAR.
1513 // When we're outside the STRING give EOF_CHAR.
1514 A68G_REF z = *DEREF (A68G_REF, &STRING (f)); A68G_ARRAY *arr; A68G_TUPLE *tup;
1515 GET_DESCRIPTOR (arr, tup, &z);
1516 int k = STRPOS (f) + LWB (tup);
1517 if (ROW_SIZE (tup) <= 0 || k < LWB (tup) || k > UPB (tup)) {
1518 END_OF_FILE (f) = A68G_TRUE;
1519 return EOF_CHAR;
1520 } else {
1521 BYTE_T *base = DEREF (BYTE_T, &ARRAY (arr));
1522 A68G_CHAR *ch = (A68G_CHAR *) & (base[INDEX_1_DIM (arr, tup, k)]);
1523 STRPOS (f)++;
1524 return VALUE (ch);
1525 }
1526 }
1527 }
1528
1529 //! @brief Push back look-ahead character to file.
1530
1531 void unchar_scanner (NODE_T * p, A68G_FILE * f, char ch)
1532 {
1533 END_OF_FILE (f) = A68G_FALSE;
1534 plusab_transput_buffer (p, TRANSPUT_BUFFER (f), ch);
1535 }
1536
1537 //! @brief PROC (REF FILE) BOOL eof
1538
1539 void genie_eof (NODE_T * p)
1540 {
1541 A68G_REF ref_file;
1542 POP_REF (p, &ref_file);
1543 CHECK_REF (p, ref_file, M_REF_FILE);
1544 A68G_FILE *file = FILE_DEREF (&ref_file);
1545 CHECK_INIT (p, INITIALISED (file), M_FILE);
1546 if (!OPENED (file)) {
1547 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1548 exit_genie (p, A68G_RUNTIME_ERROR);
1549 }
1550 if (DRAW_MOOD (file)) {
1551 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1552 exit_genie (p, A68G_RUNTIME_ERROR);
1553 }
1554 if (WRITE_MOOD (file)) {
1555 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1556 exit_genie (p, A68G_RUNTIME_ERROR);
1557 } else if (READ_MOOD (file)) {
1558 int ch = char_scanner (file);
1559 PUSH_VALUE (p, (BOOL_T) ((ch == EOF_CHAR || END_OF_FILE (file)) ? A68G_TRUE : A68G_FALSE), A68G_BOOL);
1560 unchar_scanner (p, file, (char) ch);
1561 } else {
1562 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1563 exit_genie (p, A68G_RUNTIME_ERROR);
1564 }
1565 }
1566
1567 //! @brief PROC (REF FILE) BOOL eoln
1568
1569 void genie_eoln (NODE_T * p)
1570 {
1571 A68G_REF ref_file;
1572 POP_REF (p, &ref_file);
1573 CHECK_REF (p, ref_file, M_REF_FILE);
1574 A68G_FILE *file = FILE_DEREF (&ref_file);
1575 CHECK_INIT (p, INITIALISED (file), M_FILE);
1576 if (!OPENED (file)) {
1577 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1578 exit_genie (p, A68G_RUNTIME_ERROR);
1579 }
1580 if (DRAW_MOOD (file)) {
1581 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1582 exit_genie (p, A68G_RUNTIME_ERROR);
1583 }
1584 if (WRITE_MOOD (file)) {
1585 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1586 exit_genie (p, A68G_RUNTIME_ERROR);
1587 } else if (READ_MOOD (file)) {
1588 int ch = char_scanner (file);
1589 if (END_OF_FILE (file)) {
1590 end_of_file_error (p, ref_file);
1591 }
1592 PUSH_VALUE (p, (BOOL_T) (ch == NEWLINE_CHAR ? A68G_TRUE : A68G_FALSE), A68G_BOOL);
1593 unchar_scanner (p, file, (char) ch);
1594 } else {
1595 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1596 exit_genie (p, A68G_RUNTIME_ERROR);
1597 }
1598 }
1599
1600 //! @brief PROC (REF FILE) VOID new line
1601
1602 void genie_new_line (NODE_T * p)
1603 {
1604 A68G_REF ref_file;
1605 POP_REF (p, &ref_file);
1606 CHECK_REF (p, ref_file, M_REF_FILE);
1607 A68G_FILE *file = FILE_DEREF (&ref_file);
1608 CHECK_INIT (p, INITIALISED (file), M_FILE);
1609 if (!OPENED (file)) {
1610 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1611 exit_genie (p, A68G_RUNTIME_ERROR);
1612 }
1613 if (DRAW_MOOD (file)) {
1614 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1615 exit_genie (p, A68G_RUNTIME_ERROR);
1616 }
1617 if (WRITE_MOOD (file)) {
1618 on_event_handler (p, LINE_END_MENDED (file), ref_file);
1619 if (IS_NIL (STRING (file))) {
1620 WRITE (FD (file), NEWLINE_STRING);
1621 } else {
1622 add_c_string_to_a_string (p, STRING (file), NEWLINE_STRING);
1623 }
1624 } else if (READ_MOOD (file)) {
1625 BOOL_T siga = A68G_TRUE;
1626 while (siga) {
1627 int ch;
1628 if (END_OF_FILE (file)) {
1629 end_of_file_error (p, ref_file);
1630 }
1631 ch = char_scanner (file);
1632 siga = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1633 }
1634 } else {
1635 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1636 exit_genie (p, A68G_RUNTIME_ERROR);
1637 }
1638 }
1639
1640 //! @brief PROC (REF FILE) VOID new page
1641
1642 void genie_new_page (NODE_T * p)
1643 {
1644 A68G_REF ref_file;
1645 POP_REF (p, &ref_file);
1646 CHECK_REF (p, ref_file, M_REF_FILE);
1647 A68G_FILE *file = FILE_DEREF (&ref_file);
1648 CHECK_INIT (p, INITIALISED (file), M_FILE);
1649 if (!OPENED (file)) {
1650 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1651 exit_genie (p, A68G_RUNTIME_ERROR);
1652 }
1653 if (DRAW_MOOD (file)) {
1654 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1655 exit_genie (p, A68G_RUNTIME_ERROR);
1656 }
1657 if (WRITE_MOOD (file)) {
1658 on_event_handler (p, PAGE_END_MENDED (file), ref_file);
1659 if (IS_NIL (STRING (file))) {
1660 WRITE (FD (file), "\f");
1661 } else {
1662 add_c_string_to_a_string (p, STRING (file), "\f");
1663 }
1664 } else if (READ_MOOD (file)) {
1665 BOOL_T siga = A68G_TRUE;
1666 while (siga) {
1667 if (END_OF_FILE (file)) {
1668 end_of_file_error (p, ref_file);
1669 }
1670 int ch = char_scanner (file);
1671 siga = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1672 }
1673 } else {
1674 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1675 exit_genie (p, A68G_RUNTIME_ERROR);
1676 }
1677 }
1678
1679 //! @brief PROC (REF FILE) VOID space
1680
1681 void genie_space (NODE_T * p)
1682 {
1683 A68G_REF ref_file;
1684 POP_REF (p, &ref_file);
1685 CHECK_REF (p, ref_file, M_REF_FILE);
1686 A68G_FILE *file = FILE_DEREF (&ref_file);
1687 CHECK_INIT (p, INITIALISED (file), M_FILE);
1688 if (!OPENED (file)) {
1689 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1690 exit_genie (p, A68G_RUNTIME_ERROR);
1691 }
1692 if (DRAW_MOOD (file)) {
1693 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1694 exit_genie (p, A68G_RUNTIME_ERROR);
1695 }
1696 if (WRITE_MOOD (file)) {
1697 WRITE (FD (file), " ");
1698 } else if (READ_MOOD (file)) {
1699 if (!END_OF_FILE (file)) {
1700 (void) char_scanner (file);
1701 }
1702 } else {
1703 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined");
1704 exit_genie (p, A68G_RUNTIME_ERROR);
1705 }
1706 }
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|