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