transput-unformatted.c
1 //! @file transput-unformatted.c
2 //! @author J. Marcel van der Veer
3
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2026 J. Marcel van der Veer [algol68g@algol68genie.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 //! Unformatted transput.
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-conversion.h"
32 #include "a68g-transput.h"
33
34
35 //! @brief Skip new-lines and form-feeds.
36
37 void skip_nl_ff (NODE_T * p, int *ch, A68G_REF ref_file)
38 {
39 A68G_FILE *f = FILE_DEREF (&ref_file);
40 while ((*ch) != EOF_CHAR && IS_NL_FF (*ch)) {
41 A68G_BOOL *z = (A68G_BOOL *) STACK_TOP;
42 ADDR_T pop_sp = A68G_SP;
43 unchar_scanner (p, f, (char) (*ch));
44 if (*ch == NEWLINE_CHAR) {
45 on_event_handler (p, LINE_END_MENDED (f), ref_file);
46 A68G_SP = pop_sp;
47 if (VALUE (z) == A68G_FALSE) {
48 PUSH_REF (p, ref_file);
49 genie_new_line (p);
50 }
51 } else if (*ch == FORMFEED_CHAR) {
52 on_event_handler (p, PAGE_END_MENDED (f), ref_file);
53 A68G_SP = pop_sp;
54 if (VALUE (z) == A68G_FALSE) {
55 PUSH_REF (p, ref_file);
56 genie_new_page (p);
57 }
58 }
59 (*ch) = char_scanner (f);
60 }
61 }
62
63
64 //! @brief Scan an int from file.
65
66 void scan_integer (NODE_T * p, A68G_REF ref_file)
67 {
68 A68G_FILE *f = FILE_DEREF (&ref_file);
69 reset_transput_buffer (INPUT_BUFFER);
70 int ch = char_scanner (f);
71 while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
72 if (IS_NL_FF (ch)) {
73 skip_nl_ff (p, &ch, ref_file);
74 } else {
75 ch = char_scanner (f);
76 }
77 }
78 if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
79 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
80 ch = char_scanner (f);
81 }
82 while (ch != EOF_CHAR && IS_DIGIT (ch)) {
83 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
84 ch = char_scanner (f);
85 }
86 if (ch != EOF_CHAR) {
87 unchar_scanner (p, f, (char) ch);
88 }
89 }
90
91
92 //! @brief Scan a real from file.
93
94 void scan_real (NODE_T * p, A68G_REF ref_file)
95 {
96 A68G_FILE *f = FILE_DEREF (&ref_file);
97 char x_e = EXPONENT_CHAR;
98 reset_transput_buffer (INPUT_BUFFER);
99 int ch = char_scanner (f);
100 while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
101 if (IS_NL_FF (ch)) {
102 skip_nl_ff (p, &ch, ref_file);
103 } else {
104 ch = char_scanner (f);
105 }
106 }
107 if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
108 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
109 ch = char_scanner (f);
110 }
111 while (ch != EOF_CHAR && IS_DIGIT (ch)) {
112 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
113 ch = char_scanner (f);
114 }
115 if (ch == EOF_CHAR || !(ch == POINT_CHAR || TO_UPPER (ch) == TO_UPPER (x_e))) {
116 goto salida;
117 }
118 if (ch == POINT_CHAR) {
119 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
120 ch = char_scanner (f);
121 while (ch != EOF_CHAR && IS_DIGIT (ch)) {
122 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
123 ch = char_scanner (f);
124 }
125 }
126 if (ch == EOF_CHAR || TO_UPPER (ch) != TO_UPPER (x_e)) {
127 goto salida;
128 }
129 if (TO_UPPER (ch) == TO_UPPER (x_e)) {
130 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
131 ch = char_scanner (f);
132 while (ch != EOF_CHAR && ch == BLANK_CHAR) {
133 ch = char_scanner (f);
134 }
135 if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
136 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
137 ch = char_scanner (f);
138 }
139 while (ch != EOF_CHAR && IS_DIGIT (ch)) {
140 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
141 ch = char_scanner (f);
142 }
143 }
144 salida:if (ch != EOF_CHAR) {
145 unchar_scanner (p, f, (char) ch);
146 }
147 }
148
149
150 //! @brief Scan a bits from file.
151
152 void scan_bits (NODE_T * p, A68G_REF ref_file)
153 {
154 A68G_FILE *f = FILE_DEREF (&ref_file);
155 reset_transput_buffer (INPUT_BUFFER);
156 int ch = char_scanner (f);
157 while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
158 if (IS_NL_FF (ch)) {
159 skip_nl_ff (p, &ch, ref_file);
160 } else {
161 ch = char_scanner (f);
162 }
163 }
164 while (ch != EOF_CHAR && (ch == FLIP_CHAR || ch == FLOP_CHAR)) {
165 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
166 ch = char_scanner (f);
167 }
168 if (ch != EOF_CHAR) {
169 unchar_scanner (p, f, (char) ch);
170 }
171 }
172
173
174 //! @brief Scan a char from file.
175
176 void scan_char (NODE_T * p, A68G_REF ref_file)
177 {
178 A68G_FILE *f = FILE_DEREF (&ref_file);
179 reset_transput_buffer (INPUT_BUFFER);
180 int ch = char_scanner (f);
181 skip_nl_ff (p, &ch, ref_file);
182 if (ch != EOF_CHAR) {
183 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
184 }
185 }
186
187
188 //! @brief Scan a string from file.
189
190 void scan_string (NODE_T * p, char *term, A68G_REF ref_file)
191 {
192 A68G_FILE *f = FILE_DEREF (&ref_file);
193 if (END_OF_FILE (f)) {
194 reset_transput_buffer (INPUT_BUFFER);
195 end_of_file_error (p, ref_file);
196 } else {
197 reset_transput_buffer (INPUT_BUFFER);
198 int ch = char_scanner (f);
199 BOOL_T siga = A68G_TRUE;
200 while (siga) {
201 if (ch == EOF_CHAR || END_OF_FILE (f)) {
202 if (get_transput_buffer_index (INPUT_BUFFER) == 0) {
203 end_of_file_error (p, ref_file);
204 }
205 siga = A68G_FALSE;
206 } else if (IS_NL_FF (ch)) {
207 ADDR_T pop_sp = A68G_SP;
208 unchar_scanner (p, f, (char) ch);
209 if (ch == NEWLINE_CHAR) {
210 on_event_handler (p, LINE_END_MENDED (f), ref_file);
211 } else if (ch == FORMFEED_CHAR) {
212 on_event_handler (p, PAGE_END_MENDED (f), ref_file);
213 }
214 A68G_SP = pop_sp;
215 siga = A68G_FALSE;
216 } else if (term != NO_TEXT && strchr (term, ch) != NO_TEXT) {
217 siga = A68G_FALSE;
218 unchar_scanner (p, f, (char) ch);
219 } else {
220 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
221 ch = char_scanner (f);
222 }
223 }
224 }
225 }
226
227
228 //! @brief Make temp file name.
229
230 BOOL_T a68g_mkstemp (char *fn, int flags, mode_t permissions)
231 {
232 // "tmpnam" is not safe, "mkstemp" is Unix, so a68g brings its own tmpnam.
233 #define TMP_SIZE 32
234 #define TRIALS 32
235 BUFFER tfilename;
236 char *letters = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
237 size_t len = strlen (letters);
238 BOOL_T good_file = A68G_FALSE;
239 // Next are prefixes to try.
240 // First we try /tmp, and if that won't go, the current dir.
241 char *prefix[] = { "/tmp/a68g_", "./a68g_", NO_TEXT };
242 for (int i = 0; prefix[i] != NO_TEXT; i++) {
243 for (int k = 0; k < TRIALS && good_file == A68G_FALSE; k++) {
244 a68g_bufcpy (tfilename, prefix[i], BUFFER_SIZE);
245 for (int j = 0; j < TMP_SIZE; j++) {
246 int cindex;
247 do {
248 cindex = (int) (a68g_unif_rand () * len);
249 } while (cindex < 0 || cindex >= len);
250 char chars[2];
251 chars[0] = letters[cindex];
252 chars[1] = NULL_CHAR;
253 a68g_bufcat (tfilename, chars, BUFFER_SIZE);
254 }
255 a68g_bufcat (tfilename, ".tmp", BUFFER_SIZE);
256 errno = 0;
257 FILE_T fd = open (tfilename, flags | O_EXCL, permissions);
258 good_file = (BOOL_T) (fd != A68G_NO_FILE && errno == 0);
259 if (good_file) {
260 (void) close (fd);
261 }
262 }
263 }
264 if (good_file) {
265 a68g_bufcpy (fn, tfilename, BUFFER_SIZE);
266 return A68G_TRUE;
267 } else {
268 return A68G_FALSE;
269 }
270 #undef TMP_SIZE
271 #undef TRIALS
272 }
273
274
275 //! @brief Open a file, or establish it.
276
277 FILE_T open_physical_file (NODE_T * p, A68G_REF ref_file, int flags, mode_t permissions)
278 {
279 BOOL_T reading = (flags & ~O_BINARY) == A68G_READ_ACCESS;
280 BOOL_T writing = (flags & ~O_BINARY) == A68G_WRITE_ACCESS;
281 ABEND (reading == writing, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
282 CHECK_REF (p, ref_file, M_REF_FILE);
283 A68G_FILE *file = FILE_DEREF (&ref_file);
284 CHECK_INIT (p, INITIALISED (file), M_FILE);
285 if (!IS_NIL (STRING (file))) {
286 if (writing) {
287 A68G_REF z = *DEREF (A68G_REF, &STRING (file));
288 A68G_ARRAY *arr; A68G_TUPLE *tup;
289 GET_DESCRIPTOR (arr, tup, &z);
290 UPB (tup) = LWB (tup) - 1;
291 }
292 // Associated file.
293 TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
294 reset_transput_buffer (TRANSPUT_BUFFER (file));
295 END_OF_FILE (file) = A68G_FALSE;
296 FILE_ENTRY (file) = -1;
297 return FD (file);
298 } else if (IS_NIL (IDENTIFICATION (file))) {
299 // No identification, so generate a unique identification..
300 if (reading) {
301 return A68G_NO_FILE;
302 } else {
303 BUFFER tfilename;
304 BUFCLR (tfilename);
305 BOOL_T write_mood = (flags & A68G_WRITE_ACCESS) != 0;
306 if (write_mood) {
307 flags |= (O_CREAT | O_TRUNC);
308 }
309 if (!a68g_mkstemp (tfilename, flags, permissions)) {
310 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NO_TEMP);
311 exit_genie (p, A68G_RUNTIME_ERROR);
312 }
313 FD (file) = open (tfilename, flags, permissions);
314 size_t len = 1 + strlen (tfilename);
315 IDENTIFICATION (file) = heap_generator (p, M_C_STRING, len);
316 BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
317 a68g_bufcpy (DEREF (char, &IDENTIFICATION (file)), tfilename, len);
318 TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
319 reset_transput_buffer (TRANSPUT_BUFFER (file));
320 END_OF_FILE (file) = A68G_FALSE;
321 TMP_FILE (file) = A68G_TRUE;
322 FILE_ENTRY (file) = store_file_entry (p, FD (file), tfilename, TMP_FILE (file));
323 return FD (file);
324 }
325 } else {
326 // Opening an identified file.
327 A68G_REF ref_filename = IDENTIFICATION (file);
328 CHECK_REF (p, ref_filename, M_ROWS);
329 char *filename = DEREF (char, &ref_filename);
330 BOOL_T write_mood = (flags & A68G_WRITE_ACCESS) != 0;
331 if (write_mood) {
332 // A68G creates a file when it does not exist.
333 flags |= O_CREAT;
334 }
335 if (APPEND (file)) {
336 // Append to the end upon opening for writing.
337 if (write_mood) {
338 flags |= O_APPEND;
339 }
340 APPEND (file) = A68G_FALSE;
341 } else if (write_mood) {
342 // Empty a file upon opening for writing.
343 flags |= O_TRUNC;
344 }
345 if (OPEN_EXCLUSIVE (file)) {
346 // Require that the file be non-existent.
347 if (write_mood) {
348 flags |= O_EXCL;
349 }
350 OPEN_EXCLUSIVE (file) = A68G_FALSE;
351 }
352 FD (file) = open (filename, flags, permissions);
353 TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
354 reset_transput_buffer (TRANSPUT_BUFFER (file));
355 END_OF_FILE (file) = A68G_FALSE;
356 FILE_ENTRY (file) = store_file_entry (p, FD (file), filename, TMP_FILE (file));
357 return FD (file);
358 }
359 }
360
361
362 //! @brief Call PROC (REF FILE) VOID during transput.
363
364 void genie_call_proc_ref_file_void (NODE_T * p, A68G_REF ref_file, A68G_PROCEDURE z)
365 {
366 ADDR_T pop_sp = A68G_SP, pop_fp = A68G_FP;
367 MOID_T *u = M_PROC_REF_FILE_VOID;
368 PUSH_REF (p, ref_file);
369 genie_call_procedure (p, MOID (&z), u, u, &z, pop_sp, pop_fp);
370 A68G_SP = pop_sp; // Voiding
371 }
372
373 // Unformatted transput.
374
375
376 //! @brief Hexadecimal value of digit.
377
378 int char_value (int ch)
379 {
380 switch (ch) {
381 case '0': {
382 return 0;
383 }
384 case '1': {
385 return 1;
386 }
387 case '2': {
388 return 2;
389 }
390 case '3': {
391 return 3;
392 }
393 case '4': {
394 return 4;
395 }
396 case '5': {
397 return 5;
398 }
399 case '6': {
400 return 6;
401 }
402 case '7': {
403 return 7;
404 }
405 case '8': {
406 return 8;
407 }
408 case '9': {
409 return 9;
410 }
411 case 'A':
412 case 'a': {
413 return 10;
414 }
415 case 'B':
416 case 'b': {
417 return 11;
418 }
419 case 'C':
420 case 'c': {
421 return 12;
422 }
423 case 'D':
424 case 'd': {
425 return 13;
426 }
427 case 'E':
428 case 'e': {
429 return 14;
430 }
431 case 'F':
432 case 'f': {
433 return 15;
434 }
435 default: {
436 return -1;
437 }
438 }
439 }
440
441
442 //! @brief Convert string in input buffer to value of required mode.
443
444 void genie_string_to_value (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
445 {
446 char *str = get_transput_buffer (INPUT_BUFFER);
447 errno = 0;
448 // end string, just in case.
449 plusab_transput_buffer (p, INPUT_BUFFER, NULL_CHAR);
450 if (mode == M_INT) {
451 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
452 value_error (p, mode, ref_file);
453 }
454 } else if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
455 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
456 value_error (p, mode, ref_file);
457 }
458 } else if (mode == M_REAL) {
459 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
460 value_error (p, mode, ref_file);
461 }
462 } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
463 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
464 value_error (p, mode, ref_file);
465 }
466 } else if (mode == M_BOOL) {
467 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
468 value_error (p, mode, ref_file);
469 }
470 } else if (mode == M_BITS) {
471 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
472 value_error (p, mode, ref_file);
473 }
474 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
475 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
476 value_error (p, mode, ref_file);
477 }
478 } else if (mode == M_CHAR) {
479 A68G_CHAR *z = (A68G_CHAR *) item;
480 if (str[0] == NULL_CHAR) {
481 // value_error (p, mode, ref_file);.
482 VALUE (z) = NULL_CHAR;
483 STATUS (z) = INIT_MASK;
484 } else {
485 size_t len = strlen (str);
486 if (len == 0 || len > 1) {
487 value_error (p, mode, ref_file);
488 }
489 VALUE (z) = str[0];
490 STATUS (z) = INIT_MASK;
491 }
492 } else if (mode == M_STRING) {
493 A68G_REF z;
494 z = c_to_a_string (p, str, get_transput_buffer_index (INPUT_BUFFER) - 1);
495 *(A68G_REF *) item = z;
496 }
497 if (errno != 0) {
498 transput_error (p, ref_file, mode);
499 }
500 }
501
502
503 //! @brief Read object from file.
504
505 void genie_read_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
506 {
507 A68G_FILE *f = FILE_DEREF (&ref_file);
508 errno = 0;
509 if (END_OF_FILE (f)) {
510 end_of_file_error (p, ref_file);
511 }
512 if (mode == M_PROC_REF_FILE_VOID) {
513 genie_call_proc_ref_file_void (p, ref_file, *(A68G_PROCEDURE *) item);
514 } else if (mode == M_FORMAT) {
515 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
516 exit_genie (p, A68G_RUNTIME_ERROR);
517 } else if (mode == M_REF_SOUND) {
518 read_sound (p, ref_file, DEREF (A68G_SOUND, (A68G_REF *) item));
519 } else if (IS_REF (mode)) {
520 CHECK_REF (p, *(A68G_REF *) item, mode);
521 genie_read_standard (p, SUB (mode), ADDRESS ((A68G_REF *) item), ref_file);
522 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
523 scan_integer (p, ref_file);
524 genie_string_to_value (p, mode, item, ref_file);
525 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
526 scan_real (p, ref_file);
527 genie_string_to_value (p, mode, item, ref_file);
528 } else if (mode == M_BOOL) {
529 scan_char (p, ref_file);
530 genie_string_to_value (p, mode, item, ref_file);
531 } else if (mode == M_CHAR) {
532 scan_char (p, ref_file);
533 genie_string_to_value (p, mode, item, ref_file);
534 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
535 scan_bits (p, ref_file);
536 genie_string_to_value (p, mode, item, ref_file);
537 } else if (mode == M_STRING) {
538 char *term = DEREF (char, &TERMINATOR (f));
539 scan_string (p, term, ref_file);
540 genie_string_to_value (p, mode, item, ref_file);
541 } else if (IS_STRUCT (mode)) {
542 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
543 genie_read_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
544 }
545 } else if (IS_UNION (mode)) {
546 A68G_UNION *z = (A68G_UNION *) item;
547 if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
548 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
549 exit_genie (p, A68G_RUNTIME_ERROR);
550 }
551 genie_read_standard (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file);
552 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
553 MOID_T *deflexed = DEFLEX (mode);
554 A68G_ARRAY *arr;
555 A68G_TUPLE *tup;
556 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), mode);
557 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
558 if (get_row_size (tup, DIM (arr)) > 0) {
559 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
560 BOOL_T done = A68G_FALSE;
561 initialise_internal_index (tup, DIM (arr));
562 while (!done) {
563 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
564 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
565 genie_read_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
566 done = increment_internal_index (tup, DIM (arr));
567 }
568 }
569 }
570 if (errno != 0) {
571 transput_error (p, ref_file, mode);
572 }
573 }
574
575
576 //! @brief PROC ([] SIMPLIN) VOID read
577
578 void genie_read (NODE_T * p)
579 {
580 A68G_REF row;
581 POP_REF (p, &row);
582 genie_stand_in (p);
583 PUSH_REF (p, row);
584 genie_read_file (p);
585 }
586
587
588 //! @brief Open for reading.
589
590 void open_for_reading (NODE_T * p, A68G_REF ref_file)
591 {
592 A68G_FILE *file = FILE_DEREF (&ref_file);
593 if (!OPENED (file)) {
594 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
595 exit_genie (p, A68G_RUNTIME_ERROR);
596 }
597 if (DRAW_MOOD (file)) {
598 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
599 exit_genie (p, A68G_RUNTIME_ERROR);
600 }
601 if (WRITE_MOOD (file)) {
602 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
603 exit_genie (p, A68G_RUNTIME_ERROR);
604 }
605 if (!GET (&CHANNEL (file))) {
606 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
607 exit_genie (p, A68G_RUNTIME_ERROR);
608 }
609 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
610 if (IS_NIL (STRING (file))) {
611 if ((FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0)) == A68G_NO_FILE) {
612 open_error (p, ref_file, "getting");
613 }
614 } else {
615 FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0);
616 }
617 DRAW_MOOD (file) = A68G_FALSE;
618 READ_MOOD (file) = A68G_TRUE;
619 WRITE_MOOD (file) = A68G_FALSE;
620 CHAR_MOOD (file) = A68G_TRUE;
621 }
622 if (!CHAR_MOOD (file)) {
623 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
624 exit_genie (p, A68G_RUNTIME_ERROR);
625 }
626 }
627
628
629 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get
630
631 void genie_read_file (NODE_T * p)
632 {
633 A68G_REF row; A68G_ARRAY *arr; A68G_TUPLE *tup;
634 POP_REF (p, &row);
635 CHECK_REF (p, row, M_ROW_SIMPLIN);
636 GET_DESCRIPTOR (arr, tup, &row);
637 A68G_REF ref_file;
638 POP_REF (p, &ref_file);
639 CHECK_REF (p, ref_file, M_REF_FILE);
640 A68G_FILE *file = FILE_DEREF (&ref_file);
641 CHECK_INIT (p, INITIALISED (file), M_FILE);
642 open_for_reading (p, ref_file);
643 // Read.
644 INT_T elems = ROW_SIZE (tup);
645 if (elems <= 0) {
646 return;
647 }
648 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
649 INT_T elem_index = 0;
650 for (INT_T k = 0; k < elems; k++) {
651 A68G_UNION *z = (A68G_UNION *) & base_address[elem_index];
652 MOID_T *mode = (MOID_T *) (VALUE (z));
653 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68G_UNION_SIZE];
654 genie_read_standard (p, mode, item, ref_file);
655 elem_index += SIZE (M_SIMPLIN);
656 }
657 }
658
659
660 //! @brief Convert value to string.
661
662 void genie_value_to_string (NODE_T * p, MOID_T * moid, BYTE_T * item, int mod)
663 {
664 if (moid == M_INT) {
665 A68G_INT *z = (A68G_INT *) item;
666 PUSH_UNION (p, M_INT);
667 PUSH_VALUE (p, VALUE (z), A68G_INT);
668 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_INT)));
669 if (mod == FORMAT_ITEM_G) {
670 PUSH_VALUE (p, A68G_INT_WIDTH + 1, A68G_INT);
671 genie_whole (p);
672 } else if (mod == FORMAT_ITEM_H) {
673 PUSH_VALUE (p, A68G_REAL_WIDTH + A68G_EXP_WIDTH + 4, A68G_INT);
674 PUSH_VALUE (p, A68G_REAL_WIDTH - 1, A68G_INT);
675 PUSH_VALUE (p, A68G_EXP_WIDTH + 1, A68G_INT);
676 PUSH_VALUE (p, 3, A68G_INT);
677 genie_real (p);
678 }
679 return;
680 }
681 #if (A68G_LEVEL >= 3)
682 if (moid == M_LONG_INT) {
683 A68G_LONG_INT *z = (A68G_LONG_INT *) item;
684 PUSH_UNION (p, M_LONG_INT);
685 PUSH (p, z, SIZE (M_LONG_INT));
686 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_INT)));
687 if (mod == FORMAT_ITEM_G) {
688 PUSH_VALUE (p, A68G_LONG_WIDTH + 1, A68G_INT);
689 genie_whole (p);
690 } else if (mod == FORMAT_ITEM_H) {
691 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4, A68G_INT);
692 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH - 1, A68G_INT);
693 PUSH_VALUE (p, A68G_LONG_EXP_WIDTH + 1, A68G_INT);
694 PUSH_VALUE (p, 3, A68G_INT);
695 genie_real (p);
696 }
697 return;
698 }
699 if (moid == M_LONG_REAL) {
700 A68G_LONG_REAL *z = (A68G_LONG_REAL *) item;
701 PUSH_UNION (p, M_LONG_REAL);
702 PUSH_VALUE (p, VALUE (z), A68G_LONG_REAL);
703 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_REAL)));
704 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4, A68G_INT);
705 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH - 1, A68G_INT);
706 PUSH_VALUE (p, A68G_LONG_EXP_WIDTH + 1, A68G_INT);
707 if (mod == FORMAT_ITEM_G) {
708 genie_float (p);
709 } else if (mod == FORMAT_ITEM_H) {
710 PUSH_VALUE (p, 3, A68G_INT);
711 genie_real (p);
712 }
713 return;
714 }
715 if (moid == M_LONG_BITS) {
716 A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
717 char *s = stack_string (p, 8 + A68G_LONG_BITS_WIDTH);
718 int n = 0;
719 for (int w = 0; w <= 1; w++) {
720 UNSIGNED_T bit = D_SIGN;
721 for (int j = 0; j < A68G_BITS_WIDTH; j++) {
722 if (w == 0) {
723 s[n] = (char) ((HW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR);
724 } else {
725 s[n] = (char) ((LW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR);
726 }
727 bit >>= 1;
728 n++;
729 }
730 }
731 s[n] = NULL_CHAR;
732 return;
733 }
734 #else
735 if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) {
736 int bits = get_mp_bits_width (moid), word = get_mp_bits_words (moid);
737 int pos = bits;
738 char *str = stack_string (p, 8 + bits);
739 ADDR_T pop_sp = A68G_SP;
740 unt *row = stack_mp_bits (p, (MP_T *) item, moid);
741 str[pos--] = NULL_CHAR;
742 while (pos >= 0) {
743 unt bit = 0x1;
744 for (int j = 0; j < MP_BITS_BITS && pos >= 0; j++) {
745 str[pos--] = (char) ((row[word - 1] & bit) ? FLIP_CHAR : FLOP_CHAR);
746 bit <<= 1;
747 }
748 word--;
749 }
750 A68G_SP = pop_sp;
751 return;
752 }
753 #endif
754 if (moid == M_LONG_INT) {
755 MP_T *z = (MP_T *) item;
756 PUSH_UNION (p, M_LONG_INT);
757 PUSH (p, z, SIZE (M_LONG_INT));
758 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_INT)));
759 if (mod == FORMAT_ITEM_G) {
760 PUSH_VALUE (p, A68G_LONG_WIDTH + 1, A68G_INT);
761 genie_whole (p);
762 } else if (mod == FORMAT_ITEM_H) {
763 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4, A68G_INT);
764 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH - 1, A68G_INT);
765 PUSH_VALUE (p, A68G_LONG_EXP_WIDTH + 1, A68G_INT);
766 PUSH_VALUE (p, 3, A68G_INT);
767 genie_real (p);
768 }
769 return;
770 }
771 if (moid == M_LONG_LONG_INT) {
772 MP_T *z = (MP_T *) item;
773 PUSH_UNION (p, M_LONG_LONG_INT);
774 PUSH (p, z, SIZE (M_LONG_LONG_INT));
775 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_LONG_INT)));
776 if (mod == FORMAT_ITEM_G) {
777 PUSH_VALUE (p, A68G_LONG_LONG_WIDTH + 1, A68G_INT);
778 genie_whole (p);
779 } else if (mod == FORMAT_ITEM_H) {
780 PUSH_VALUE (p, A68G_LONG_LONG_REAL_WIDTH + A68G_LONG_LONG_EXP_WIDTH + 4, A68G_INT);
781 PUSH_VALUE (p, A68G_LONG_LONG_REAL_WIDTH - 1, A68G_INT);
782 PUSH_VALUE (p, A68G_LONG_LONG_EXP_WIDTH + 1, A68G_INT);
783 PUSH_VALUE (p, 3, A68G_INT);
784 genie_real (p);
785 }
786 return;
787 }
788 if (moid == M_REAL) {
789 A68G_REAL *z = (A68G_REAL *) item;
790 PUSH_UNION (p, M_REAL);
791 PUSH_VALUE (p, VALUE (z), A68G_REAL);
792 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_REAL)));
793 PUSH_VALUE (p, A68G_REAL_WIDTH + A68G_EXP_WIDTH + 4, A68G_INT);
794 PUSH_VALUE (p, A68G_REAL_WIDTH - 1, A68G_INT);
795 PUSH_VALUE (p, A68G_EXP_WIDTH + 1, A68G_INT);
796 if (mod == FORMAT_ITEM_G) {
797 genie_float (p);
798 } else if (mod == FORMAT_ITEM_H) {
799 PUSH_VALUE (p, 3, A68G_INT);
800 genie_real (p);
801 }
802 return;
803 }
804 if (moid == M_LONG_REAL) {
805 MP_T *z = (MP_T *) item;
806 PUSH_UNION (p, M_LONG_REAL);
807 PUSH (p, z, (int) SIZE (M_LONG_REAL));
808 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_REAL)));
809 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4, A68G_INT);
810 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH - 1, A68G_INT);
811 PUSH_VALUE (p, A68G_LONG_EXP_WIDTH + 1, A68G_INT);
812 if (mod == FORMAT_ITEM_G) {
813 genie_float (p);
814 } else if (mod == FORMAT_ITEM_H) {
815 PUSH_VALUE (p, 3, A68G_INT);
816 genie_real (p);
817 }
818 return;
819 }
820 if (moid == M_LONG_LONG_REAL) {
821 MP_T *z = (MP_T *) item;
822 PUSH_UNION (p, M_LONG_LONG_REAL);
823 PUSH (p, z, (int) SIZE (M_LONG_LONG_REAL));
824 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_LONG_REAL)));
825 PUSH_VALUE (p, A68G_LONG_LONG_REAL_WIDTH + A68G_LONG_LONG_EXP_WIDTH + 4, A68G_INT);
826 PUSH_VALUE (p, A68G_LONG_LONG_REAL_WIDTH - 1, A68G_INT);
827 PUSH_VALUE (p, A68G_LONG_LONG_EXP_WIDTH + 1, A68G_INT);
828 if (mod == FORMAT_ITEM_G) {
829 genie_float (p);
830 } else if (mod == FORMAT_ITEM_H) {
831 PUSH_VALUE (p, 3, A68G_INT);
832 genie_real (p);
833 }
834 return;
835 }
836 if (moid == M_BITS) {
837 A68G_BITS *z = (A68G_BITS *) item;
838 char *str = stack_string (p, 8 + A68G_BITS_WIDTH);
839 UNSIGNED_T bit = 0x1;
840 int j;
841 for (j = 1; j < A68G_BITS_WIDTH; j++) {
842 bit <<= 1;
843 }
844 for (j = 0; j < A68G_BITS_WIDTH; j++) {
845 str[j] = (char) ((VALUE (z) & bit) ? FLIP_CHAR : FLOP_CHAR);
846 bit >>= 1;
847 }
848 str[j] = NULL_CHAR;
849 return;
850 }
851 }
852
853
854 //! @brief Print object to file.
855
856 void genie_write_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
857 {
858 errno = 0;
859 ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
860 if (mode == M_PROC_REF_FILE_VOID) {
861 genie_call_proc_ref_file_void (p, ref_file, *(A68G_PROCEDURE *) item);
862 } else if (mode == M_FORMAT) {
863 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
864 exit_genie (p, A68G_RUNTIME_ERROR);
865 } else if (mode == M_SOUND) {
866 write_sound (p, ref_file, (A68G_SOUND *) item);
867 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
868 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
869 add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
870 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
871 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
872 add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
873 } else if (mode == M_BOOL) {
874 A68G_BOOL *z = (A68G_BOOL *) item;
875 char flipflop = (char) (VALUE (z) == A68G_TRUE ? FLIP_CHAR : FLOP_CHAR);
876 plusab_transput_buffer (p, UNFORMATTED_BUFFER, flipflop);
877 } else if (mode == M_CHAR) {
878 A68G_CHAR *ch = (A68G_CHAR *) item;
879 plusab_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (ch));
880 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
881 char *str = (char *) STACK_TOP;
882 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
883 add_string_transput_buffer (p, UNFORMATTED_BUFFER, str);
884 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
885 // Handle these separately since this is faster than straightening.
886 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
887 } else if (IS_UNION (mode)) {
888 A68G_UNION *z = (A68G_UNION *) item;
889 MOID_T *um = (MOID_T *) (VALUE (z));
890 BYTE_T *ui = &item[A68G_UNION_SIZE];
891 if (um == NO_MOID) {
892 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
893 exit_genie (p, A68G_RUNTIME_ERROR);
894 }
895 genie_write_standard (p, um, ui, ref_file);
896 } else if (IS_STRUCT (mode)) {
897 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
898 BYTE_T *elem = &item[OFFSET (q)];
899 genie_check_initialisation (p, elem, MOID (q));
900 genie_write_standard (p, MOID (q), elem, ref_file);
901 }
902 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
903 MOID_T *deflexed = DEFLEX (mode);
904 A68G_ARRAY *arr;
905 A68G_TUPLE *tup;
906 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
907 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
908 if (get_row_size (tup, DIM (arr)) > 0) {
909 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
910 BOOL_T done = A68G_FALSE;
911 initialise_internal_index (tup, DIM (arr));
912 while (!done) {
913 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
914 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
915 BYTE_T *elem = &base_addr[elem_addr];
916 genie_check_initialisation (p, elem, SUB (deflexed));
917 genie_write_standard (p, SUB (deflexed), elem, ref_file);
918 done = increment_internal_index (tup, DIM (arr));
919 }
920 }
921 }
922 if (errno != 0) {
923 ABEND (IS_NIL (ref_file), ERROR_ACTION, error_specification ());
924 transput_error (p, ref_file, mode);
925 }
926 }
927
928
929 //! @brief PROC ([] SIMPLOUT) VOID print, write
930
931 void genie_write (NODE_T * p)
932 {
933 A68G_REF row;
934 POP_REF (p, &row);
935 genie_stand_out (p);
936 PUSH_REF (p, row);
937 genie_write_file (p);
938 }
939
940
941 //! @brief Open for writing.
942
943 void open_for_writing (NODE_T * p, A68G_REF ref_file)
944 {
945 A68G_FILE *file = FILE_DEREF (&ref_file);
946 if (!OPENED (file)) {
947 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
948 exit_genie (p, A68G_RUNTIME_ERROR);
949 }
950 if (DRAW_MOOD (file)) {
951 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
952 exit_genie (p, A68G_RUNTIME_ERROR);
953 }
954 if (READ_MOOD (file)) {
955 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
956 exit_genie (p, A68G_RUNTIME_ERROR);
957 }
958 if (!PUT (&CHANNEL (file))) {
959 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
960 exit_genie (p, A68G_RUNTIME_ERROR);
961 }
962 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
963 if (IS_NIL (STRING (file))) {
964 if ((FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, A68G_PROTECTION)) == A68G_NO_FILE) {
965 open_error (p, ref_file, "putting");
966 }
967 } else {
968 FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, 0);
969 }
970 DRAW_MOOD (file) = A68G_FALSE;
971 READ_MOOD (file) = A68G_FALSE;
972 WRITE_MOOD (file) = A68G_TRUE;
973 CHAR_MOOD (file) = A68G_TRUE;
974 }
975 if (!CHAR_MOOD (file)) {
976 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
977 exit_genie (p, A68G_RUNTIME_ERROR);
978 }
979 }
980
981
982 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put
983
984 void genie_write_file (NODE_T * p)
985 {
986 A68G_REF row; A68G_ARRAY *arr; A68G_TUPLE *tup;
987 POP_REF (p, &row);
988 CHECK_REF (p, row, M_ROW_SIMPLOUT);
989 GET_DESCRIPTOR (arr, tup, &row);
990 A68G_REF ref_file;
991 POP_REF (p, &ref_file);
992 CHECK_REF (p, ref_file, M_REF_FILE);
993 A68G_FILE *file = FILE_DEREF (&ref_file);
994 CHECK_INIT (p, INITIALISED (file), M_FILE);
995 open_for_writing (p, ref_file);
996 // Write.
997 INT_T elems = ROW_SIZE (tup);
998 if (elems <= 0) {
999 return;
1000 }
1001 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1002 INT_T elem_index = 0;
1003 for (INT_T k = 0; k < elems; k++) {
1004 A68G_UNION *z = (A68G_UNION *) & (base_address[elem_index]);
1005 MOID_T *mode = (MOID_T *) (VALUE (z));
1006 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68G_UNION_SIZE];
1007 reset_transput_buffer (UNFORMATTED_BUFFER);
1008 genie_write_standard (p, mode, item, ref_file);
1009 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);
1010 elem_index += SIZE (M_SIMPLOUT);
1011 }
1012 }
1013
1014
1015 //! @brief Read object binary from file.
1016
1017 void genie_read_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
1018 {
1019 CHECK_REF (p, ref_file, M_REF_FILE);
1020 A68G_FILE *f = FILE_DEREF (&ref_file);
1021 errno = 0;
1022 if (END_OF_FILE (f)) {
1023 end_of_file_error (p, ref_file);
1024 }
1025 if (mode == M_PROC_REF_FILE_VOID) {
1026 genie_call_proc_ref_file_void (p, ref_file, *(A68G_PROCEDURE *) item);
1027 } else if (mode == M_FORMAT) {
1028 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1029 exit_genie (p, A68G_RUNTIME_ERROR);
1030 } else if (mode == M_REF_SOUND) {
1031 read_sound (p, ref_file, (A68G_SOUND *) ADDRESS ((A68G_REF *) item));
1032 } else if (IS_REF (mode)) {
1033 CHECK_REF (p, *(A68G_REF *) item, mode);
1034 genie_read_bin_standard (p, SUB (mode), ADDRESS ((A68G_REF *) item), ref_file);
1035 } else if (mode == M_INT) {
1036 A68G_INT *z = (A68G_INT *) item;
1037 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1038 STATUS (z) = INIT_MASK;
1039 } else if (mode == M_LONG_INT) {
1040 #if (A68G_LEVEL >= 3)
1041 A68G_LONG_INT *z = (A68G_LONG_INT *) item;
1042 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1043 STATUS (z) = INIT_MASK;
1044 #else
1045 MP_T *z = (MP_T *) item;
1046 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1047 SET_INIT_MP (z);
1048 #endif
1049 } else if (mode == M_LONG_LONG_INT) {
1050 MP_T *z = (MP_T *) item;
1051 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1052 SET_INIT_MP (z);
1053 } else if (mode == M_REAL) {
1054 A68G_REAL *z = (A68G_REAL *) item;
1055 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1056 STATUS (z) = INIT_MASK;
1057 } else if (mode == M_LONG_REAL) {
1058 #if (A68G_LEVEL >= 3)
1059 A68G_LONG_REAL *z = (A68G_LONG_REAL *) item;
1060 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1061 STATUS (z) = INIT_MASK;
1062 #else
1063 MP_T *z = (MP_T *) item;
1064 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1065 SET_INIT_MP (z);
1066 #endif
1067 } else if (mode == M_LONG_LONG_REAL) {
1068 MP_T *z = (MP_T *) item;
1069 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1070 SET_INIT_MP (z);
1071 } else if (mode == M_BOOL) {
1072 A68G_BOOL *z = (A68G_BOOL *) item;
1073 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1074 STATUS (z) = INIT_MASK;
1075 } else if (mode == M_CHAR) {
1076 A68G_CHAR *z = (A68G_CHAR *) item;
1077 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1078 STATUS (z) = INIT_MASK;
1079 } else if (mode == M_BITS) {
1080 A68G_BITS *z = (A68G_BITS *) item;
1081 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1082 STATUS (z) = INIT_MASK;
1083 } else if (mode == M_LONG_BITS) {
1084 #if (A68G_LEVEL >= 3)
1085 A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
1086 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1087 STATUS (z) = INIT_MASK;
1088 #else
1089 MP_T *z = (MP_T *) item;
1090 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1091 SET_INIT_MP (z);
1092 #endif
1093 } else if (mode == M_LONG_LONG_BITS) {
1094 MP_T *z = (MP_T *) item;
1095 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1096 SET_INIT_MP (z);
1097 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1098 int len;
1099 ASSERT (io_read (FD (f), &(len), sizeof (len)) != -1);
1100 reset_transput_buffer (UNFORMATTED_BUFFER);
1101 for (int k = 0; k < len; k++) {
1102 char ch;
1103 ASSERT (io_read (FD (f), &(ch), sizeof (char)) != -1);
1104 plusab_transput_buffer (p, UNFORMATTED_BUFFER, ch);
1105 }
1106 *(A68G_REF *) item = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
1107 } else if (IS_UNION (mode)) {
1108 A68G_UNION *z = (A68G_UNION *) item;
1109 if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
1110 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
1111 exit_genie (p, A68G_RUNTIME_ERROR);
1112 }
1113 genie_read_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file);
1114 } else if (IS_STRUCT (mode)) {
1115 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1116 genie_read_bin_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
1117 }
1118 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1119 MOID_T *deflexed = DEFLEX (mode);
1120 A68G_ARRAY *arr; A68G_TUPLE *tup;
1121 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
1122 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
1123 if (get_row_size (tup, DIM (arr)) > 0) {
1124 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1125 BOOL_T done = A68G_FALSE;
1126 initialise_internal_index (tup, DIM (arr));
1127 while (!done) {
1128 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
1129 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
1130 genie_read_bin_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
1131 done = increment_internal_index (tup, DIM (arr));
1132 }
1133 }
1134 }
1135 if (errno != 0) {
1136 transput_error (p, ref_file, mode);
1137 }
1138 }
1139
1140
1141 //! @brief PROC ([] SIMPLIN) VOID read bin
1142
1143 void genie_read_bin (NODE_T * p)
1144 {
1145 A68G_REF row;
1146 POP_REF (p, &row);
1147 genie_stand_back (p);
1148 PUSH_REF (p, row);
1149 genie_read_bin_file (p);
1150 }
1151
1152
1153 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get bin
1154
1155 void genie_read_bin_file (NODE_T * p)
1156 {
1157 A68G_REF row; A68G_ARRAY *arr; A68G_TUPLE *tup;
1158 POP_REF (p, &row);
1159 CHECK_REF (p, row, M_ROW_SIMPLIN);
1160 GET_DESCRIPTOR (arr, tup, &row);
1161 A68G_REF ref_file;
1162 POP_REF (p, &ref_file);
1163 ref_file = *(A68G_REF *) STACK_TOP;
1164 CHECK_REF (p, ref_file, M_REF_FILE);
1165 A68G_FILE *file = FILE_DEREF (&ref_file);
1166 CHECK_INIT (p, INITIALISED (file), M_FILE);
1167 if (!OPENED (file)) {
1168 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1169 exit_genie (p, A68G_RUNTIME_ERROR);
1170 }
1171 if (DRAW_MOOD (file)) {
1172 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1173 exit_genie (p, A68G_RUNTIME_ERROR);
1174 }
1175 if (WRITE_MOOD (file)) {
1176 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1177 exit_genie (p, A68G_RUNTIME_ERROR);
1178 }
1179 if (!GET (&CHANNEL (file))) {
1180 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
1181 exit_genie (p, A68G_RUNTIME_ERROR);
1182 }
1183 if (!BIN (&CHANNEL (file))) {
1184 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary getting");
1185 exit_genie (p, A68G_RUNTIME_ERROR);
1186 }
1187 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1188 if ((FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS | O_BINARY, 0)) == A68G_NO_FILE) {
1189 open_error (p, ref_file, "binary getting");
1190 }
1191 DRAW_MOOD (file) = A68G_FALSE;
1192 READ_MOOD (file) = A68G_TRUE;
1193 WRITE_MOOD (file) = A68G_FALSE;
1194 CHAR_MOOD (file) = A68G_FALSE;
1195 }
1196 if (CHAR_MOOD (file)) {
1197 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
1198 exit_genie (p, A68G_RUNTIME_ERROR);
1199 }
1200 // Read.
1201 INT_T elems = ROW_SIZE (tup);
1202 if (elems <= 0) {
1203 return;
1204 }
1205 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1206 INT_T elem_index = 0;
1207 for (INT_T k = 0; k < elems; k++) {
1208 A68G_UNION *z = (A68G_UNION *) & base_address[elem_index];
1209 MOID_T *mode = (MOID_T *) (VALUE (z));
1210 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68G_UNION_SIZE];
1211 genie_read_bin_standard (p, mode, item, ref_file);
1212 elem_index += SIZE (M_SIMPLIN);
1213 }
1214 }
1215
1216
1217 //! @brief Write object binary to file.
1218
1219 void genie_write_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
1220 {
1221 CHECK_REF (p, ref_file, M_REF_FILE);
1222 A68G_FILE *f = FILE_DEREF (&ref_file);
1223 errno = 0;
1224 if (mode == M_PROC_REF_FILE_VOID) {
1225 genie_call_proc_ref_file_void (p, ref_file, *(A68G_PROCEDURE *) item);
1226 } else if (mode == M_FORMAT) {
1227 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1228 exit_genie (p, A68G_RUNTIME_ERROR);
1229 } else if (mode == M_SOUND) {
1230 write_sound (p, ref_file, (A68G_SOUND *) item);
1231 } else if (mode == M_INT) {
1232 ASSERT (io_write (FD (f), &(VALUE ((A68G_INT *) item)), sizeof (VALUE ((A68G_INT *) item))) != -1);
1233 } else if (mode == M_LONG_INT) {
1234 #if (A68G_LEVEL >= 3)
1235 ASSERT (io_write (FD (f), &(VALUE ((A68G_LONG_INT *) item)), sizeof (VALUE ((A68G_LONG_INT *) item))) != -1);
1236 #else
1237 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1238 #endif
1239 } else if (mode == M_LONG_LONG_INT) {
1240 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1241 } else if (mode == M_REAL) {
1242 ASSERT (io_write (FD (f), &(VALUE ((A68G_REAL *) item)), sizeof (VALUE ((A68G_REAL *) item))) != -1);
1243 } else if (mode == M_LONG_REAL) {
1244 #if (A68G_LEVEL >= 3)
1245 ASSERT (io_write (FD (f), &(VALUE ((A68G_LONG_REAL *) item)), sizeof (VALUE ((A68G_LONG_REAL *) item))) != -1);
1246 #else
1247 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1248 #endif
1249 } else if (mode == M_LONG_LONG_REAL) {
1250 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1251 } else if (mode == M_BOOL) {
1252 ASSERT (io_write (FD (f), &(VALUE ((A68G_BOOL *) item)), sizeof (VALUE ((A68G_BOOL *) item))) != -1);
1253 } else if (mode == M_CHAR) {
1254 ASSERT (io_write (FD (f), &(VALUE ((A68G_CHAR *) item)), sizeof (VALUE ((A68G_CHAR *) item))) != -1);
1255 } else if (mode == M_BITS) {
1256 ASSERT (io_write (FD (f), &(VALUE ((A68G_BITS *) item)), sizeof (VALUE ((A68G_BITS *) item))) != -1);
1257 } else if (mode == M_LONG_BITS) {
1258 #if (A68G_LEVEL >= 3)
1259 ASSERT (io_write (FD (f), &(VALUE ((A68G_LONG_BITS *) item)), sizeof (VALUE ((A68G_LONG_BITS *) item))) != -1);
1260 #else
1261 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1262 #endif
1263 } else if (mode == M_LONG_LONG_BITS) {
1264 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1265 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1266 reset_transput_buffer (UNFORMATTED_BUFFER);
1267 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
1268 int len = get_transput_buffer_index (UNFORMATTED_BUFFER);
1269 ASSERT (io_write (FD (f), &(len), sizeof (len)) != -1);
1270 WRITE (FD (f), get_transput_buffer (UNFORMATTED_BUFFER));
1271 } else if (IS_UNION (mode)) {
1272 A68G_UNION *z = (A68G_UNION *) item;
1273 genie_write_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file);
1274 } else if (IS_STRUCT (mode)) {
1275 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1276 BYTE_T *elem = &item[OFFSET (q)];
1277 genie_check_initialisation (p, elem, MOID (q));
1278 genie_write_bin_standard (p, MOID (q), elem, ref_file);
1279 }
1280 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1281 MOID_T *deflexed = DEFLEX (mode);
1282 A68G_ARRAY *arr; A68G_TUPLE *tup;
1283 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
1284 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
1285 if (get_row_size (tup, DIM (arr)) > 0) {
1286 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1287 BOOL_T done = A68G_FALSE;
1288 initialise_internal_index (tup, DIM (arr));
1289 while (!done) {
1290 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
1291 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
1292 BYTE_T *elem = &base_addr[elem_addr];
1293 genie_check_initialisation (p, elem, SUB (deflexed));
1294 genie_write_bin_standard (p, SUB (deflexed), elem, ref_file);
1295 done = increment_internal_index (tup, DIM (arr));
1296 }
1297 }
1298 }
1299 if (errno != 0) {
1300 transput_error (p, ref_file, mode);
1301 }
1302 }
1303
1304
1305 //! @brief PROC ([] SIMPLOUT) VOID write bin, print bin
1306
1307 void genie_write_bin (NODE_T * p)
1308 {
1309 A68G_REF row;
1310 POP_REF (p, &row);
1311 genie_stand_back (p);
1312 PUSH_REF (p, row);
1313 genie_write_bin_file (p);
1314 }
1315
1316
1317 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put bin
1318
1319 void genie_write_bin_file (NODE_T * p)
1320 {
1321 A68G_REF row; A68G_ARRAY *arr; A68G_TUPLE *tup;
1322 POP_REF (p, &row);
1323 CHECK_REF (p, row, M_ROW_SIMPLOUT);
1324 GET_DESCRIPTOR (arr, tup, &row);
1325 A68G_REF ref_file;
1326 POP_REF (p, &ref_file);
1327 ref_file = *(A68G_REF *) STACK_TOP;
1328 CHECK_REF (p, ref_file, M_REF_FILE);
1329 A68G_FILE *file = FILE_DEREF (&ref_file);
1330 CHECK_INIT (p, INITIALISED (file), M_FILE);
1331 if (!OPENED (file)) {
1332 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1333 exit_genie (p, A68G_RUNTIME_ERROR);
1334 }
1335 if (DRAW_MOOD (file)) {
1336 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1337 exit_genie (p, A68G_RUNTIME_ERROR);
1338 }
1339 if (READ_MOOD (file)) {
1340 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1341 exit_genie (p, A68G_RUNTIME_ERROR);
1342 }
1343 if (!PUT (&CHANNEL (file))) {
1344 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1345 exit_genie (p, A68G_RUNTIME_ERROR);
1346 }
1347 if (!BIN (&CHANNEL (file))) {
1348 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary putting");
1349 exit_genie (p, A68G_RUNTIME_ERROR);
1350 }
1351 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1352 if ((FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS | O_BINARY, A68G_PROTECTION)) == A68G_NO_FILE) {
1353 open_error (p, ref_file, "binary putting");
1354 }
1355 DRAW_MOOD (file) = A68G_FALSE;
1356 READ_MOOD (file) = A68G_FALSE;
1357 WRITE_MOOD (file) = A68G_TRUE;
1358 CHAR_MOOD (file) = A68G_FALSE;
1359 }
1360 if (CHAR_MOOD (file)) {
1361 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
1362 exit_genie (p, A68G_RUNTIME_ERROR);
1363 }
1364 INT_T elems = ROW_SIZE (tup);
1365 if (elems <= 0) {
1366 return;
1367 }
1368 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1369 INT_T elem_index = 0;
1370 for (INT_T k = 0; k < elems; k++) {
1371 A68G_UNION *z = (A68G_UNION *) & base_address[elem_index];
1372 MOID_T *mode = (MOID_T *) (VALUE (z));
1373 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68G_UNION_SIZE];
1374 genie_write_bin_standard (p, mode, item, ref_file);
1375 elem_index += SIZE (M_SIMPLOUT);
1376 }
1377 }
1378
1379
1380 //! @brief PROC (NUMBER, INT) STRING rawout
1381
1382 void genie_rawout (NODE_T * p)
1383 {
1384 PUSH_STRING (p, rawout (p));
1385 }
1386
1387
1388 //! @brief PROC (NUMBER, INT) STRING whole
1389
1390 void genie_whole (NODE_T * p)
1391 {
1392 PUSH_STRING (p, whole (p));
1393 }
1394
1395
1396 //! @brief PROC (NUMBER, INT, INT) STRING bits
1397
1398 void genie_bits (NODE_T * p)
1399 {
1400 PUSH_STRING (p, bits_to_string (p));
1401 }
1402
1403
1404 //! @brief PROC (NUMBER, INT, INT) STRING fixed
1405
1406 void genie_fixed (NODE_T * p)
1407 {
1408 PUSH_STRING (p, fixed (p));
1409 }
1410
1411
1412 //! @brief PROC (NUMBER, INT, INT, INT) STRING eng
1413
1414 void genie_real (NODE_T * p)
1415 {
1416 PUSH_STRING (p, real (p));
1417 }
1418
1419
1420 //! @brief PROC (NUMBER, INT, INT, INT) STRING float
1421
1422 void genie_float (NODE_T * p)
1423 {
1424 PUSH_VALUE (p, 1, A68G_INT);
1425 genie_real (p);
1426 }
1427
1428 // ALGOL68C routines.
1429
1430 //! @def A68C_TRANSPUT
1431
1432 //! @brief Generate Algol68C routines readint, getint, etcetera.
1433
1434 #define A68C_TRANSPUT(n, m)\
1435 void genie_get_##n (NODE_T * p)\
1436 {\
1437 A68G_REF ref_file;\
1438 POP_REF (p, &ref_file);\
1439 CHECK_REF (p, ref_file, M_REF_FILE);\
1440 BYTE_T *z = STACK_TOP;\
1441 INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
1442 ADDR_T pop_sp = A68G_SP;\
1443 open_for_reading (p, ref_file);\
1444 genie_read_standard (p, MODE (m), z, ref_file);\
1445 A68G_SP = pop_sp;\
1446 }\
1447 void genie_put_##n (NODE_T * p)\
1448 {\
1449 size_t size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\
1450 A68G_REF ref_file = * (A68G_REF *) STACK_OFFSET (- (size + sizf));\
1451 CHECK_REF (p, ref_file, M_REF_FILE);\
1452 reset_transput_buffer (UNFORMATTED_BUFFER);\
1453 open_for_writing (p, ref_file);\
1454 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
1455 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
1456 DECREMENT_STACK_POINTER (p, size + sizf);\
1457 }\
1458 void genie_read_##n (NODE_T * p)\
1459 {\
1460 BYTE_T *z = STACK_TOP;\
1461 INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
1462 ADDR_T pop_sp = A68G_SP;\
1463 open_for_reading (p, A68G (stand_in));\
1464 genie_read_standard (p, MODE (m), z, A68G (stand_in));\
1465 A68G_SP = pop_sp;\
1466 }\
1467 void genie_print_##n (NODE_T * p)\
1468 {\
1469 size_t size = SIZE (MODE (m));\
1470 reset_transput_buffer (UNFORMATTED_BUFFER);\
1471 open_for_writing (p, A68G (stand_out));\
1472 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68G (stand_out));\
1473 write_purge_buffer (p, A68G (stand_out), UNFORMATTED_BUFFER);\
1474 DECREMENT_STACK_POINTER (p, size);\
1475 }
1476
1477 A68C_TRANSPUT (int, INT);
1478 A68C_TRANSPUT (long_int, LONG_INT);
1479 A68C_TRANSPUT (long_mp_int, LONG_LONG_INT);
1480 A68C_TRANSPUT (real, REAL);
1481 A68C_TRANSPUT (long_real, LONG_REAL);
1482 A68C_TRANSPUT (long_mp_real, LONG_LONG_REAL);
1483 A68C_TRANSPUT (bits, BITS);
1484 A68C_TRANSPUT (long_bits, LONG_BITS);
1485 A68C_TRANSPUT (long_mp_bits, LONG_LONG_BITS);
1486 A68C_TRANSPUT (bool, BOOL);
1487 A68C_TRANSPUT (char, CHAR);
1488 A68C_TRANSPUT (string, STRING);
1489
1490 #undef A68C_TRANSPUT
1491
1492 #define A68C_TRANSPUT(n, s, m)\
1493 void genie_get_##n (NODE_T * p) {\
1494 A68G_REF ref_file;\
1495 POP_REF (p, &ref_file);\
1496 CHECK_REF (p, ref_file, M_REF_FILE);\
1497 PUSH_REF (p, ref_file);\
1498 genie_get_##s (p);\
1499 PUSH_REF (p, ref_file);\
1500 genie_get_##s (p);\
1501 }\
1502 void genie_put_##n (NODE_T * p) {\
1503 size_t size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\
1504 A68G_REF ref_file = * (A68G_REF *) STACK_OFFSET (- (size + sizf));\
1505 CHECK_REF (p, ref_file, M_REF_FILE);\
1506 reset_transput_buffer (UNFORMATTED_BUFFER);\
1507 open_for_writing (p, ref_file);\
1508 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
1509 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
1510 DECREMENT_STACK_POINTER (p, size + sizf);\
1511 }\
1512 void genie_read_##n (NODE_T * p) {\
1513 genie_read_##s (p);\
1514 genie_read_##s (p);\
1515 }\
1516 void genie_print_##n (NODE_T * p) {\
1517 size_t size = SIZE (MODE (m));\
1518 reset_transput_buffer (UNFORMATTED_BUFFER);\
1519 open_for_writing (p, A68G (stand_out));\
1520 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68G (stand_out));\
1521 write_purge_buffer (p, A68G (stand_out), UNFORMATTED_BUFFER);\
1522 DECREMENT_STACK_POINTER (p, size);\
1523 }
1524
1525 A68C_TRANSPUT (complex, real, COMPLEX);
1526 A68C_TRANSPUT (mp_complex, long_real, LONG_COMPLEX);
1527 A68C_TRANSPUT (long_mp_complex, long_mp_real, LONG_LONG_COMPLEX);
1528
1529 #undef A68C_TRANSPUT
1530
1531 void genie_peek_char (NODE_T * p)
1532 {
1533 A68G_INT mode;
1534 POP_OBJECT (p, &mode, A68G_INT);
1535 CHECK_INIT (p, INITIALISED (&mode), M_INT);
1536 PUSH_VALUE (p, (char) peek_char (VALUE (&mode)), A68G_CHAR);
1537 }
1538
1539
1540 //! @brief PROC STRING read line
1541
1542 void genie_read_line (NODE_T * p)
1543 {
1544 #if defined (HAVE_READLINE)
1545 char *line = readline ("");
1546 if (line != NO_TEXT && strlen (line) > 0) {
1547 add_history (line);
1548 }
1549 PUSH_REF (p, c_to_a_string (p, line, DEFAULT_WIDTH));
1550 a68g_free (line);
1551 #else
1552 genie_read_string (p);
1553 genie_stand_in (p);
1554 genie_new_line (p);
1555 #endif
1556 }
© J.M. van der Veer • jmvdveer@algol68genie.nl
