rts-unformatted.c
1 //! @file rts-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-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 //! 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-transput.h"
32
33 //! @brief Skip new-lines and form-feeds.
34
35 void skip_nl_ff (NODE_T * p, int *ch, A68G_REF ref_file)
36 {
37 A68G_FILE *f = FILE_DEREF (&ref_file);
38 while ((*ch) != EOF_CHAR && IS_NL_FF (*ch)) {
39 A68G_BOOL *z = (A68G_BOOL *) STACK_TOP;
40 ADDR_T pop_sp = A68G_SP;
41 unchar_scanner (p, f, (char) (*ch));
42 if (*ch == NEWLINE_CHAR) {
43 on_event_handler (p, LINE_END_MENDED (f), ref_file);
44 A68G_SP = pop_sp;
45 if (VALUE (z) == A68G_FALSE) {
46 PUSH_REF (p, ref_file);
47 genie_new_line (p);
48 }
49 } else if (*ch == FORMFEED_CHAR) {
50 on_event_handler (p, PAGE_END_MENDED (f), ref_file);
51 A68G_SP = pop_sp;
52 if (VALUE (z) == A68G_FALSE) {
53 PUSH_REF (p, ref_file);
54 genie_new_page (p);
55 }
56 }
57 (*ch) = char_scanner (f);
58 }
59 }
60
61 //! @brief Scan an int from file.
62
63 void scan_integer (NODE_T * p, A68G_REF ref_file)
64 {
65 A68G_FILE *f = FILE_DEREF (&ref_file);
66 reset_transput_buffer (INPUT_BUFFER);
67 int ch = char_scanner (f);
68 while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
69 if (IS_NL_FF (ch)) {
70 skip_nl_ff (p, &ch, ref_file);
71 } else {
72 ch = char_scanner (f);
73 }
74 }
75 if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
76 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
77 ch = char_scanner (f);
78 }
79 while (ch != EOF_CHAR && IS_DIGIT (ch)) {
80 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
81 ch = char_scanner (f);
82 }
83 if (ch != EOF_CHAR) {
84 unchar_scanner (p, f, (char) ch);
85 }
86 }
87
88 //! @brief Scan a real from file.
89
90 void scan_real (NODE_T * p, A68G_REF ref_file)
91 {
92 A68G_FILE *f = FILE_DEREF (&ref_file);
93 char x_e = EXPONENT_CHAR;
94 reset_transput_buffer (INPUT_BUFFER);
95 int ch = char_scanner (f);
96 while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
97 if (IS_NL_FF (ch)) {
98 skip_nl_ff (p, &ch, ref_file);
99 } else {
100 ch = char_scanner (f);
101 }
102 }
103 if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
104 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
105 ch = char_scanner (f);
106 }
107 while (ch != EOF_CHAR && IS_DIGIT (ch)) {
108 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
109 ch = char_scanner (f);
110 }
111 if (ch == EOF_CHAR || !(ch == POINT_CHAR || TO_UPPER (ch) == TO_UPPER (x_e))) {
112 goto salida;
113 }
114 if (ch == POINT_CHAR) {
115 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
116 ch = char_scanner (f);
117 while (ch != EOF_CHAR && IS_DIGIT (ch)) {
118 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
119 ch = char_scanner (f);
120 }
121 }
122 if (ch == EOF_CHAR || TO_UPPER (ch) != TO_UPPER (x_e)) {
123 goto salida;
124 }
125 if (TO_UPPER (ch) == TO_UPPER (x_e)) {
126 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
127 ch = char_scanner (f);
128 while (ch != EOF_CHAR && ch == BLANK_CHAR) {
129 ch = char_scanner (f);
130 }
131 if (ch != EOF_CHAR && (ch == '+' || ch == '-')) {
132 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
133 ch = char_scanner (f);
134 }
135 while (ch != EOF_CHAR && IS_DIGIT (ch)) {
136 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
137 ch = char_scanner (f);
138 }
139 }
140 salida:if (ch != EOF_CHAR) {
141 unchar_scanner (p, f, (char) ch);
142 }
143 }
144
145 //! @brief Scan a bits from file.
146
147 void scan_bits (NODE_T * p, A68G_REF ref_file)
148 {
149 A68G_FILE *f = FILE_DEREF (&ref_file);
150 reset_transput_buffer (INPUT_BUFFER);
151 int ch = char_scanner (f);
152 while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
153 if (IS_NL_FF (ch)) {
154 skip_nl_ff (p, &ch, ref_file);
155 } else {
156 ch = char_scanner (f);
157 }
158 }
159 while (ch != EOF_CHAR && (ch == FLIP_CHAR || ch == FLOP_CHAR)) {
160 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
161 ch = char_scanner (f);
162 }
163 if (ch != EOF_CHAR) {
164 unchar_scanner (p, f, (char) ch);
165 }
166 }
167
168 //! @brief Scan a char from file.
169
170 void scan_char (NODE_T * p, A68G_REF ref_file)
171 {
172 A68G_FILE *f = FILE_DEREF (&ref_file);
173 reset_transput_buffer (INPUT_BUFFER);
174 int ch = char_scanner (f);
175 skip_nl_ff (p, &ch, ref_file);
176 if (ch != EOF_CHAR) {
177 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
178 }
179 }
180
181 //! @brief Scan a string from file.
182
183 void scan_string (NODE_T * p, char *term, A68G_REF ref_file)
184 {
185 A68G_FILE *f = FILE_DEREF (&ref_file);
186 if (END_OF_FILE (f)) {
187 reset_transput_buffer (INPUT_BUFFER);
188 end_of_file_error (p, ref_file);
189 } else {
190 reset_transput_buffer (INPUT_BUFFER);
191 int ch = char_scanner (f);
192 BOOL_T siga = A68G_TRUE;
193 while (siga) {
194 if (ch == EOF_CHAR || END_OF_FILE (f)) {
195 if (get_transput_buffer_index (INPUT_BUFFER) == 0) {
196 end_of_file_error (p, ref_file);
197 }
198 siga = A68G_FALSE;
199 } else if (IS_NL_FF (ch)) {
200 ADDR_T pop_sp = A68G_SP;
201 unchar_scanner (p, f, (char) ch);
202 if (ch == NEWLINE_CHAR) {
203 on_event_handler (p, LINE_END_MENDED (f), ref_file);
204 } else if (ch == FORMFEED_CHAR) {
205 on_event_handler (p, PAGE_END_MENDED (f), ref_file);
206 }
207 A68G_SP = pop_sp;
208 siga = A68G_FALSE;
209 } else if (term != NO_TEXT && strchr (term, ch) != NO_TEXT) {
210 siga = A68G_FALSE;
211 unchar_scanner (p, f, (char) ch);
212 } else {
213 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
214 ch = char_scanner (f);
215 }
216 }
217 }
218 }
219
220 //! @brief Make temp file name.
221
222 BOOL_T a68g_mkstemp (char *fn, int flags, mode_t permissions)
223 {
224 // "tmpnam" is not safe, "mkstemp" is Unix, so a68g brings its own tmpnam.
225 #define TMP_SIZE 32
226 #define TRIALS 32
227 BUFFER tfilename;
228 char *letters = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
229 size_t len = strlen (letters);
230 BOOL_T good_file = A68G_FALSE;
231 // Next are prefixes to try.
232 // First we try /tmp, and if that won't go, the current dir.
233 char *prefix[] = { "/tmp/a68g_", "./a68g_", NO_TEXT };
234 for (int i = 0; prefix[i] != NO_TEXT; i++) {
235 for (int k = 0; k < TRIALS && good_file == A68G_FALSE; k++) {
236 a68g_bufcpy (tfilename, prefix[i], BUFFER_SIZE);
237 for (int j = 0; j < TMP_SIZE; j++) {
238 int cindex;
239 do {
240 cindex = (int) (a68g_unif_rand () * len);
241 } while (cindex < 0 || cindex >= len);
242 char chars[2];
243 chars[0] = letters[cindex];
244 chars[1] = NULL_CHAR;
245 a68g_bufcat (tfilename, chars, BUFFER_SIZE);
246 }
247 a68g_bufcat (tfilename, ".tmp", BUFFER_SIZE);
248 errno = 0;
249 FILE_T fd = open (tfilename, flags | O_EXCL, permissions);
250 good_file = (BOOL_T) (fd != A68G_NO_FILE && errno == 0);
251 if (good_file) {
252 (void) close (fd);
253 }
254 }
255 }
256 if (good_file) {
257 a68g_bufcpy (fn, tfilename, BUFFER_SIZE);
258 return A68G_TRUE;
259 } else {
260 return A68G_FALSE;
261 }
262 #undef TMP_SIZE
263 #undef TRIALS
264 }
265
266 //! @brief Open a file, or establish it.
267
268 FILE_T open_physical_file (NODE_T * p, A68G_REF ref_file, int flags, mode_t permissions)
269 {
270 BOOL_T reading = (flags & ~O_BINARY) == A68G_READ_ACCESS;
271 BOOL_T writing = (flags & ~O_BINARY) == A68G_WRITE_ACCESS;
272 ABEND (reading == writing, ERROR_INTERNAL_CONSISTENCY, __func__);
273 CHECK_REF (p, ref_file, M_REF_FILE);
274 A68G_FILE *file = FILE_DEREF (&ref_file);
275 CHECK_INIT (p, INITIALISED (file), M_FILE);
276 if (!IS_NIL (STRING (file))) {
277 if (writing) {
278 A68G_REF z = *DEREF (A68G_REF, &STRING (file));
279 A68G_ARRAY *arr; A68G_TUPLE *tup;
280 GET_DESCRIPTOR (arr, tup, &z);
281 UPB (tup) = LWB (tup) - 1;
282 }
283 // Associated file.
284 TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
285 reset_transput_buffer (TRANSPUT_BUFFER (file));
286 END_OF_FILE (file) = A68G_FALSE;
287 FILE_ENTRY (file) = -1;
288 return FD (file);
289 } else if (IS_NIL (IDENTIFICATION (file))) {
290 // No identification, so generate a unique identification..
291 if (reading) {
292 return A68G_NO_FILE;
293 } else {
294 BUFFER tfilename;
295 BUFCLR (tfilename);
296 if (!a68g_mkstemp (tfilename, flags, permissions)) {
297 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NO_TEMP);
298 exit_genie (p, A68G_RUNTIME_ERROR);
299 }
300 FD (file) = open (tfilename, flags, permissions);
301 size_t len = 1 + strlen (tfilename);
302 IDENTIFICATION (file) = heap_generator (p, M_C_STRING, len);
303 BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
304 a68g_bufcpy (DEREF (char, &IDENTIFICATION (file)), tfilename, len);
305 TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
306 reset_transput_buffer (TRANSPUT_BUFFER (file));
307 END_OF_FILE (file) = A68G_FALSE;
308 TMP_FILE (file) = A68G_TRUE;
309 FILE_ENTRY (file) = store_file_entry (p, FD (file), tfilename, TMP_FILE (file));
310 return FD (file);
311 }
312 } else {
313 // Opening an identified file.
314 A68G_REF ref_filename = IDENTIFICATION (file);
315 CHECK_REF (p, ref_filename, M_ROWS);
316 char *filename = DEREF (char, &ref_filename);
317 if (OPEN_EXCLUSIVE (file)) {
318 // Establishing requires that the file does not exist.
319 if (flags == (A68G_WRITE_ACCESS)) {
320 flags |= O_EXCL;
321 }
322 OPEN_EXCLUSIVE (file) = A68G_FALSE;
323 }
324 FD (file) = open (filename, flags, permissions);
325 TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
326 reset_transput_buffer (TRANSPUT_BUFFER (file));
327 END_OF_FILE (file) = A68G_FALSE;
328 FILE_ENTRY (file) = store_file_entry (p, FD (file), filename, TMP_FILE (file));
329 return FD (file);
330 }
331 }
332
333 //! @brief Call PROC (REF FILE) VOID during transput.
334
335 void genie_call_proc_ref_file_void (NODE_T * p, A68G_REF ref_file, A68G_PROCEDURE z)
336 {
337 ADDR_T pop_sp = A68G_SP, pop_fp = A68G_FP;
338 MOID_T *u = M_PROC_REF_FILE_VOID;
339 PUSH_REF (p, ref_file);
340 genie_call_procedure (p, MOID (&z), u, u, &z, pop_sp, pop_fp);
341 A68G_SP = pop_sp; // Voiding
342 }
343
344 // Unformatted transput.
345
346 //! @brief Hexadecimal value of digit.
347
348 int char_value (int ch)
349 {
350 switch (ch) {
351 case '0': {
352 return 0;
353 }
354 case '1': {
355 return 1;
356 }
357 case '2': {
358 return 2;
359 }
360 case '3': {
361 return 3;
362 }
363 case '4': {
364 return 4;
365 }
366 case '5': {
367 return 5;
368 }
369 case '6': {
370 return 6;
371 }
372 case '7': {
373 return 7;
374 }
375 case '8': {
376 return 8;
377 }
378 case '9': {
379 return 9;
380 }
381 case 'A':
382 case 'a': {
383 return 10;
384 }
385 case 'B':
386 case 'b': {
387 return 11;
388 }
389 case 'C':
390 case 'c': {
391 return 12;
392 }
393 case 'D':
394 case 'd': {
395 return 13;
396 }
397 case 'E':
398 case 'e': {
399 return 14;
400 }
401 case 'F':
402 case 'f': {
403 return 15;
404 }
405 default: {
406 return -1;
407 }
408 }
409 }
410
411 //! @brief INT value of BITS denotation
412
413 UNSIGNED_T bits_to_int (NODE_T * p, char *str)
414 {
415 errno = 0;
416 char *radix = NO_TEXT, *end = NO_TEXT;
417 int base = (int) a68g_strtou (str, &radix, 10);
418 if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) {
419 UNSIGNED_T bits = 0;
420 if (base < 2 || base > 16) {
421 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base);
422 exit_genie (p, A68G_RUNTIME_ERROR);
423 }
424 bits = a68g_strtou (&(radix[1]), &end, base);
425 if (end != NO_TEXT && end[0] == NULL_CHAR && errno == 0) {
426 return bits;
427 }
428 }
429 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_BITS);
430 exit_genie (p, A68G_RUNTIME_ERROR);
431 return 0;
432 }
433
434 //! @brief Convert string to required mode and store.
435
436 BOOL_T genie_string_to_value_internal (NODE_T * p, MOID_T * m, char *a, BYTE_T * item)
437 {
438 errno = 0;
439 // strto.. does not mind empty strings.
440 if (strlen (a) == 0) {
441 return A68G_FALSE;
442 }
443 if (m == M_INT) {
444 A68G_INT *z = (A68G_INT *) item;
445 char *end;
446 VALUE (z) = (INT_T) a68g_strtoi (a, &end, 10);
447 if (end[0] == NULL_CHAR && errno == 0) {
448 STATUS (z) = INIT_MASK;
449 return A68G_TRUE;
450 } else {
451 return A68G_FALSE;
452 }
453 }
454 if (m == M_REAL) {
455 A68G_REAL *z = (A68G_REAL *) item;
456 char *end;
457 VALUE (z) = strtod (a, &end);
458 if (end[0] == NULL_CHAR && errno == 0) {
459 STATUS (z) = INIT_MASK;
460 return A68G_TRUE;
461 } else {
462 return A68G_FALSE;
463 }
464 }
465 #if (A68G_LEVEL >= 3)
466 if (m == M_LONG_INT) {
467 A68G_LONG_INT *z = (A68G_LONG_INT *) item;
468 if (string_to_double_int (p, z, a) == A68G_FALSE) {
469 return A68G_FALSE;
470 }
471 STATUS (z) = INIT_MASK;
472 return A68G_TRUE;
473 }
474 if (m == M_LONG_REAL) {
475 A68G_LONG_REAL *z = (A68G_LONG_REAL *) item;
476 char *end;
477 // VALUE (z).f = strtoflt128 (a, &end);
478 VALUE (z).f = string_to_double (a, &end);
479 MATH_RTE (p, errno != 0, M_LONG_REAL, ERROR_MATH);
480 if (end[0] == NULL_CHAR && errno == 0) {
481 STATUS (z) = INIT_MASK;
482 return A68G_TRUE;
483 } else {
484 return A68G_FALSE;
485 }
486 }
487 if (m == M_LONG_BITS) {
488 A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
489 int ret = A68G_TRUE;
490 DOUBLE_NUM_T b;
491 set_lw (b, 0x0);
492 if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
493 // [] BOOL denotation is "TTFFFFTFT ...".
494 if (strlen (a) > (size_t) A68G_LONG_BITS_WIDTH) {
495 errno = ERANGE;
496 ret = A68G_FALSE;
497 } else {
498 int n = 1;
499 UNSIGNED_T k = 0x1;
500 for (INT_T j = (INT_T) strlen (a) - 1; j >= 0; j--) {
501 if (a[j] == FLIP_CHAR) {
502 if (n <= A68G_LONG_BITS_WIDTH / 2) {
503 LW (b) |= k;
504 } else {
505 HW (b) |= k;
506 }
507 } else if (a[j] != FLOP_CHAR) {
508 ret = A68G_FALSE;
509 }
510 k <<= 1;
511 }
512 }
513 VALUE (z) = b;
514 } else {
515 // BITS denotation.
516 VALUE (z) = double_strtou (p, a);
517 }
518 return ret;
519 }
520 #else
521 if (m == M_LONG_BITS || m == M_LONG_LONG_BITS) {
522 int digits = DIGITS (m);
523 int status = A68G_TRUE;
524 ADDR_T pop_sp = A68G_SP;
525 MP_T *z = (MP_T *) item;
526 if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
527 // [] BOOL denotation is "TTFFFFTFT ...".
528 if (strlen (a) > (size_t) A68G_BITS_WIDTH) {
529 errno = ERANGE;
530 status = A68G_FALSE;
531 } else {
532 MP_T *w = lit_mp (p, 1, 0, digits);
533 SET_MP_ZERO (z, digits);
534 for (INT_T j = (INT_T) strlen (a) - 1; j >= 0; j--) {
535 if (a[j] == FLIP_CHAR) {
536 (void) add_mp (p, z, z, w, digits);
537 } else if (a[j] != FLOP_CHAR) {
538 status = A68G_FALSE;
539 }
540 (void) mul_mp_digit (p, w, w, (MP_T) 2, digits);
541 }
542 }
543 } else {
544 // BITS denotation is also allowed.
545 mp_strtou (p, z, a, m);
546 }
547 A68G_SP = pop_sp;
548 if (errno != 0 || status == A68G_FALSE) {
549 return A68G_FALSE;
550 }
551 MP_STATUS (z) = (MP_T) INIT_MASK;
552 return A68G_TRUE;
553 }
554 #endif
555 if (m == M_LONG_INT || m == M_LONG_LONG_INT) {
556 int digits = DIGITS (m);
557 MP_T *z = (MP_T *) item;
558 if (strtomp (p, z, a, digits) == NaN_MP) {
559 return A68G_FALSE;
560 }
561 if (!check_mp_int (z, m)) {
562 errno = ERANGE;
563 return A68G_FALSE;
564 }
565 MP_STATUS (z) = (MP_T) INIT_MASK;
566 return A68G_TRUE;
567 }
568 if (m == M_LONG_REAL || m == M_LONG_LONG_REAL) {
569 int digits = DIGITS (m);
570 MP_T *z = (MP_T *) item;
571 if (strtomp (p, z, a, digits) == NaN_MP) {
572 return A68G_FALSE;
573 }
574 MP_STATUS (z) = (MP_T) INIT_MASK;
575 return A68G_TRUE;
576 }
577 if (m == M_BOOL) {
578 A68G_BOOL *z = (A68G_BOOL *) item;
579 char q = a[0], flip = FLIP_CHAR, flop = FLOP_CHAR;
580 if (q == flip || q == flop) {
581 VALUE (z) = (BOOL_T) (q == flip);
582 STATUS (z) = INIT_MASK;
583 return A68G_TRUE;
584 } else {
585 return A68G_FALSE;
586 }
587 }
588 if (m == M_BITS) {
589 A68G_BITS *z = (A68G_BITS *) item;
590 int status = A68G_TRUE;
591 if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
592 // [] BOOL denotation is "TTFFFFTFT ...".
593 if (strlen (a) > (size_t) A68G_BITS_WIDTH) {
594 errno = ERANGE;
595 status = A68G_FALSE;
596 } else {
597 UNSIGNED_T k = 0x1;
598 VALUE (z) = 0;
599 for (INT_T j = (INT_T) strlen (a) - 1; j >= 0; j--) {
600 if (a[j] == FLIP_CHAR) {
601 VALUE (z) += k;
602 } else if (a[j] != FLOP_CHAR) {
603 status = A68G_FALSE;
604 }
605 k <<= 1;
606 }
607 }
608 } else {
609 // BITS denotation is also allowed.
610 VALUE (z) = bits_to_int (p, a);
611 }
612 if (errno != 0 || status == A68G_FALSE) {
613 return A68G_FALSE;
614 }
615 STATUS (z) = INIT_MASK;
616 return A68G_TRUE;
617 }
618 return A68G_FALSE;
619 }
620
621 //! @brief Convert string in input buffer to value of required mode.
622
623 void genie_string_to_value (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
624 {
625 char *str = get_transput_buffer (INPUT_BUFFER);
626 errno = 0;
627 // end string, just in case.
628 plusab_transput_buffer (p, INPUT_BUFFER, NULL_CHAR);
629 if (mode == M_INT) {
630 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
631 value_error (p, mode, ref_file);
632 }
633 } else if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
634 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
635 value_error (p, mode, ref_file);
636 }
637 } else if (mode == M_REAL) {
638 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
639 value_error (p, mode, ref_file);
640 }
641 } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
642 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
643 value_error (p, mode, ref_file);
644 }
645 } else if (mode == M_BOOL) {
646 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
647 value_error (p, mode, ref_file);
648 }
649 } else if (mode == M_BITS) {
650 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
651 value_error (p, mode, ref_file);
652 }
653 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
654 if (genie_string_to_value_internal (p, mode, str, item) == A68G_FALSE) {
655 value_error (p, mode, ref_file);
656 }
657 } else if (mode == M_CHAR) {
658 A68G_CHAR *z = (A68G_CHAR *) item;
659 if (str[0] == NULL_CHAR) {
660 // value_error (p, mode, ref_file);.
661 VALUE (z) = NULL_CHAR;
662 STATUS (z) = INIT_MASK;
663 } else {
664 size_t len = strlen (str);
665 if (len == 0 || len > 1) {
666 value_error (p, mode, ref_file);
667 }
668 VALUE (z) = str[0];
669 STATUS (z) = INIT_MASK;
670 }
671 } else if (mode == M_STRING) {
672 A68G_REF z;
673 z = c_to_a_string (p, str, get_transput_buffer_index (INPUT_BUFFER) - 1);
674 *(A68G_REF *) item = z;
675 }
676 if (errno != 0) {
677 transput_error (p, ref_file, mode);
678 }
679 }
680
681 //! @brief Read object from file.
682
683 void genie_read_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
684 {
685 A68G_FILE *f = FILE_DEREF (&ref_file);
686 errno = 0;
687 if (END_OF_FILE (f)) {
688 end_of_file_error (p, ref_file);
689 }
690 if (mode == M_PROC_REF_FILE_VOID) {
691 genie_call_proc_ref_file_void (p, ref_file, *(A68G_PROCEDURE *) item);
692 } else if (mode == M_FORMAT) {
693 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
694 exit_genie (p, A68G_RUNTIME_ERROR);
695 } else if (mode == M_REF_SOUND) {
696 read_sound (p, ref_file, DEREF (A68G_SOUND, (A68G_REF *) item));
697 } else if (IS_REF (mode)) {
698 CHECK_REF (p, *(A68G_REF *) item, mode);
699 genie_read_standard (p, SUB (mode), ADDRESS ((A68G_REF *) item), ref_file);
700 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
701 scan_integer (p, ref_file);
702 genie_string_to_value (p, mode, item, ref_file);
703 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
704 scan_real (p, ref_file);
705 genie_string_to_value (p, mode, item, ref_file);
706 } else if (mode == M_BOOL) {
707 scan_char (p, ref_file);
708 genie_string_to_value (p, mode, item, ref_file);
709 } else if (mode == M_CHAR) {
710 scan_char (p, ref_file);
711 genie_string_to_value (p, mode, item, ref_file);
712 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
713 scan_bits (p, ref_file);
714 genie_string_to_value (p, mode, item, ref_file);
715 } else if (mode == M_STRING) {
716 char *term = DEREF (char, &TERMINATOR (f));
717 scan_string (p, term, ref_file);
718 genie_string_to_value (p, mode, item, ref_file);
719 } else if (IS_STRUCT (mode)) {
720 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
721 genie_read_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
722 }
723 } else if (IS_UNION (mode)) {
724 A68G_UNION *z = (A68G_UNION *) item;
725 if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
726 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
727 exit_genie (p, A68G_RUNTIME_ERROR);
728 }
729 genie_read_standard (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file);
730 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
731 MOID_T *deflexed = DEFLEX (mode);
732 A68G_ARRAY *arr;
733 A68G_TUPLE *tup;
734 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), mode);
735 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
736 if (get_row_size (tup, DIM (arr)) > 0) {
737 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
738 BOOL_T done = A68G_FALSE;
739 initialise_internal_index (tup, DIM (arr));
740 while (!done) {
741 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
742 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
743 genie_read_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
744 done = increment_internal_index (tup, DIM (arr));
745 }
746 }
747 }
748 if (errno != 0) {
749 transput_error (p, ref_file, mode);
750 }
751 }
752
753 //! @brief PROC ([] SIMPLIN) VOID read
754
755 void genie_read (NODE_T * p)
756 {
757 A68G_REF row;
758 POP_REF (p, &row);
759 genie_stand_in (p);
760 PUSH_REF (p, row);
761 genie_read_file (p);
762 }
763
764 //! @brief Open for reading.
765
766 void open_for_reading (NODE_T * p, A68G_REF ref_file)
767 {
768 A68G_FILE *file = FILE_DEREF (&ref_file);
769 if (!OPENED (file)) {
770 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
771 exit_genie (p, A68G_RUNTIME_ERROR);
772 }
773 if (DRAW_MOOD (file)) {
774 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
775 exit_genie (p, A68G_RUNTIME_ERROR);
776 }
777 if (WRITE_MOOD (file)) {
778 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
779 exit_genie (p, A68G_RUNTIME_ERROR);
780 }
781 if (!GET (&CHANNEL (file))) {
782 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
783 exit_genie (p, A68G_RUNTIME_ERROR);
784 }
785 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
786 if (IS_NIL (STRING (file))) {
787 if ((FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0)) == A68G_NO_FILE) {
788 open_error (p, ref_file, "getting");
789 }
790 } else {
791 FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0);
792 }
793 DRAW_MOOD (file) = A68G_FALSE;
794 READ_MOOD (file) = A68G_TRUE;
795 WRITE_MOOD (file) = A68G_FALSE;
796 CHAR_MOOD (file) = A68G_TRUE;
797 }
798 if (!CHAR_MOOD (file)) {
799 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
800 exit_genie (p, A68G_RUNTIME_ERROR);
801 }
802 }
803
804 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get
805
806 void genie_read_file (NODE_T * p)
807 {
808 A68G_REF row; A68G_ARRAY *arr; A68G_TUPLE *tup;
809 POP_REF (p, &row);
810 CHECK_REF (p, row, M_ROW_SIMPLIN);
811 GET_DESCRIPTOR (arr, tup, &row);
812 int elems = ROW_SIZE (tup);
813 A68G_REF ref_file;
814 POP_REF (p, &ref_file);
815 CHECK_REF (p, ref_file, M_REF_FILE);
816 A68G_FILE *file = FILE_DEREF (&ref_file);
817 CHECK_INIT (p, INITIALISED (file), M_FILE);
818 open_for_reading (p, ref_file);
819 // Read.
820 if (elems <= 0) {
821 return;
822 }
823 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
824 int elem_index = 0;
825 for (int k = 0; k < elems; k++) {
826 A68G_UNION *z = (A68G_UNION *) & base_address[elem_index];
827 MOID_T *mode = (MOID_T *) (VALUE (z));
828 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68G_UNION_SIZE];
829 genie_read_standard (p, mode, item, ref_file);
830 elem_index += SIZE (M_SIMPLIN);
831 }
832 }
833
834 //! @brief Convert value to string.
835
836 void genie_value_to_string (NODE_T * p, MOID_T * moid, BYTE_T * item, int mod)
837 {
838 if (moid == M_INT) {
839 A68G_INT *z = (A68G_INT *) item;
840 PUSH_UNION (p, M_INT);
841 PUSH_VALUE (p, VALUE (z), A68G_INT);
842 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_INT)));
843 if (mod == FORMAT_ITEM_G) {
844 PUSH_VALUE (p, A68G_INT_WIDTH + 1, A68G_INT);
845 genie_whole (p);
846 } else if (mod == FORMAT_ITEM_H) {
847 PUSH_VALUE (p, A68G_REAL_WIDTH + A68G_EXP_WIDTH + 4, A68G_INT);
848 PUSH_VALUE (p, A68G_REAL_WIDTH - 1, A68G_INT);
849 PUSH_VALUE (p, A68G_EXP_WIDTH + 1, A68G_INT);
850 PUSH_VALUE (p, 3, A68G_INT);
851 genie_real (p);
852 }
853 return;
854 }
855 #if (A68G_LEVEL >= 3)
856 if (moid == M_LONG_INT) {
857 A68G_LONG_INT *z = (A68G_LONG_INT *) item;
858 PUSH_UNION (p, M_LONG_INT);
859 PUSH (p, z, SIZE (M_LONG_INT));
860 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_INT)));
861 if (mod == FORMAT_ITEM_G) {
862 PUSH_VALUE (p, A68G_LONG_WIDTH + 1, A68G_INT);
863 genie_whole (p);
864 } else if (mod == FORMAT_ITEM_H) {
865 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4, A68G_INT);
866 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH - 1, A68G_INT);
867 PUSH_VALUE (p, A68G_LONG_EXP_WIDTH + 1, A68G_INT);
868 PUSH_VALUE (p, 3, A68G_INT);
869 genie_real (p);
870 }
871 return;
872 }
873 if (moid == M_LONG_REAL) {
874 A68G_LONG_REAL *z = (A68G_LONG_REAL *) item;
875 PUSH_UNION (p, M_LONG_REAL);
876 PUSH_VALUE (p, VALUE (z), A68G_LONG_REAL);
877 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_REAL)));
878 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4, A68G_INT);
879 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH - 1, A68G_INT);
880 PUSH_VALUE (p, A68G_LONG_EXP_WIDTH + 1, A68G_INT);
881 if (mod == FORMAT_ITEM_G) {
882 genie_float (p);
883 } else if (mod == FORMAT_ITEM_H) {
884 PUSH_VALUE (p, 3, A68G_INT);
885 genie_real (p);
886 }
887 return;
888 }
889 if (moid == M_LONG_BITS) {
890 A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
891 char *s = stack_string (p, 8 + A68G_LONG_BITS_WIDTH);
892 int n = 0;
893 for (int w = 0; w <= 1; w++) {
894 UNSIGNED_T bit = D_SIGN;
895 for (int j = 0; j < A68G_BITS_WIDTH; j++) {
896 if (w == 0) {
897 s[n] = (char) ((HW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR);
898 } else {
899 s[n] = (char) ((LW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR);
900 }
901 bit >>= 1;
902 n++;
903 }
904 }
905 s[n] = NULL_CHAR;
906 return;
907 }
908 #else
909 if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) {
910 int bits = get_mp_bits_width (moid), word = get_mp_bits_words (moid);
911 int pos = bits;
912 char *str = stack_string (p, 8 + bits);
913 ADDR_T pop_sp = A68G_SP;
914 unt *row = stack_mp_bits (p, (MP_T *) item, moid);
915 str[pos--] = NULL_CHAR;
916 while (pos >= 0) {
917 unt bit = 0x1;
918 for (int j = 0; j < MP_BITS_BITS && pos >= 0; j++) {
919 str[pos--] = (char) ((row[word - 1] & bit) ? FLIP_CHAR : FLOP_CHAR);
920 bit <<= 1;
921 }
922 word--;
923 }
924 A68G_SP = pop_sp;
925 return;
926 }
927 #endif
928 if (moid == M_LONG_INT) {
929 MP_T *z = (MP_T *) item;
930 PUSH_UNION (p, M_LONG_INT);
931 PUSH (p, z, SIZE (M_LONG_INT));
932 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_INT)));
933 if (mod == FORMAT_ITEM_G) {
934 PUSH_VALUE (p, A68G_LONG_WIDTH + 1, A68G_INT);
935 genie_whole (p);
936 } else if (mod == FORMAT_ITEM_H) {
937 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4, A68G_INT);
938 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH - 1, A68G_INT);
939 PUSH_VALUE (p, A68G_LONG_EXP_WIDTH + 1, A68G_INT);
940 PUSH_VALUE (p, 3, A68G_INT);
941 genie_real (p);
942 }
943 return;
944 }
945 if (moid == M_LONG_LONG_INT) {
946 MP_T *z = (MP_T *) item;
947 PUSH_UNION (p, M_LONG_LONG_INT);
948 PUSH (p, z, SIZE (M_LONG_LONG_INT));
949 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_LONG_INT)));
950 if (mod == FORMAT_ITEM_G) {
951 PUSH_VALUE (p, A68G_LONG_LONG_WIDTH + 1, A68G_INT);
952 genie_whole (p);
953 } else if (mod == FORMAT_ITEM_H) {
954 PUSH_VALUE (p, A68G_LONG_LONG_REAL_WIDTH + A68G_LONG_LONG_EXP_WIDTH + 4, A68G_INT);
955 PUSH_VALUE (p, A68G_LONG_LONG_REAL_WIDTH - 1, A68G_INT);
956 PUSH_VALUE (p, A68G_LONG_LONG_EXP_WIDTH + 1, A68G_INT);
957 PUSH_VALUE (p, 3, A68G_INT);
958 genie_real (p);
959 }
960 return;
961 }
962 if (moid == M_REAL) {
963 A68G_REAL *z = (A68G_REAL *) item;
964 PUSH_UNION (p, M_REAL);
965 PUSH_VALUE (p, VALUE (z), A68G_REAL);
966 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_REAL)));
967 PUSH_VALUE (p, A68G_REAL_WIDTH + A68G_EXP_WIDTH + 4, A68G_INT);
968 PUSH_VALUE (p, A68G_REAL_WIDTH - 1, A68G_INT);
969 PUSH_VALUE (p, A68G_EXP_WIDTH + 1, A68G_INT);
970 if (mod == FORMAT_ITEM_G) {
971 genie_float (p);
972 } else if (mod == FORMAT_ITEM_H) {
973 PUSH_VALUE (p, 3, A68G_INT);
974 genie_real (p);
975 }
976 return;
977 }
978 if (moid == M_LONG_REAL) {
979 MP_T *z = (MP_T *) item;
980 PUSH_UNION (p, M_LONG_REAL);
981 PUSH (p, z, (int) SIZE (M_LONG_REAL));
982 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_REAL)));
983 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4, A68G_INT);
984 PUSH_VALUE (p, A68G_LONG_REAL_WIDTH - 1, A68G_INT);
985 PUSH_VALUE (p, A68G_LONG_EXP_WIDTH + 1, A68G_INT);
986 if (mod == FORMAT_ITEM_G) {
987 genie_float (p);
988 } else if (mod == FORMAT_ITEM_H) {
989 PUSH_VALUE (p, 3, A68G_INT);
990 genie_real (p);
991 }
992 return;
993 }
994 if (moid == M_LONG_LONG_REAL) {
995 MP_T *z = (MP_T *) item;
996 PUSH_UNION (p, M_LONG_LONG_REAL);
997 PUSH (p, z, (int) SIZE (M_LONG_LONG_REAL));
998 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_LONG_LONG_REAL)));
999 PUSH_VALUE (p, A68G_LONG_LONG_REAL_WIDTH + A68G_LONG_LONG_EXP_WIDTH + 4, A68G_INT);
1000 PUSH_VALUE (p, A68G_LONG_LONG_REAL_WIDTH - 1, A68G_INT);
1001 PUSH_VALUE (p, A68G_LONG_LONG_EXP_WIDTH + 1, A68G_INT);
1002 if (mod == FORMAT_ITEM_G) {
1003 genie_float (p);
1004 } else if (mod == FORMAT_ITEM_H) {
1005 PUSH_VALUE (p, 3, A68G_INT);
1006 genie_real (p);
1007 }
1008 return;
1009 }
1010 if (moid == M_BITS) {
1011 A68G_BITS *z = (A68G_BITS *) item;
1012 char *str = stack_string (p, 8 + A68G_BITS_WIDTH);
1013 UNSIGNED_T bit = 0x1;
1014 int j;
1015 for (j = 1; j < A68G_BITS_WIDTH; j++) {
1016 bit <<= 1;
1017 }
1018 for (j = 0; j < A68G_BITS_WIDTH; j++) {
1019 str[j] = (char) ((VALUE (z) & bit) ? FLIP_CHAR : FLOP_CHAR);
1020 bit >>= 1;
1021 }
1022 str[j] = NULL_CHAR;
1023 return;
1024 }
1025 }
1026
1027 //! @brief Print object to file.
1028
1029 void genie_write_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
1030 {
1031 errno = 0;
1032 ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1033 if (mode == M_PROC_REF_FILE_VOID) {
1034 genie_call_proc_ref_file_void (p, ref_file, *(A68G_PROCEDURE *) item);
1035 } else if (mode == M_FORMAT) {
1036 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1037 exit_genie (p, A68G_RUNTIME_ERROR);
1038 } else if (mode == M_SOUND) {
1039 write_sound (p, ref_file, (A68G_SOUND *) item);
1040 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
1041 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1042 add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
1043 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
1044 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1045 add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
1046 } else if (mode == M_BOOL) {
1047 A68G_BOOL *z = (A68G_BOOL *) item;
1048 char flipflop = (char) (VALUE (z) == A68G_TRUE ? FLIP_CHAR : FLOP_CHAR);
1049 plusab_transput_buffer (p, UNFORMATTED_BUFFER, flipflop);
1050 } else if (mode == M_CHAR) {
1051 A68G_CHAR *ch = (A68G_CHAR *) item;
1052 plusab_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (ch));
1053 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
1054 char *str = (char *) STACK_TOP;
1055 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1056 add_string_transput_buffer (p, UNFORMATTED_BUFFER, str);
1057 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1058 // Handle these separately since this is faster than straightening.
1059 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
1060 } else if (IS_UNION (mode)) {
1061 A68G_UNION *z = (A68G_UNION *) item;
1062 MOID_T *um = (MOID_T *) (VALUE (z));
1063 BYTE_T *ui = &item[A68G_UNION_SIZE];
1064 if (um == NO_MOID) {
1065 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
1066 exit_genie (p, A68G_RUNTIME_ERROR);
1067 }
1068 genie_write_standard (p, um, ui, ref_file);
1069 } else if (IS_STRUCT (mode)) {
1070 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1071 BYTE_T *elem = &item[OFFSET (q)];
1072 genie_check_initialisation (p, elem, MOID (q));
1073 genie_write_standard (p, MOID (q), elem, ref_file);
1074 }
1075 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1076 MOID_T *deflexed = DEFLEX (mode);
1077 A68G_ARRAY *arr;
1078 A68G_TUPLE *tup;
1079 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
1080 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
1081 if (get_row_size (tup, DIM (arr)) > 0) {
1082 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1083 BOOL_T done = A68G_FALSE;
1084 initialise_internal_index (tup, DIM (arr));
1085 while (!done) {
1086 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
1087 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
1088 BYTE_T *elem = &base_addr[elem_addr];
1089 genie_check_initialisation (p, elem, SUB (deflexed));
1090 genie_write_standard (p, SUB (deflexed), elem, ref_file);
1091 done = increment_internal_index (tup, DIM (arr));
1092 }
1093 }
1094 }
1095 if (errno != 0) {
1096 ABEND (IS_NIL (ref_file), ERROR_ACTION, error_specification ());
1097 transput_error (p, ref_file, mode);
1098 }
1099 }
1100
1101 //! @brief PROC ([] SIMPLOUT) VOID print, write
1102
1103 void genie_write (NODE_T * p)
1104 {
1105 A68G_REF row;
1106 POP_REF (p, &row);
1107 genie_stand_out (p);
1108 PUSH_REF (p, row);
1109 genie_write_file (p);
1110 }
1111
1112 //! @brief Open for writing.
1113
1114 void open_for_writing (NODE_T * p, A68G_REF ref_file)
1115 {
1116 A68G_FILE *file = FILE_DEREF (&ref_file);
1117 if (!OPENED (file)) {
1118 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1119 exit_genie (p, A68G_RUNTIME_ERROR);
1120 }
1121 if (DRAW_MOOD (file)) {
1122 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1123 exit_genie (p, A68G_RUNTIME_ERROR);
1124 }
1125 if (READ_MOOD (file)) {
1126 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1127 exit_genie (p, A68G_RUNTIME_ERROR);
1128 }
1129 if (!PUT (&CHANNEL (file))) {
1130 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1131 exit_genie (p, A68G_RUNTIME_ERROR);
1132 }
1133 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1134 if (IS_NIL (STRING (file))) {
1135 if ((FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, A68G_PROTECTION)) == A68G_NO_FILE) {
1136 open_error (p, ref_file, "putting");
1137 }
1138 } else {
1139 FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, 0);
1140 }
1141 DRAW_MOOD (file) = A68G_FALSE;
1142 READ_MOOD (file) = A68G_FALSE;
1143 WRITE_MOOD (file) = A68G_TRUE;
1144 CHAR_MOOD (file) = A68G_TRUE;
1145 }
1146 if (!CHAR_MOOD (file)) {
1147 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
1148 exit_genie (p, A68G_RUNTIME_ERROR);
1149 }
1150 }
1151
1152 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put
1153
1154 void genie_write_file (NODE_T * p)
1155 {
1156 A68G_REF row; A68G_ARRAY *arr; A68G_TUPLE *tup;
1157 POP_REF (p, &row);
1158 CHECK_REF (p, row, M_ROW_SIMPLOUT);
1159 GET_DESCRIPTOR (arr, tup, &row);
1160 int elems = ROW_SIZE (tup);
1161 A68G_REF ref_file;
1162 POP_REF (p, &ref_file);
1163 CHECK_REF (p, ref_file, M_REF_FILE);
1164 A68G_FILE *file = FILE_DEREF (&ref_file);
1165 CHECK_INIT (p, INITIALISED (file), M_FILE);
1166 open_for_writing (p, ref_file);
1167 // Write.
1168 if (elems <= 0) {
1169 return;
1170 }
1171 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1172 int elem_index = 0;
1173 for (int k = 0; k < elems; k++) {
1174 A68G_UNION *z = (A68G_UNION *) & (base_address[elem_index]);
1175 MOID_T *mode = (MOID_T *) (VALUE (z));
1176 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68G_UNION_SIZE];
1177 reset_transput_buffer (UNFORMATTED_BUFFER);
1178 genie_write_standard (p, mode, item, ref_file);
1179 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);
1180 elem_index += SIZE (M_SIMPLOUT);
1181 }
1182 }
1183
1184 //! @brief Read object binary from file.
1185
1186 void genie_read_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
1187 {
1188 CHECK_REF (p, ref_file, M_REF_FILE);
1189 A68G_FILE *f = FILE_DEREF (&ref_file);
1190 errno = 0;
1191 if (END_OF_FILE (f)) {
1192 end_of_file_error (p, ref_file);
1193 }
1194 if (mode == M_PROC_REF_FILE_VOID) {
1195 genie_call_proc_ref_file_void (p, ref_file, *(A68G_PROCEDURE *) item);
1196 } else if (mode == M_FORMAT) {
1197 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1198 exit_genie (p, A68G_RUNTIME_ERROR);
1199 } else if (mode == M_REF_SOUND) {
1200 read_sound (p, ref_file, (A68G_SOUND *) ADDRESS ((A68G_REF *) item));
1201 } else if (IS_REF (mode)) {
1202 CHECK_REF (p, *(A68G_REF *) item, mode);
1203 genie_read_bin_standard (p, SUB (mode), ADDRESS ((A68G_REF *) item), ref_file);
1204 } else if (mode == M_INT) {
1205 A68G_INT *z = (A68G_INT *) item;
1206 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1207 STATUS (z) = INIT_MASK;
1208 } else if (mode == M_LONG_INT) {
1209 #if (A68G_LEVEL >= 3)
1210 A68G_LONG_INT *z = (A68G_LONG_INT *) item;
1211 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1212 STATUS (z) = INIT_MASK;
1213 #else
1214 MP_T *z = (MP_T *) item;
1215 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1216 MP_STATUS (z) = (MP_T) INIT_MASK;
1217 #endif
1218 } else if (mode == M_LONG_LONG_INT) {
1219 MP_T *z = (MP_T *) item;
1220 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1221 MP_STATUS (z) = (MP_T) INIT_MASK;
1222 } else if (mode == M_REAL) {
1223 A68G_REAL *z = (A68G_REAL *) item;
1224 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1225 STATUS (z) = INIT_MASK;
1226 } else if (mode == M_LONG_REAL) {
1227 #if (A68G_LEVEL >= 3)
1228 A68G_LONG_REAL *z = (A68G_LONG_REAL *) item;
1229 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1230 STATUS (z) = INIT_MASK;
1231 #else
1232 MP_T *z = (MP_T *) item;
1233 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1234 MP_STATUS (z) = (MP_T) INIT_MASK;
1235 #endif
1236 } else if (mode == M_LONG_LONG_REAL) {
1237 MP_T *z = (MP_T *) item;
1238 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1239 MP_STATUS (z) = (MP_T) INIT_MASK;
1240 } else if (mode == M_BOOL) {
1241 A68G_BOOL *z = (A68G_BOOL *) item;
1242 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1243 STATUS (z) = INIT_MASK;
1244 } else if (mode == M_CHAR) {
1245 A68G_CHAR *z = (A68G_CHAR *) item;
1246 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1247 STATUS (z) = INIT_MASK;
1248 } else if (mode == M_BITS) {
1249 A68G_BITS *z = (A68G_BITS *) item;
1250 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1251 STATUS (z) = INIT_MASK;
1252 } else if (mode == M_LONG_BITS) {
1253 #if (A68G_LEVEL >= 3)
1254 A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
1255 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1256 STATUS (z) = INIT_MASK;
1257 #else
1258 MP_T *z = (MP_T *) item;
1259 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1260 MP_STATUS (z) = (MP_T) INIT_MASK;
1261 #endif
1262 } else if (mode == M_LONG_LONG_BITS) {
1263 MP_T *z = (MP_T *) item;
1264 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1265 MP_STATUS (z) = (MP_T) INIT_MASK;
1266 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1267 int len;
1268 ASSERT (io_read (FD (f), &(len), sizeof (len)) != -1);
1269 reset_transput_buffer (UNFORMATTED_BUFFER);
1270 for (int k = 0; k < len; k++) {
1271 char ch;
1272 ASSERT (io_read (FD (f), &(ch), sizeof (char)) != -1);
1273 plusab_transput_buffer (p, UNFORMATTED_BUFFER, ch);
1274 }
1275 *(A68G_REF *) item = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
1276 } else if (IS_UNION (mode)) {
1277 A68G_UNION *z = (A68G_UNION *) item;
1278 if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
1279 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
1280 exit_genie (p, A68G_RUNTIME_ERROR);
1281 }
1282 genie_read_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file);
1283 } else if (IS_STRUCT (mode)) {
1284 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1285 genie_read_bin_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
1286 }
1287 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1288 MOID_T *deflexed = DEFLEX (mode);
1289 A68G_ARRAY *arr; A68G_TUPLE *tup;
1290 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
1291 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
1292 if (get_row_size (tup, DIM (arr)) > 0) {
1293 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1294 BOOL_T done = A68G_FALSE;
1295 initialise_internal_index (tup, DIM (arr));
1296 while (!done) {
1297 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
1298 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
1299 genie_read_bin_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
1300 done = increment_internal_index (tup, DIM (arr));
1301 }
1302 }
1303 }
1304 if (errno != 0) {
1305 transput_error (p, ref_file, mode);
1306 }
1307 }
1308
1309 //! @brief PROC ([] SIMPLIN) VOID read bin
1310
1311 void genie_read_bin (NODE_T * p)
1312 {
1313 A68G_REF row;
1314 POP_REF (p, &row);
1315 genie_stand_back (p);
1316 PUSH_REF (p, row);
1317 genie_read_bin_file (p);
1318 }
1319
1320 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get bin
1321
1322 void genie_read_bin_file (NODE_T * p)
1323 {
1324 A68G_REF row; A68G_ARRAY *arr; A68G_TUPLE *tup;
1325 POP_REF (p, &row);
1326 CHECK_REF (p, row, M_ROW_SIMPLIN);
1327 GET_DESCRIPTOR (arr, tup, &row);
1328 int elems = ROW_SIZE (tup);
1329 A68G_REF ref_file;
1330 POP_REF (p, &ref_file);
1331 ref_file = *(A68G_REF *) STACK_TOP;
1332 CHECK_REF (p, ref_file, M_REF_FILE);
1333 A68G_FILE *file = FILE_DEREF (&ref_file);
1334 CHECK_INIT (p, INITIALISED (file), M_FILE);
1335 if (!OPENED (file)) {
1336 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1337 exit_genie (p, A68G_RUNTIME_ERROR);
1338 }
1339 if (DRAW_MOOD (file)) {
1340 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1341 exit_genie (p, A68G_RUNTIME_ERROR);
1342 }
1343 if (WRITE_MOOD (file)) {
1344 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1345 exit_genie (p, A68G_RUNTIME_ERROR);
1346 }
1347 if (!GET (&CHANNEL (file))) {
1348 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
1349 exit_genie (p, A68G_RUNTIME_ERROR);
1350 }
1351 if (!BIN (&CHANNEL (file))) {
1352 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary getting");
1353 exit_genie (p, A68G_RUNTIME_ERROR);
1354 }
1355 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1356 if ((FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS | O_BINARY, 0)) == A68G_NO_FILE) {
1357 open_error (p, ref_file, "binary getting");
1358 }
1359 DRAW_MOOD (file) = A68G_FALSE;
1360 READ_MOOD (file) = A68G_TRUE;
1361 WRITE_MOOD (file) = A68G_FALSE;
1362 CHAR_MOOD (file) = A68G_FALSE;
1363 }
1364 if (CHAR_MOOD (file)) {
1365 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
1366 exit_genie (p, A68G_RUNTIME_ERROR);
1367 }
1368 // Read.
1369 if (elems <= 0) {
1370 return;
1371 }
1372 int elem_index = 0;
1373 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1374 for (int k = 0; k < elems; k++) {
1375 A68G_UNION *z = (A68G_UNION *) & base_address[elem_index];
1376 MOID_T *mode = (MOID_T *) (VALUE (z));
1377 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68G_UNION_SIZE];
1378 genie_read_bin_standard (p, mode, item, ref_file);
1379 elem_index += SIZE (M_SIMPLIN);
1380 }
1381 }
1382
1383 //! @brief Write object binary to file.
1384
1385 void genie_write_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
1386 {
1387 CHECK_REF (p, ref_file, M_REF_FILE);
1388 A68G_FILE *f = FILE_DEREF (&ref_file);
1389 errno = 0;
1390 if (mode == M_PROC_REF_FILE_VOID) {
1391 genie_call_proc_ref_file_void (p, ref_file, *(A68G_PROCEDURE *) item);
1392 } else if (mode == M_FORMAT) {
1393 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1394 exit_genie (p, A68G_RUNTIME_ERROR);
1395 } else if (mode == M_SOUND) {
1396 write_sound (p, ref_file, (A68G_SOUND *) item);
1397 } else if (mode == M_INT) {
1398 ASSERT (io_write (FD (f), &(VALUE ((A68G_INT *) item)), sizeof (VALUE ((A68G_INT *) item))) != -1);
1399 } else if (mode == M_LONG_INT) {
1400 #if (A68G_LEVEL >= 3)
1401 ASSERT (io_write (FD (f), &(VALUE ((A68G_LONG_INT *) item)), sizeof (VALUE ((A68G_LONG_INT *) item))) != -1);
1402 #else
1403 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1404 #endif
1405 } else if (mode == M_LONG_LONG_INT) {
1406 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1407 } else if (mode == M_REAL) {
1408 ASSERT (io_write (FD (f), &(VALUE ((A68G_REAL *) item)), sizeof (VALUE ((A68G_REAL *) item))) != -1);
1409 } else if (mode == M_LONG_REAL) {
1410 #if (A68G_LEVEL >= 3)
1411 ASSERT (io_write (FD (f), &(VALUE ((A68G_LONG_REAL *) item)), sizeof (VALUE ((A68G_LONG_REAL *) item))) != -1);
1412 #else
1413 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1414 #endif
1415 } else if (mode == M_LONG_LONG_REAL) {
1416 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1417 } else if (mode == M_BOOL) {
1418 ASSERT (io_write (FD (f), &(VALUE ((A68G_BOOL *) item)), sizeof (VALUE ((A68G_BOOL *) item))) != -1);
1419 } else if (mode == M_CHAR) {
1420 ASSERT (io_write (FD (f), &(VALUE ((A68G_CHAR *) item)), sizeof (VALUE ((A68G_CHAR *) item))) != -1);
1421 } else if (mode == M_BITS) {
1422 ASSERT (io_write (FD (f), &(VALUE ((A68G_BITS *) item)), sizeof (VALUE ((A68G_BITS *) item))) != -1);
1423 } else if (mode == M_LONG_BITS) {
1424 #if (A68G_LEVEL >= 3)
1425 ASSERT (io_write (FD (f), &(VALUE ((A68G_LONG_BITS *) item)), sizeof (VALUE ((A68G_LONG_BITS *) item))) != -1);
1426 #else
1427 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1428 #endif
1429 } else if (mode == M_LONG_LONG_BITS) {
1430 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1431 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1432 reset_transput_buffer (UNFORMATTED_BUFFER);
1433 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
1434 int len = get_transput_buffer_index (UNFORMATTED_BUFFER);
1435 ASSERT (io_write (FD (f), &(len), sizeof (len)) != -1);
1436 WRITE (FD (f), get_transput_buffer (UNFORMATTED_BUFFER));
1437 } else if (IS_UNION (mode)) {
1438 A68G_UNION *z = (A68G_UNION *) item;
1439 genie_write_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file);
1440 } else if (IS_STRUCT (mode)) {
1441 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1442 BYTE_T *elem = &item[OFFSET (q)];
1443 genie_check_initialisation (p, elem, MOID (q));
1444 genie_write_bin_standard (p, MOID (q), elem, ref_file);
1445 }
1446 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1447 MOID_T *deflexed = DEFLEX (mode);
1448 A68G_ARRAY *arr; A68G_TUPLE *tup;
1449 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
1450 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
1451 if (get_row_size (tup, DIM (arr)) > 0) {
1452 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1453 BOOL_T done = A68G_FALSE;
1454 initialise_internal_index (tup, DIM (arr));
1455 while (!done) {
1456 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
1457 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
1458 BYTE_T *elem = &base_addr[elem_addr];
1459 genie_check_initialisation (p, elem, SUB (deflexed));
1460 genie_write_bin_standard (p, SUB (deflexed), elem, ref_file);
1461 done = increment_internal_index (tup, DIM (arr));
1462 }
1463 }
1464 }
1465 if (errno != 0) {
1466 transput_error (p, ref_file, mode);
1467 }
1468 }
1469
1470 //! @brief PROC ([] SIMPLOUT) VOID write bin, print bin
1471
1472 void genie_write_bin (NODE_T * p)
1473 {
1474 A68G_REF row;
1475 POP_REF (p, &row);
1476 genie_stand_back (p);
1477 PUSH_REF (p, row);
1478 genie_write_bin_file (p);
1479 }
1480
1481 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put bin
1482
1483 void genie_write_bin_file (NODE_T * p)
1484 {
1485 A68G_REF row; A68G_ARRAY *arr; A68G_TUPLE *tup;
1486 POP_REF (p, &row);
1487 CHECK_REF (p, row, M_ROW_SIMPLOUT);
1488 GET_DESCRIPTOR (arr, tup, &row);
1489 int elems = ROW_SIZE (tup);
1490 A68G_REF ref_file;
1491 POP_REF (p, &ref_file);
1492 ref_file = *(A68G_REF *) STACK_TOP;
1493 CHECK_REF (p, ref_file, M_REF_FILE);
1494 A68G_FILE *file = FILE_DEREF (&ref_file);
1495 CHECK_INIT (p, INITIALISED (file), M_FILE);
1496 if (!OPENED (file)) {
1497 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1498 exit_genie (p, A68G_RUNTIME_ERROR);
1499 }
1500 if (DRAW_MOOD (file)) {
1501 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1502 exit_genie (p, A68G_RUNTIME_ERROR);
1503 }
1504 if (READ_MOOD (file)) {
1505 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1506 exit_genie (p, A68G_RUNTIME_ERROR);
1507 }
1508 if (!PUT (&CHANNEL (file))) {
1509 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1510 exit_genie (p, A68G_RUNTIME_ERROR);
1511 }
1512 if (!BIN (&CHANNEL (file))) {
1513 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary putting");
1514 exit_genie (p, A68G_RUNTIME_ERROR);
1515 }
1516 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1517 if ((FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS | O_BINARY, A68G_PROTECTION)) == A68G_NO_FILE) {
1518 open_error (p, ref_file, "binary putting");
1519 }
1520 DRAW_MOOD (file) = A68G_FALSE;
1521 READ_MOOD (file) = A68G_FALSE;
1522 WRITE_MOOD (file) = A68G_TRUE;
1523 CHAR_MOOD (file) = A68G_FALSE;
1524 }
1525 if (CHAR_MOOD (file)) {
1526 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
1527 exit_genie (p, A68G_RUNTIME_ERROR);
1528 }
1529 if (elems <= 0) {
1530 return;
1531 }
1532 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1533 int elem_index = 0;
1534 for (int k = 0; k < elems; k++) {
1535 A68G_UNION *z = (A68G_UNION *) & base_address[elem_index];
1536 MOID_T *mode = (MOID_T *) (VALUE (z));
1537 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68G_UNION_SIZE];
1538 genie_write_bin_standard (p, mode, item, ref_file);
1539 elem_index += SIZE (M_SIMPLOUT);
1540 }
1541 }
1542
1543 // Next are formatting routines "whole", "fixed" and "float" for mode
1544 // INT, LONG INT and LONG LONG INT, and REAL, LONG REAL and LONG LONG REAL.
1545 // They are direct implementations of the routines described in the
1546 // Revised Report, although those were only meant as a specification.
1547
1548 //! @brief Generate a string of error chars.
1549
1550 char *error_chars (char *s, int n)
1551 {
1552 int k = (n != 0 ? ABS (n) : 1);
1553 s[k] = NULL_CHAR;
1554 while (--k >= 0) {
1555 s[k] = ERROR_CHAR;
1556 }
1557 return s;
1558 }
1559
1560 //! @brief Convert temporary C string to A68 string.
1561
1562 A68G_REF tmp_to_a68g_string (NODE_T * p, char *temp_string)
1563 {
1564 // no compaction allowed since temp_string might be up for garbage collecting ...
1565 return c_to_a_string (p, temp_string, DEFAULT_WIDTH);
1566 }
1567
1568 //! @brief Add c to str, assuming that "str" is large enough.
1569
1570 char *plusto (char c, char *str)
1571 {
1572 MOVE (&str[1], &str[0], strlen (str) + 1);
1573 str[0] = c;
1574 return str;
1575 }
1576
1577 //! @brief Add c to str, assuming that "str" is large enough.
1578
1579 char *string_plusab_char (char *str, char c, int strwid)
1580 {
1581 char z[2];
1582 z[0] = c;
1583 z[1] = NULL_CHAR;
1584 a68g_bufcat (str, z, strwid);
1585 return str;
1586 }
1587
1588 //! @brief Add leading spaces to str until length is width.
1589
1590 char *leading_spaces (char *str, int width)
1591 {
1592 int j = width - strlen (str);
1593 while (--j >= 0) {
1594 (void) plusto (BLANK_CHAR, str);
1595 }
1596 return str;
1597 }
1598
1599 //! @brief Convert int to char using a table.
1600
1601 char digchar (int k)
1602 {
1603 char *s = "0123456789abcdefghijklmnopqrstuvwxyz";
1604 if (k >= 0 && k < strlen (s)) {
1605 return s[k];
1606 } else {
1607 return ERROR_CHAR;
1608 }
1609 }
1610
1611 //! @brief Formatted string for HEX_NUMBER.
1612
1613 char *bits_to_string (NODE_T * p)
1614 {
1615 A68G_INT width, base;
1616 POP_OBJECT (p, &base, A68G_INT);
1617 POP_OBJECT (p, &width, A68G_INT);
1618 DECREMENT_STACK_POINTER (p, SIZE (M_HEX_NUMBER));
1619 CHECK_INT_SHORTEN (p, VALUE (&base));
1620 CHECK_INT_SHORTEN (p, VALUE (&width));
1621 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
1622 ADDR_T pop_sp = A68G_SP;
1623 int length = ABS (VALUE (&width)), radix = ABS (VALUE (&base));
1624 if (radix < 2 || radix > 16) {
1625 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1626 exit_genie (p, A68G_RUNTIME_ERROR);
1627 }
1628 reset_transput_buffer (EDIT_BUFFER);
1629 #if (A68G_LEVEL <= 2)
1630 (void) mode;
1631 (void) length;
1632 (void) error_chars (get_transput_buffer (EDIT_BUFFER), VALUE (&width));
1633 #else
1634 {
1635 BOOL_T ret = A68G_TRUE;
1636 if (mode == M_BOOL) {
1637 UNSIGNED_T z = VALUE ((A68G_BOOL *) (STACK_OFFSET (A68G_UNION_SIZE)));
1638 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
1639 } else if (mode == M_CHAR) {
1640 INT_T z = VALUE ((A68G_CHAR *) (STACK_OFFSET (A68G_UNION_SIZE)));
1641 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
1642 } else if (mode == M_INT) {
1643 INT_T z = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
1644 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
1645 } else if (mode == M_REAL) {
1646 // A trick to copy a REAL into an unt without truncating
1647 UNSIGNED_T z;
1648 memcpy (&z, (void *) &VALUE ((A68G_REAL *) (STACK_OFFSET (A68G_UNION_SIZE))), 8);
1649 ret = convert_radix (p, z, radix, length);
1650 } else if (mode == M_BITS) {
1651 UNSIGNED_T z = VALUE ((A68G_BITS *) (STACK_OFFSET (A68G_UNION_SIZE)));
1652 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
1653 } else if (mode == M_LONG_INT) {
1654 DOUBLE_NUM_T z = VALUE ((A68G_LONG_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
1655 ret = convert_radix_double (p, z, radix, length);
1656 } else if (mode == M_LONG_REAL) {
1657 DOUBLE_NUM_T z = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
1658 ret = convert_radix_double (p, z, radix, length);
1659 } else if (mode == M_LONG_BITS) {
1660 DOUBLE_NUM_T z = VALUE ((A68G_LONG_BITS *) (STACK_OFFSET (A68G_UNION_SIZE)));
1661 ret = convert_radix_double (p, z, radix, length);
1662 }
1663 if (ret == A68G_FALSE) {
1664 errno = EDOM;
1665 PRELUDE_ERROR (A68G_TRUE, p, ERROR_OUT_OF_BOUNDS, mode);
1666 }
1667 }
1668 #endif
1669 A68G_SP = pop_sp;
1670 return get_transput_buffer (EDIT_BUFFER);
1671 }
1672
1673 //! @brief Standard string for LONG INT.
1674
1675 char *sub_whole_mp (NODE_T * p, MP_T * m, int digits, int width)
1676 {
1677 int len = 0;
1678 char *s = stack_string (p, 8 + width);
1679 s[0] = NULL_CHAR;
1680 ADDR_T pop_sp = A68G_SP;
1681 MP_T *n = nil_mp (p, digits);
1682 (void) move_mp (n, m, digits);
1683 do {
1684 if (len < width) {
1685 // Sic transit gloria mundi.
1686 int n_mod_10 = (MP_INT_T) MP_DIGIT (n, (int) (1 + MP_EXPONENT (n))) % 10;
1687 (void) plusto (digchar (n_mod_10), s);
1688 }
1689 len++;
1690 (void) over_mp_digit (p, n, n, (MP_T) 10, digits);
1691 } while (MP_DIGIT (n, 1) > 0);
1692 if (len > width) {
1693 (void) error_chars (s, width);
1694 }
1695 A68G_SP = pop_sp;
1696 return s;
1697 }
1698
1699 //! @brief Formatted string for NUMBER.
1700
1701 char *whole (NODE_T * p)
1702 {
1703 A68G_INT width;
1704 POP_OBJECT (p, &width, A68G_INT);
1705 CHECK_INT_SHORTEN (p, VALUE (&width));
1706 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1707 ADDR_T pop_sp = A68G_SP;
1708 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
1709 //
1710 if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
1711 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1712 PUSH_VALUE (p, VALUE (&width), A68G_INT);
1713 PUSH_VALUE (p, 0, A68G_INT);
1714 return fixed (p);
1715 } else if (mode == M_INT) {
1716 INT_T x = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
1717 int digits = DIGITS (M_LONG_LONG_INT);
1718 PUSH_UNION (p, (void *) M_LONG_LONG_INT);
1719 MP_T *z = nil_mp (p, digits);
1720 (void) int_to_mp (p, z, x, digits);
1721 PUSH_PRIMAL (p, VALUE (&width), INT);
1722 return whole (p);
1723 }
1724 #if (A68G_LEVEL >= 3)
1725 if (mode == M_LONG_INT) {
1726 DOUBLE_NUM_T x = VALUE ((A68G_LONG_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
1727 int digits = DIGITS (M_LONG_LONG_INT);
1728 PUSH_UNION (p, (void *) M_LONG_LONG_INT);
1729 MP_T *z = nil_mp (p, digits);
1730 (void) double_int_to_mp (p, z, x, digits);
1731 PUSH_PRIMAL (p, VALUE (&width), INT);
1732 return whole (p);
1733 }
1734 #endif
1735 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
1736 int digits = DIGITS (mode);
1737 MP_T *n = (MP_T *) (STACK_OFFSET (A68G_UNION_SIZE));
1738 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1739 if (MP_EXPONENT (n) >= (MP_T) digits) {
1740 int max_length = (mode == M_LONG_INT ? A68G_LONG_INT_WIDTH : A68G_LONG_LONG_INT_WIDTH);
1741 int length = (VALUE (&width) == 0 ? max_length : VALUE (&width));
1742 char *s = stack_string (p, 1 + length);
1743 (void) error_chars (s, length);
1744 A68G_SP = pop_sp;
1745 return s;
1746 }
1747 BOOL_T ltz = (BOOL_T) (MP_DIGIT (n, 1) < 0);
1748 int length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
1749 size_t size = (ltz ? 1 : (VALUE (&width) > 0 ? 1 : 0));
1750 MP_DIGIT (n, 1) = ABS (MP_DIGIT (n, 1));
1751 if (VALUE (&width) == 0) {
1752 MP_T *m = nil_mp (p, digits);
1753 (void) move_mp (m, n, digits);
1754 length = 0;
1755 while ((over_mp_digit (p, m, m, (MP_T) 10, digits), length++, MP_DIGIT (m, 1) != 0)) {
1756 ;
1757 }
1758 }
1759 size += length;
1760 int abs_width = ABS (VALUE (&width));
1761 size = 8 + MAX (size, abs_width);
1762 char *s = stack_string (p, size);
1763 a68g_bufcpy (s, sub_whole_mp (p, n, digits, length), size);
1764 if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
1765 (void) error_chars (s, abs_width);
1766 } else {
1767 if (ltz) {
1768 (void) plusto ('-', s);
1769 } else if (VALUE (&width) > 0) {
1770 (void) plusto ('+', s);
1771 }
1772 if (VALUE (&width) != 0) {
1773 (void) leading_spaces (s, abs_width);
1774 }
1775 }
1776 A68G_SP = pop_sp;
1777 return s;
1778 }
1779 ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1780 return NO_TEXT;
1781 }
1782
1783 //! @brief Fetch next digit from LONG.
1784
1785 char choose_dig_mp (NODE_T * p, MP_T * y, int digits)
1786 {
1787 // Assuming positive "y".
1788 ADDR_T pop_sp = A68G_SP;
1789 (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
1790 int c = MP_EXPONENT (y) == 0 ? (MP_INT_T) MP_DIGIT (y, 1) : 0;
1791 if (c > 9) {
1792 c = 9;
1793 }
1794 MP_T *t = lit_mp (p, c, 0, digits);
1795 (void) sub_mp (p, y, y, t, digits);
1796 // Reset the stack to prevent overflow, there may be many digits.
1797 A68G_SP = pop_sp;
1798 return digchar (c);
1799 }
1800
1801 //! @brief Standard string for LONG.
1802
1803 char *sub_fixed_mp (NODE_T * p, MP_T * x, int digits, int width, int after)
1804 {
1805 ADDR_T pop_sp = A68G_SP;
1806 MP_T *y = nil_mp (p, digits);
1807 MP_T *s = nil_mp (p, digits);
1808 MP_T *t = nil_mp (p, digits);
1809 (void) ten_up_mp (p, t, -after, digits);
1810 (void) half_mp (p, t, t, digits);
1811 (void) add_mp (p, y, x, t, digits);
1812 int before = 0;
1813 // Not RR - argument reduction.
1814 while (MP_EXPONENT (y) > 1) {
1815 int k = (int) round (MP_EXPONENT (y) - 1);
1816 MP_EXPONENT (y) -= k;
1817 before += k * LOG_MP_RADIX;
1818 }
1819 // Follow RR again.
1820 SET_MP_ONE (s, digits);
1821 while ((sub_mp (p, t, y, s, digits), MP_DIGIT (t, 1) >= 0)) {
1822 before++;
1823 (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
1824 }
1825 // Compose the number.
1826 if (before + after + (after > 0 ? 1 : 0) > width) {
1827 char *str = stack_string (p, width + 1);
1828 (void) error_chars (str, width);
1829 A68G_SP = pop_sp;
1830 return str;
1831 }
1832 int strwid = 8 + before + after;
1833 char *str = stack_string (p, strwid);
1834 str[0] = NULL_CHAR;
1835 int len = 0;
1836 for (int j = 0; j < before; j++) {
1837 char ch = (char) (len < A68G_LONG_LONG_REAL_WIDTH ? choose_dig_mp (p, y, digits) : '0');
1838 (void) string_plusab_char (str, ch, strwid);
1839 len++;
1840 }
1841 if (after > 0) {
1842 (void) string_plusab_char (str, POINT_CHAR, strwid);
1843 }
1844 for (int j = 0; j < after; j++) {
1845 char ch = (char) (len < A68G_LONG_LONG_REAL_WIDTH ? choose_dig_mp (p, y, digits) : '0');
1846 (void) string_plusab_char (str, ch, strwid);
1847 len++;
1848 }
1849 if (strlen (str) > width) {
1850 (void) error_chars (str, width);
1851 }
1852 A68G_SP = pop_sp;
1853 return str;
1854 }
1855
1856 //! @brief Formatted string for NUMBER.
1857
1858 char *fixed (NODE_T * p)
1859 {
1860 A68G_INT width, after;
1861 POP_OBJECT (p, &after, A68G_INT);
1862 POP_OBJECT (p, &width, A68G_INT);
1863 CHECK_INT_SHORTEN (p, VALUE (&after));
1864 CHECK_INT_SHORTEN (p, VALUE (&width));
1865 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1866 ADDR_T pop_sp = A68G_SP;
1867 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
1868 if (mode == M_INT) {
1869 INT_T k = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
1870 PUSH_UNION (p, M_REAL);
1871 PUSH_VALUE (p, (REAL_T) k, A68G_REAL);
1872 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_REAL)));
1873 PUSH_VALUE (p, VALUE (&width), A68G_INT);
1874 PUSH_VALUE (p, VALUE (&after), A68G_INT);
1875 return fixed (p);
1876 } else if (mode == M_REAL) {
1877 REAL_T x = VALUE ((A68G_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
1878 int digits = DIGITS (M_LONG_LONG_REAL);
1879 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
1880 MP_T *z = nil_mp (p, digits);
1881 #if (A68G_LEVEL >= 3)
1882 (void) double_to_mp (p, z, (DOUBLE_T) x, A68G_REAL_DIG, A68G_TRUE, digits);
1883 #else
1884 (void) real_to_mp (p, z, x, digits);
1885 #endif
1886 PUSH_PRIMAL (p, VALUE (&width), INT);
1887 PUSH_PRIMAL (p, VALUE (&after), INT);
1888 return fixed (p);
1889 }
1890 #if (A68G_LEVEL >= 3)
1891 if (mode == M_LONG_INT) {
1892 DOUBLE_NUM_T x = VALUE ((A68G_LONG_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
1893 int digits = DIGITS (M_LONG_LONG_REAL);
1894 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
1895 MP_T *z = nil_mp (p, digits);
1896 (void) double_int_to_mp (p, z, x, digits);
1897 PUSH_PRIMAL (p, VALUE (&width), INT);
1898 PUSH_PRIMAL (p, VALUE (&after), INT);
1899 return fixed (p);
1900 } else if (mode == M_LONG_REAL) {
1901 DOUBLE_T x = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE))).f;
1902 CHECK_DOUBLE_REAL (p, x);
1903 int digits = DIGITS (M_LONG_LONG_REAL);
1904 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
1905 MP_T *z = nil_mp (p, digits);
1906 (void) double_to_mp (p, z, x, A68G_DOUBLE_DIG, A68G_TRUE, digits);
1907 PUSH_PRIMAL (p, VALUE (&width), INT);
1908 PUSH_PRIMAL (p, VALUE (&after), INT);
1909 return fixed (p);
1910 }
1911 #endif
1912 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
1913 if (mode == M_LONG_INT) {
1914 VALUE ((A68G_UNION *) STACK_TOP) = (void *) M_LONG_REAL;
1915 } else {
1916 VALUE ((A68G_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL;
1917 }
1918 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1919 PUSH_VALUE (p, VALUE (&width), A68G_INT);
1920 PUSH_VALUE (p, VALUE (&after), A68G_INT);
1921 return fixed (p);
1922 } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
1923 int digits = DIGITS (mode);
1924 MP_T *x = (MP_T *) (STACK_OFFSET (A68G_UNION_SIZE));
1925 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1926 BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
1927 MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
1928 int length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
1929 if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
1930 MP_T *z0 = nil_mp (p, digits);
1931 MP_T *z1 = nil_mp (p, digits);
1932 MP_T *t = nil_mp (p, digits);
1933 if (VALUE (&width) == 0) {
1934 length = (VALUE (&after) == 0 ? 1 : 0);
1935 (void) set_mp (z0, (MP_T) (MP_RADIX / 10), -1, digits);
1936 (void) set_mp (z1, (MP_T) 10, 0, digits);
1937 (void) pow_mp_int (p, z0, z0, VALUE (&after), digits);
1938 (void) pow_mp_int (p, z1, z1, length, digits);
1939 while ((div_mp_digit (p, t, z0, (MP_T) 2, digits), add_mp (p, t, x, t, digits), sub_mp (p, t, t, z1, digits), MP_DIGIT (t, 1) > 0)) {
1940 length++;
1941 (void) mul_mp_digit (p, z1, z1, (MP_T) 10, digits);
1942 }
1943 length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
1944 }
1945 char *s = sub_fixed_mp (p, x, digits, length, VALUE (&after));
1946 if (strchr (s, ERROR_CHAR) == NO_TEXT) {
1947 if (length > strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68G_TRUE) && (MP_EXPONENT (x) < 0 || MP_DIGIT (x, 1) == 0)) {
1948 (void) plusto ('0', s);
1949 }
1950 if (ltz) {
1951 (void) plusto ('-', s);
1952 } else if (VALUE (&width) > 0) {
1953 (void) plusto ('+', s);
1954 }
1955 if (VALUE (&width) != 0) {
1956 (void) leading_spaces (s, ABS (VALUE (&width)));
1957 }
1958 A68G_SP = pop_sp;
1959 return s;
1960 } else if (VALUE (&after) > 0) {
1961 A68G_SP = pop_sp;
1962 MP_DIGIT (x, 1) = ltz ? -ABS (MP_DIGIT (x, 1)) : ABS (MP_DIGIT (x, 1));
1963 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1964 PUSH_VALUE (p, VALUE (&width), A68G_INT);
1965 PUSH_VALUE (p, VALUE (&after) - 1, A68G_INT);
1966 return fixed (p);
1967 } else {
1968 A68G_SP = pop_sp;
1969 return error_chars (s, VALUE (&width));
1970 }
1971 } else {
1972 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
1973 A68G_SP = pop_sp;
1974 return error_chars (s, VALUE (&width));
1975 }
1976 }
1977 ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1978 return NO_TEXT;
1979 }
1980
1981 //! @brief Scale LONG for formatting.
1982
1983 void standardize_mp (NODE_T * p, MP_T * y, int digits, int before, int after, int *q)
1984 {
1985 ADDR_T pop_sp = A68G_SP;
1986 MP_T *f = nil_mp (p, digits);
1987 MP_T *g = nil_mp (p, digits);
1988 MP_T *h = nil_mp (p, digits);
1989 MP_T *t = nil_mp (p, digits);
1990 ten_up_mp (p, g, before, digits);
1991 (void) div_mp_digit (p, h, g, (MP_T) 10, digits);
1992 // Speed huge exponents.
1993 if ((MP_EXPONENT (y) - MP_EXPONENT (g)) > 1) {
1994 (*q) += LOG_MP_RADIX * ((int) MP_EXPONENT (y) - (int) MP_EXPONENT (g) - 1);
1995 MP_EXPONENT (y) = MP_EXPONENT (g) + 1;
1996 }
1997 while ((sub_mp (p, t, y, g, digits), MP_DIGIT (t, 1) >= 0)) {
1998 (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
1999 (*q)++;
2000 }
2001 if (MP_DIGIT (y, 1) != 0) {
2002 // Speed huge exponents.
2003 if ((MP_EXPONENT (y) - MP_EXPONENT (h)) < -1) {
2004 (*q) -= LOG_MP_RADIX * ((int) MP_EXPONENT (h) - (int) MP_EXPONENT (y) - 1);
2005 MP_EXPONENT (y) = MP_EXPONENT (h) - 1;
2006 }
2007 while ((sub_mp (p, t, y, h, digits), MP_DIGIT (t, 1) < 0)) {
2008 (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
2009 (*q)--;
2010 }
2011 }
2012 ten_up_mp (p, f, -after, digits);
2013 (void) div_mp_digit (p, t, f, (MP_T) 2, digits);
2014 (void) add_mp (p, t, y, t, digits);
2015 (void) sub_mp (p, t, t, g, digits);
2016 if (MP_DIGIT (t, 1) >= 0) {
2017 (void) move_mp (y, h, digits);
2018 (*q)++;
2019 }
2020 A68G_SP = pop_sp;
2021 }
2022
2023 //! @brief Formatted string for NUMBER.
2024
2025 char *real (NODE_T * p)
2026 {
2027 // POP arguments.
2028 A68G_INT width, after, expo, frmt;
2029 POP_OBJECT (p, &frmt, A68G_INT);
2030 POP_OBJECT (p, &expo, A68G_INT);
2031 POP_OBJECT (p, &after, A68G_INT);
2032 POP_OBJECT (p, &width, A68G_INT);
2033 CHECK_INT_SHORTEN (p, VALUE (&frmt));
2034 CHECK_INT_SHORTEN (p, VALUE (&expo));
2035 CHECK_INT_SHORTEN (p, VALUE (&after));
2036 CHECK_INT_SHORTEN (p, VALUE (&width));
2037 ADDR_T arg_sp = A68G_SP;
2038 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2039 MOID_T *mode = (MOID_T *) (VALUE ((A68G_UNION *) STACK_TOP));
2040 ADDR_T pop_sp = A68G_SP;
2041 //
2042 if (mode == M_INT) {
2043 INT_T k = VALUE ((A68G_INT *) (STACK_OFFSET (A68G_UNION_SIZE)));
2044 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
2045 int digits = DIGITS (M_LONG_LONG_REAL);
2046 MP_T *z = nil_mp (p, digits);
2047 int_to_mp (p, z, k, digits);
2048 PUSH_VALUE (p, VALUE (&width), A68G_INT);
2049 PUSH_VALUE (p, VALUE (&after), A68G_INT);
2050 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
2051 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
2052 return real (p);
2053 } else if (mode == M_REAL) {
2054 REAL_T x = VALUE ((A68G_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
2055 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
2056 int digits = DIGITS (M_LONG_LONG_REAL);
2057 MP_T *z = nil_mp (p, digits);
2058 #if (A68G_LEVEL >= 3)
2059 (void) double_to_mp (p, z, (DOUBLE_T) x, A68G_REAL_DIG, A68G_TRUE, digits);
2060 #else
2061 (void) real_to_mp (p, z, x, digits);
2062 #endif
2063 PUSH_PRIMAL (p, VALUE (&width), INT);
2064 PUSH_PRIMAL (p, VALUE (&after), INT);
2065 PUSH_PRIMAL (p, VALUE (&expo), INT);
2066 PUSH_PRIMAL (p, VALUE (&frmt), INT);
2067 return real (p);
2068 }
2069 #if (A68G_LEVEL >= 3)
2070 if (mode == M_LONG_INT) {
2071 DOUBLE_NUM_T k = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE)));
2072 int digits = DIGITS (M_LONG_LONG_REAL);
2073 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
2074 MP_T *z = nil_mp (p, digits);
2075 (void) double_int_to_mp (p, z, k, digits);
2076 PUSH_PRIMAL (p, VALUE (&width), INT);
2077 PUSH_PRIMAL (p, VALUE (&after), INT);
2078 PUSH_PRIMAL (p, VALUE (&expo), INT);
2079 PUSH_PRIMAL (p, VALUE (&frmt), INT);
2080 return real (p);
2081 } else if (mode == M_LONG_REAL) {
2082 DOUBLE_T x = VALUE ((A68G_LONG_REAL *) (STACK_OFFSET (A68G_UNION_SIZE))).f;
2083 CHECK_DOUBLE_REAL (p, x);
2084 int digits = DIGITS (M_LONG_LONG_REAL);
2085 PUSH_UNION (p, (void *) M_LONG_LONG_REAL);
2086 MP_T *z = nil_mp (p, digits);
2087 (void) double_to_mp (p, z, (DOUBLE_T) x, A68G_DOUBLE_DIG, A68G_TRUE, digits);
2088 PUSH_PRIMAL (p, VALUE (&width), INT);
2089 PUSH_PRIMAL (p, VALUE (&after), INT);
2090 PUSH_PRIMAL (p, VALUE (&expo), INT);
2091 PUSH_PRIMAL (p, VALUE (&frmt), INT);
2092 return real (p);
2093 }
2094 #endif
2095 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2096 A68G_SP = pop_sp;
2097 if (mode == M_LONG_INT) {
2098 VALUE ((A68G_UNION *) STACK_TOP) = (void *) M_LONG_REAL;
2099 } else {
2100 VALUE ((A68G_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL;
2101 }
2102 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2103 PUSH_VALUE (p, VALUE (&width), A68G_INT);
2104 PUSH_VALUE (p, VALUE (&after), A68G_INT);
2105 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
2106 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
2107 return real (p);
2108 } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2109 int digits = DIGITS (mode);
2110 int before;
2111 MP_T *x = (MP_T *) (STACK_OFFSET (A68G_UNION_SIZE));
2112 CHECK_LONG_REAL (p, x, mode);
2113 BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
2114 A68G_SP = arg_sp;
2115 MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
2116 before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
2117 if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
2118 int q = 0;
2119 size_t N_mp = SIZE_MP (digits);
2120 MP_T *z = nil_mp (p, digits);
2121 (void) move_mp (z, x, digits);
2122 standardize_mp (p, z, digits, before, VALUE (&after), &q);
2123 if (VALUE (&frmt) > 0) {
2124 while (q % VALUE (&frmt) != 0) {
2125 (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
2126 q--;
2127 if (VALUE (&after) > 0) {
2128 VALUE (&after)--;
2129 }
2130 }
2131 } else {
2132 ADDR_T sp1 = A68G_SP;
2133 MP_T *dif = nil_mp (p, digits);
2134 MP_T *lim = nil_mp (p, digits);
2135 (void) ten_up_mp (p, lim, -VALUE (&frmt) - 1, digits);
2136 (void) sub_mp (p, dif, z, lim, digits);
2137 while (MP_DIGIT (dif, 1) < 0) {
2138 (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
2139 q--;
2140 if (VALUE (&after) > 0) {
2141 VALUE (&after)--;
2142 }
2143 (void) sub_mp (p, dif, z, lim, digits);
2144 }
2145 (void) mul_mp_digit (p, lim, lim, (MP_T) 10, digits);
2146 (void) sub_mp (p, dif, z, lim, digits);
2147 while (MP_DIGIT (dif, 1) > 0) {
2148 (void) div_mp_digit (p, z, z, (MP_T) 10, digits);
2149 q++;
2150 if (VALUE (&after) > 0) {
2151 VALUE (&after)++;
2152 }
2153 (void) sub_mp (p, dif, z, lim, digits);
2154 }
2155 A68G_SP = sp1;
2156 }
2157 //
2158 int strwid = 8 + ABS (VALUE (&width));
2159 char *s = stack_string (p, strwid);
2160 // Mantissa.
2161 PUSH_UNION (p, mode);
2162 MP_DIGIT (z, 1) = (ltz ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1));
2163 PUSH (p, z, N_mp);
2164 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE_MP (digits)));
2165 PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68G_INT);
2166 PUSH_VALUE (p, VALUE (&after), A68G_INT);
2167 a68g_bufcpy (s, fixed (p), strwid);
2168 // Exponent.
2169 PUSH_UNION (p, M_INT);
2170 PUSH_VALUE (p, q, A68G_INT);
2171 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68G_UNION_SIZE + SIZE (M_INT)));
2172 PUSH_VALUE (p, VALUE (&expo), A68G_INT);
2173 (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
2174 a68g_bufcat (s, whole (p), strwid);
2175 // Recursion when error chars.
2176 if (VALUE (&expo) == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
2177 A68G_SP = arg_sp;
2178 // INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2179 PUSH_VALUE (p, VALUE (&width), A68G_INT);
2180 PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68G_INT);
2181 PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68G_INT);
2182 PUSH_VALUE (p, VALUE (&frmt), A68G_INT);
2183 return real (p);
2184 } else {
2185 A68G_SP = pop_sp;
2186 return s;
2187 }
2188 } else {
2189 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2190 A68G_SP = pop_sp;
2191 return error_chars (s, VALUE (&width));
2192 }
2193 }
2194 ABEND (A68G_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
2195 return NO_TEXT;
2196 }
2197
2198 //! @brief PROC (NUMBER, INT) STRING whole
2199
2200 void genie_whole (NODE_T * p)
2201 {
2202 PUSH_REF(p, tmp_to_a68g_string (p, whole (p)));
2203 }
2204
2205 //! @brief PROC (NUMBER, INT, INT) STRING bits
2206
2207 void genie_bits (NODE_T * p)
2208 {
2209 PUSH_REF (p, tmp_to_a68g_string (p, bits_to_string (p)));
2210 }
2211
2212 //! @brief PROC (NUMBER, INT, INT) STRING fixed
2213
2214 void genie_fixed (NODE_T * p)
2215 {
2216 PUSH_REF (p, tmp_to_a68g_string (p, fixed (p)));
2217 }
2218
2219 //! @brief PROC (NUMBER, INT, INT, INT) STRING eng
2220
2221 void genie_real (NODE_T * p)
2222 {
2223 PUSH_REF (p, tmp_to_a68g_string (p, real (p)));
2224 }
2225
2226 //! @brief PROC (NUMBER, INT, INT, INT) STRING float
2227
2228 void genie_float (NODE_T * p)
2229 {
2230 PUSH_VALUE (p, 1, A68G_INT);
2231 genie_real (p);
2232 }
2233
2234 // ALGOL68C routines.
2235
2236 //! @def A68C_TRANSPUT
2237 //! @brief Generate Algol68C routines readint, getint, etcetera.
2238
2239 #define A68C_TRANSPUT(n, m)\
2240 void genie_get_##n (NODE_T * p)\
2241 {\
2242 A68G_REF ref_file;\
2243 POP_REF (p, &ref_file);\
2244 CHECK_REF (p, ref_file, M_REF_FILE);\
2245 BYTE_T *z = STACK_TOP;\
2246 INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
2247 ADDR_T pop_sp = A68G_SP;\
2248 open_for_reading (p, ref_file);\
2249 genie_read_standard (p, MODE (m), z, ref_file);\
2250 A68G_SP = pop_sp;\
2251 }\
2252 void genie_put_##n (NODE_T * p)\
2253 {\
2254 size_t size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\
2255 A68G_REF ref_file = * (A68G_REF *) STACK_OFFSET (- (size + sizf));\
2256 CHECK_REF (p, ref_file, M_REF_FILE);\
2257 reset_transput_buffer (UNFORMATTED_BUFFER);\
2258 open_for_writing (p, ref_file);\
2259 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
2260 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
2261 DECREMENT_STACK_POINTER (p, size + sizf);\
2262 }\
2263 void genie_read_##n (NODE_T * p)\
2264 {\
2265 BYTE_T *z = STACK_TOP;\
2266 INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
2267 ADDR_T pop_sp = A68G_SP;\
2268 open_for_reading (p, A68G (stand_in));\
2269 genie_read_standard (p, MODE (m), z, A68G (stand_in));\
2270 A68G_SP = pop_sp;\
2271 }\
2272 void genie_print_##n (NODE_T * p)\
2273 {\
2274 size_t size = SIZE (MODE (m));\
2275 reset_transput_buffer (UNFORMATTED_BUFFER);\
2276 open_for_writing (p, A68G (stand_out));\
2277 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68G (stand_out));\
2278 write_purge_buffer (p, A68G (stand_out), UNFORMATTED_BUFFER);\
2279 DECREMENT_STACK_POINTER (p, size);\
2280 }
2281
2282 A68C_TRANSPUT (int, INT);
2283 A68C_TRANSPUT (long_int, LONG_INT);
2284 A68C_TRANSPUT (long_mp_int, LONG_LONG_INT);
2285 A68C_TRANSPUT (real, REAL);
2286 A68C_TRANSPUT (long_real, LONG_REAL);
2287 A68C_TRANSPUT (long_mp_real, LONG_LONG_REAL);
2288 A68C_TRANSPUT (bits, BITS);
2289 A68C_TRANSPUT (long_bits, LONG_BITS);
2290 A68C_TRANSPUT (long_mp_bits, LONG_LONG_BITS);
2291 A68C_TRANSPUT (bool, BOOL);
2292 A68C_TRANSPUT (char, CHAR);
2293 A68C_TRANSPUT (string, STRING);
2294
2295 #undef A68C_TRANSPUT
2296
2297 #define A68C_TRANSPUT(n, s, m)\
2298 void genie_get_##n (NODE_T * p) {\
2299 A68G_REF ref_file;\
2300 POP_REF (p, &ref_file);\
2301 CHECK_REF (p, ref_file, M_REF_FILE);\
2302 PUSH_REF (p, ref_file);\
2303 genie_get_##s (p);\
2304 PUSH_REF (p, ref_file);\
2305 genie_get_##s (p);\
2306 }\
2307 void genie_put_##n (NODE_T * p) {\
2308 size_t size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\
2309 A68G_REF ref_file = * (A68G_REF *) STACK_OFFSET (- (size + sizf));\
2310 CHECK_REF (p, ref_file, M_REF_FILE);\
2311 reset_transput_buffer (UNFORMATTED_BUFFER);\
2312 open_for_writing (p, ref_file);\
2313 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
2314 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
2315 DECREMENT_STACK_POINTER (p, size + sizf);\
2316 }\
2317 void genie_read_##n (NODE_T * p) {\
2318 genie_read_##s (p);\
2319 genie_read_##s (p);\
2320 }\
2321 void genie_print_##n (NODE_T * p) {\
2322 size_t size = SIZE (MODE (m));\
2323 reset_transput_buffer (UNFORMATTED_BUFFER);\
2324 open_for_writing (p, A68G (stand_out));\
2325 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68G (stand_out));\
2326 write_purge_buffer (p, A68G (stand_out), UNFORMATTED_BUFFER);\
2327 DECREMENT_STACK_POINTER (p, size);\
2328 }
2329
2330 A68C_TRANSPUT (complex, real, COMPLEX);
2331 A68C_TRANSPUT (mp_complex, long_real, LONG_COMPLEX);
2332 A68C_TRANSPUT (long_mp_complex, long_mp_real, LONG_LONG_COMPLEX);
2333
2334 #undef A68C_TRANSPUT
2335
2336 //! @brief PROC STRING read line
2337
2338 void genie_read_line (NODE_T * p)
2339 {
2340 #if defined (HAVE_READLINE)
2341 char *line = readline ("");
2342 if (line != NO_TEXT && strlen (line) > 0) {
2343 add_history (line);
2344 }
2345 PUSH_REF (p, c_to_a_string (p, line, DEFAULT_WIDTH));
2346 a68g_free (line);
2347 #else
2348 genie_read_string (p);
2349 genie_stand_in (p);
2350 genie_new_line (p);
2351 #endif
2352 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
