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-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
8
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! 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, A68_REF ref_file)
36 {
37 A68_FILE *f = FILE_DEREF (&ref_file);
38 while ((*ch) != EOF_CHAR && IS_NL_FF (*ch)) {
39 A68_BOOL *z = (A68_BOOL *) STACK_TOP;
40 ADDR_T pop_sp = A68_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 A68_SP = pop_sp;
45 if (VALUE (z) == A68_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 A68_SP = pop_sp;
52 if (VALUE (z) == A68_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, A68_REF ref_file)
64 {
65 A68_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, A68_REF ref_file)
91 {
92 A68_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, A68_REF ref_file)
148 {
149 A68_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, A68_REF ref_file)
171 {
172 A68_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, A68_REF ref_file)
184 {
185 A68_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 = A68_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 = A68_FALSE;
199 } else if (IS_NL_FF (ch)) {
200 ADDR_T pop_sp = A68_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 A68_SP = pop_sp;
208 siga = A68_FALSE;
209 } else if (term != NO_TEXT && strchr (term, ch) != NO_TEXT) {
210 siga = A68_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 a68_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 int len = (int) strlen (letters);
230 BOOL_T good_file = A68_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/a68_", "./a68_", NO_TEXT };
234 for (int i = 0; prefix[i] != NO_TEXT; i++) {
235 for (int k = 0; k < TRIALS && good_file == A68_FALSE; k++) {
236 bufcpy (tfilename, prefix[i], BUFFER_SIZE);
237 for (int j = 0; j < TMP_SIZE; j++) {
238 int cindex;
239 do {
240 cindex = (int) (a68_unif_rand () * len);
241 } while (cindex < 0 || cindex >= len);
242 char chars[2];
243 chars[0] = letters[cindex];
244 chars[1] = NULL_CHAR;
245 bufcat (tfilename, chars, BUFFER_SIZE);
246 }
247 bufcat (tfilename, ".tmp", BUFFER_SIZE);
248 errno = 0;
249 FILE_T fd = open (tfilename, flags | O_EXCL, permissions);
250 good_file = (BOOL_T) (fd != A68_NO_FILE && errno == 0);
251 if (good_file) {
252 (void) close (fd);
253 }
254 }
255 }
256 if (good_file) {
257 bufcpy (fn, tfilename, BUFFER_SIZE);
258 return A68_TRUE;
259 } else {
260 return A68_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, A68_REF ref_file, int flags, mode_t permissions)
269 {
270 BOOL_T reading = (flags & ~O_BINARY) == A68_READ_ACCESS;
271 BOOL_T writing = (flags & ~O_BINARY) == A68_WRITE_ACCESS;
272 ABEND (reading == writing, ERROR_INTERNAL_CONSISTENCY, __func__);
273 CHECK_REF (p, ref_file, M_REF_FILE);
274 A68_FILE *file = FILE_DEREF (&ref_file);
275 CHECK_INIT (p, INITIALISED (file), M_FILE);
276 if (!IS_NIL (STRING (file))) {
277 if (writing) {
278 A68_REF z = *DEREF (A68_REF, &STRING (file));
279 A68_ARRAY *arr; A68_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) = A68_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 A68_NO_FILE;
293 } else {
294 BUFFER tfilename;
295 int len;
296 BUFCLR (tfilename);
297 if (!a68_mkstemp (tfilename, flags, permissions)) {
298 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NO_TEMP);
299 exit_genie (p, A68_RUNTIME_ERROR);
300 }
301 FD (file) = open (tfilename, flags, permissions);
302 len = 1 + (int) strlen (tfilename);
303 IDENTIFICATION (file) = heap_generator (p, M_C_STRING, len);
304 BLOCK_GC_HANDLE (&(IDENTIFICATION (file)));
305 bufcpy (DEREF (char, &IDENTIFICATION (file)), tfilename, len);
306 TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
307 reset_transput_buffer (TRANSPUT_BUFFER (file));
308 END_OF_FILE (file) = A68_FALSE;
309 TMP_FILE (file) = A68_TRUE;
310 FILE_ENTRY (file) = store_file_entry (p, FD (file), tfilename, TMP_FILE (file));
311 return FD (file);
312 }
313 } else {
314 // Opening an identified file.
315 A68_REF ref_filename = IDENTIFICATION (file);
316 CHECK_REF (p, ref_filename, M_ROWS);
317 char *filename = DEREF (char, &ref_filename);
318 if (OPEN_EXCLUSIVE (file)) {
319 // Establishing requires that the file does not exist.
320 if (flags == (A68_WRITE_ACCESS)) {
321 flags |= O_EXCL;
322 }
323 OPEN_EXCLUSIVE (file) = A68_FALSE;
324 }
325 FD (file) = open (filename, flags, permissions);
326 TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p);
327 reset_transput_buffer (TRANSPUT_BUFFER (file));
328 END_OF_FILE (file) = A68_FALSE;
329 FILE_ENTRY (file) = store_file_entry (p, FD (file), filename, TMP_FILE (file));
330 return FD (file);
331 }
332 }
333
334 //! @brief Call PROC (REF FILE) VOID during transput.
335
336 void genie_call_proc_ref_file_void (NODE_T * p, A68_REF ref_file, A68_PROCEDURE z)
337 {
338 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
339 MOID_T *u = M_PROC_REF_FILE_VOID;
340 PUSH_REF (p, ref_file);
341 genie_call_procedure (p, MOID (&z), u, u, &z, pop_sp, pop_fp);
342 A68_SP = pop_sp; // Voiding
343 }
344
345 // Unformatted transput.
346
347 //! @brief Hexadecimal value of digit.
348
349 int char_value (int ch)
350 {
351 switch (ch) {
352 case '0': {
353 return 0;
354 }
355 case '1': {
356 return 1;
357 }
358 case '2': {
359 return 2;
360 }
361 case '3': {
362 return 3;
363 }
364 case '4': {
365 return 4;
366 }
367 case '5': {
368 return 5;
369 }
370 case '6': {
371 return 6;
372 }
373 case '7': {
374 return 7;
375 }
376 case '8': {
377 return 8;
378 }
379 case '9': {
380 return 9;
381 }
382 case 'A':
383 case 'a': {
384 return 10;
385 }
386 case 'B':
387 case 'b': {
388 return 11;
389 }
390 case 'C':
391 case 'c': {
392 return 12;
393 }
394 case 'D':
395 case 'd': {
396 return 13;
397 }
398 case 'E':
399 case 'e': {
400 return 14;
401 }
402 case 'F':
403 case 'f': {
404 return 15;
405 }
406 default: {
407 return -1;
408 }
409 }
410 }
411
412 //! @brief INT value of BITS denotation
413
414 UNSIGNED_T bits_to_int (NODE_T * p, char *str)
415 {
416 errno = 0;
417 char *radix = NO_TEXT, *end = NO_TEXT;
418 int base = (int) a68_strtou (str, &radix, 10);
419 if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) {
420 UNSIGNED_T bits = 0;
421 if (base < 2 || base > 16) {
422 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base);
423 exit_genie (p, A68_RUNTIME_ERROR);
424 }
425 bits = a68_strtou (&(radix[1]), &end, base);
426 if (end != NO_TEXT && end[0] == NULL_CHAR && errno == 0) {
427 return bits;
428 }
429 }
430 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_BITS);
431 exit_genie (p, A68_RUNTIME_ERROR);
432 return 0;
433 }
434
435 //! @brief Convert string to required mode and store.
436
437 BOOL_T genie_string_to_value_internal (NODE_T * p, MOID_T * m, char *a, BYTE_T * item)
438 {
439 errno = 0;
440 // strto.. does not mind empty strings.
441 if (strlen (a) == 0) {
442 return A68_FALSE;
443 }
444 if (m == M_INT) {
445 A68_INT *z = (A68_INT *) item;
446 char *end;
447 VALUE (z) = (INT_T) a68_strtoi (a, &end, 10);
448 if (end[0] == NULL_CHAR && errno == 0) {
449 STATUS (z) = INIT_MASK;
450 return A68_TRUE;
451 } else {
452 return A68_FALSE;
453 }
454 }
455 if (m == M_REAL) {
456 A68_REAL *z = (A68_REAL *) item;
457 char *end;
458 VALUE (z) = strtod (a, &end);
459 if (end[0] == NULL_CHAR && errno == 0) {
460 STATUS (z) = INIT_MASK;
461 return A68_TRUE;
462 } else {
463 return A68_FALSE;
464 }
465 }
466 #if (A68_LEVEL >= 3)
467 if (m == M_LONG_INT) {
468 A68_LONG_INT *z = (A68_LONG_INT *) item;
469 if (string_to_double_int (p, z, a) == A68_FALSE) {
470 return A68_FALSE;
471 }
472 STATUS (z) = INIT_MASK;
473 return A68_TRUE;
474 }
475 if (m == M_LONG_REAL) {
476 A68_LONG_REAL *z = (A68_LONG_REAL *) item;
477 char *end;
478 // VALUE (z).f = strtoflt128 (a, &end);
479 VALUE (z).f = string_to_double (a, &end);
480 MATH_RTE (p, errno != 0, M_LONG_REAL, ERROR_MATH);
481 if (end[0] == NULL_CHAR && errno == 0) {
482 STATUS (z) = INIT_MASK;
483 return A68_TRUE;
484 } else {
485 return A68_FALSE;
486 }
487 }
488 if (m == M_LONG_BITS) {
489 A68_LONG_BITS *z = (A68_LONG_BITS *) item;
490 int ret = A68_TRUE;
491 DOUBLE_NUM_T b;
492 set_lw (b, 0x0);
493 if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
494 // [] BOOL denotation is "TTFFFFTFT ...".
495 if (strlen (a) > (size_t) A68_LONG_BITS_WIDTH) {
496 errno = ERANGE;
497 ret = A68_FALSE;
498 } else {
499 int n = 1;
500 UNSIGNED_T k = 0x1;
501 for (int j = (int) strlen (a) - 1; j >= 0; j--) {
502 if (a[j] == FLIP_CHAR) {
503 if (n <= A68_LONG_BITS_WIDTH / 2) {
504 LW (b) |= k;
505 } else {
506 HW (b) |= k;
507 }
508 } else if (a[j] != FLOP_CHAR) {
509 ret = A68_FALSE;
510 }
511 k <<= 1;
512 }
513 }
514 VALUE (z) = b;
515 } else {
516 // BITS denotation.
517 VALUE (z) = double_strtou (p, a);
518 }
519 return ret;
520 }
521 #else
522 if (m == M_LONG_BITS || m == M_LONG_LONG_BITS) {
523 int digits = DIGITS (m);
524 int status = A68_TRUE;
525 ADDR_T pop_sp = A68_SP;
526 MP_T *z = (MP_T *) item;
527 if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
528 // [] BOOL denotation is "TTFFFFTFT ...".
529 if (strlen (a) > (size_t) A68_BITS_WIDTH) {
530 errno = ERANGE;
531 status = A68_FALSE;
532 } else {
533 MP_T *w = lit_mp (p, 1, 0, digits);
534 SET_MP_ZERO (z, digits);
535 for (int j = (int) strlen (a) - 1; j >= 0; j--) {
536 if (a[j] == FLIP_CHAR) {
537 (void) add_mp (p, z, z, w, digits);
538 } else if (a[j] != FLOP_CHAR) {
539 status = A68_FALSE;
540 }
541 (void) mul_mp_digit (p, w, w, (MP_T) 2, digits);
542 }
543 }
544 } else {
545 // BITS denotation is also allowed.
546 mp_strtou (p, z, a, m);
547 }
548 A68_SP = pop_sp;
549 if (errno != 0 || status == A68_FALSE) {
550 return A68_FALSE;
551 }
552 MP_STATUS (z) = (MP_T) INIT_MASK;
553 return A68_TRUE;
554 }
555 #endif
556 if (m == M_LONG_INT || m == M_LONG_LONG_INT) {
557 int digits = DIGITS (m);
558 MP_T *z = (MP_T *) item;
559 if (strtomp (p, z, a, digits) == NaN_MP) {
560 return A68_FALSE;
561 }
562 if (!check_mp_int (z, m)) {
563 errno = ERANGE;
564 return A68_FALSE;
565 }
566 MP_STATUS (z) = (MP_T) INIT_MASK;
567 return A68_TRUE;
568 }
569 if (m == M_LONG_REAL || m == M_LONG_LONG_REAL) {
570 int digits = DIGITS (m);
571 MP_T *z = (MP_T *) item;
572 if (strtomp (p, z, a, digits) == NaN_MP) {
573 return A68_FALSE;
574 }
575 MP_STATUS (z) = (MP_T) INIT_MASK;
576 return A68_TRUE;
577 }
578 if (m == M_BOOL) {
579 A68_BOOL *z = (A68_BOOL *) item;
580 char q = a[0], flip = FLIP_CHAR, flop = FLOP_CHAR;
581 if (q == flip || q == flop) {
582 VALUE (z) = (BOOL_T) (q == flip);
583 STATUS (z) = INIT_MASK;
584 return A68_TRUE;
585 } else {
586 return A68_FALSE;
587 }
588 }
589 if (m == M_BITS) {
590 A68_BITS *z = (A68_BITS *) item;
591 int status = A68_TRUE;
592 if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) {
593 // [] BOOL denotation is "TTFFFFTFT ...".
594 if (strlen (a) > (size_t) A68_BITS_WIDTH) {
595 errno = ERANGE;
596 status = A68_FALSE;
597 } else {
598 UNSIGNED_T k = 0x1;
599 VALUE (z) = 0;
600 for (int j = (int) strlen (a) - 1; j >= 0; j--) {
601 if (a[j] == FLIP_CHAR) {
602 VALUE (z) += k;
603 } else if (a[j] != FLOP_CHAR) {
604 status = A68_FALSE;
605 }
606 k <<= 1;
607 }
608 }
609 } else {
610 // BITS denotation is also allowed.
611 VALUE (z) = bits_to_int (p, a);
612 }
613 if (errno != 0 || status == A68_FALSE) {
614 return A68_FALSE;
615 }
616 STATUS (z) = INIT_MASK;
617 return A68_TRUE;
618 }
619 return A68_FALSE;
620 }
621
622 //! @brief Convert string in input buffer to value of required mode.
623
624 void genie_string_to_value (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
625 {
626 char *str = get_transput_buffer (INPUT_BUFFER);
627 errno = 0;
628 // end string, just in case.
629 plusab_transput_buffer (p, INPUT_BUFFER, NULL_CHAR);
630 if (mode == M_INT) {
631 if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
632 value_error (p, mode, ref_file);
633 }
634 } else if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
635 if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
636 value_error (p, mode, ref_file);
637 }
638 } else if (mode == M_REAL) {
639 if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
640 value_error (p, mode, ref_file);
641 }
642 } else if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
643 if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
644 value_error (p, mode, ref_file);
645 }
646 } else if (mode == M_BOOL) {
647 if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
648 value_error (p, mode, ref_file);
649 }
650 } else if (mode == M_BITS) {
651 if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
652 value_error (p, mode, ref_file);
653 }
654 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
655 if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) {
656 value_error (p, mode, ref_file);
657 }
658 } else if (mode == M_CHAR) {
659 A68_CHAR *z = (A68_CHAR *) item;
660 if (str[0] == NULL_CHAR) {
661 // value_error (p, mode, ref_file);.
662 VALUE (z) = NULL_CHAR;
663 STATUS (z) = INIT_MASK;
664 } else {
665 int len = (int) strlen (str);
666 if (len == 0 || len > 1) {
667 value_error (p, mode, ref_file);
668 }
669 VALUE (z) = str[0];
670 STATUS (z) = INIT_MASK;
671 }
672 } else if (mode == M_STRING) {
673 A68_REF z;
674 z = c_to_a_string (p, str, get_transput_buffer_index (INPUT_BUFFER) - 1);
675 *(A68_REF *) item = z;
676 }
677 if (errno != 0) {
678 transput_error (p, ref_file, mode);
679 }
680 }
681
682 //! @brief Read object from file.
683
684 void genie_read_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
685 {
686 A68_FILE *f = FILE_DEREF (&ref_file);
687 errno = 0;
688 if (END_OF_FILE (f)) {
689 end_of_file_error (p, ref_file);
690 }
691 if (mode == M_PROC_REF_FILE_VOID) {
692 genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
693 } else if (mode == M_FORMAT) {
694 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
695 exit_genie (p, A68_RUNTIME_ERROR);
696 } else if (mode == M_REF_SOUND) {
697 read_sound (p, ref_file, DEREF (A68_SOUND, (A68_REF *) item));
698 } else if (IS_REF (mode)) {
699 CHECK_REF (p, *(A68_REF *) item, mode);
700 genie_read_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file);
701 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
702 scan_integer (p, ref_file);
703 genie_string_to_value (p, mode, item, ref_file);
704 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
705 scan_real (p, ref_file);
706 genie_string_to_value (p, mode, item, ref_file);
707 } else if (mode == M_BOOL) {
708 scan_char (p, ref_file);
709 genie_string_to_value (p, mode, item, ref_file);
710 } else if (mode == M_CHAR) {
711 scan_char (p, ref_file);
712 genie_string_to_value (p, mode, item, ref_file);
713 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
714 scan_bits (p, ref_file);
715 genie_string_to_value (p, mode, item, ref_file);
716 } else if (mode == M_STRING) {
717 char *term = DEREF (char, &TERMINATOR (f));
718 scan_string (p, term, ref_file);
719 genie_string_to_value (p, mode, item, ref_file);
720 } else if (IS_STRUCT (mode)) {
721 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
722 genie_read_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
723 }
724 } else if (IS_UNION (mode)) {
725 A68_UNION *z = (A68_UNION *) item;
726 if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
727 diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
728 exit_genie (p, A68_RUNTIME_ERROR);
729 }
730 genie_read_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
731 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
732 MOID_T *deflexed = DEFLEX (mode);
733 A68_ARRAY *arr;
734 A68_TUPLE *tup;
735 CHECK_INIT (p, INITIALISED ((A68_REF *) item), mode);
736 GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
737 if (get_row_size (tup, DIM (arr)) > 0) {
738 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
739 BOOL_T done = A68_FALSE;
740 initialise_internal_index (tup, DIM (arr));
741 while (!done) {
742 ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
743 ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
744 genie_read_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
745 done = increment_internal_index (tup, DIM (arr));
746 }
747 }
748 }
749 if (errno != 0) {
750 transput_error (p, ref_file, mode);
751 }
752 }
753
754 //! @brief PROC ([] SIMPLIN) VOID read
755
756 void genie_read (NODE_T * p)
757 {
758 A68_REF row;
759 POP_REF (p, &row);
760 genie_stand_in (p);
761 PUSH_REF (p, row);
762 genie_read_file (p);
763 }
764
765 //! @brief Open for reading.
766
767 void open_for_reading (NODE_T * p, A68_REF ref_file)
768 {
769 A68_FILE *file = FILE_DEREF (&ref_file);
770 if (!OPENED (file)) {
771 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
772 exit_genie (p, A68_RUNTIME_ERROR);
773 }
774 if (DRAW_MOOD (file)) {
775 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
776 exit_genie (p, A68_RUNTIME_ERROR);
777 }
778 if (WRITE_MOOD (file)) {
779 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
780 exit_genie (p, A68_RUNTIME_ERROR);
781 }
782 if (!GET (&CHANNEL (file))) {
783 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
784 exit_genie (p, A68_RUNTIME_ERROR);
785 }
786 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
787 if (IS_NIL (STRING (file))) {
788 if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILE) {
789 open_error (p, ref_file, "getting");
790 }
791 } else {
792 FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0);
793 }
794 DRAW_MOOD (file) = A68_FALSE;
795 READ_MOOD (file) = A68_TRUE;
796 WRITE_MOOD (file) = A68_FALSE;
797 CHAR_MOOD (file) = A68_TRUE;
798 }
799 if (!CHAR_MOOD (file)) {
800 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
801 exit_genie (p, A68_RUNTIME_ERROR);
802 }
803 }
804
805 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get
806
807 void genie_read_file (NODE_T * p)
808 {
809 A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup;
810 POP_REF (p, &row);
811 CHECK_REF (p, row, M_ROW_SIMPLIN);
812 GET_DESCRIPTOR (arr, tup, &row);
813 int elems = ROW_SIZE (tup);
814 A68_REF ref_file;
815 POP_REF (p, &ref_file);
816 CHECK_REF (p, ref_file, M_REF_FILE);
817 A68_FILE *file = FILE_DEREF (&ref_file);
818 CHECK_INIT (p, INITIALISED (file), M_FILE);
819 open_for_reading (p, ref_file);
820 // Read.
821 if (elems <= 0) {
822 return;
823 }
824 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
825 int elem_index = 0;
826 for (int k = 0; k < elems; k++) {
827 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
828 MOID_T *mode = (MOID_T *) (VALUE (z));
829 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
830 genie_read_standard (p, mode, item, ref_file);
831 elem_index += SIZE (M_SIMPLIN);
832 }
833 }
834
835 //! @brief Convert value to string.
836
837 void genie_value_to_string (NODE_T * p, MOID_T * moid, BYTE_T * item, int mod)
838 {
839 if (moid == M_INT) {
840 A68_INT *z = (A68_INT *) item;
841 PUSH_UNION (p, M_INT);
842 PUSH_VALUE (p, VALUE (z), A68_INT);
843 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT)));
844 if (mod == FORMAT_ITEM_G) {
845 PUSH_VALUE (p, A68_INT_WIDTH + 1, A68_INT);
846 genie_whole (p);
847 } else if (mod == FORMAT_ITEM_H) {
848 PUSH_VALUE (p, A68_REAL_WIDTH + A68_EXP_WIDTH + 4, A68_INT);
849 PUSH_VALUE (p, A68_REAL_WIDTH - 1, A68_INT);
850 PUSH_VALUE (p, A68_EXP_WIDTH + 1, A68_INT);
851 PUSH_VALUE (p, 3, A68_INT);
852 genie_real (p);
853 }
854 return;
855 }
856 #if (A68_LEVEL >= 3)
857 if (moid == M_LONG_INT) {
858 A68_LONG_INT *z = (A68_LONG_INT *) item;
859 PUSH_UNION (p, M_LONG_INT);
860 PUSH (p, z, SIZE (M_LONG_INT));
861 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_INT)));
862 if (mod == FORMAT_ITEM_G) {
863 PUSH_VALUE (p, A68_LONG_WIDTH + 1, A68_INT);
864 genie_whole (p);
865 } else if (mod == FORMAT_ITEM_H) {
866 PUSH_VALUE (p, A68_LONG_REAL_WIDTH + A68_LONG_EXP_WIDTH + 4, A68_INT);
867 PUSH_VALUE (p, A68_LONG_REAL_WIDTH - 1, A68_INT);
868 PUSH_VALUE (p, A68_LONG_EXP_WIDTH + 1, A68_INT);
869 PUSH_VALUE (p, 3, A68_INT);
870 genie_real (p);
871 }
872 return;
873 }
874 if (moid == M_LONG_REAL) {
875 A68_LONG_REAL *z = (A68_LONG_REAL *) item;
876 PUSH_UNION (p, M_LONG_REAL);
877 PUSH_VALUE (p, VALUE (z), A68_LONG_REAL);
878 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL)));
879 PUSH_VALUE (p, A68_LONG_REAL_WIDTH + A68_LONG_EXP_WIDTH + 4, A68_INT);
880 PUSH_VALUE (p, A68_LONG_REAL_WIDTH - 1, A68_INT);
881 PUSH_VALUE (p, A68_LONG_EXP_WIDTH + 1, A68_INT);
882 if (mod == FORMAT_ITEM_G) {
883 genie_float (p);
884 } else if (mod == FORMAT_ITEM_H) {
885 PUSH_VALUE (p, 3, A68_INT);
886 genie_real (p);
887 }
888 return;
889 }
890 if (moid == M_LONG_BITS) {
891 A68_LONG_BITS *z = (A68_LONG_BITS *) item;
892 char *s = stack_string (p, 8 + A68_LONG_BITS_WIDTH);
893 int n = 0;
894 for (int w = 0; w <= 1; w++) {
895 UNSIGNED_T bit = D_SIGN;
896 for (int j = 0; j < A68_BITS_WIDTH; j++) {
897 if (w == 0) {
898 s[n] = (char) ((HW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR);
899 } else {
900 s[n] = (char) ((LW (VALUE (z)) & bit) ? FLIP_CHAR : FLOP_CHAR);
901 }
902 bit >>= 1;
903 n++;
904 }
905 }
906 s[n] = NULL_CHAR;
907 return;
908 }
909 #else
910 if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) {
911 int bits = get_mp_bits_width (moid), word = get_mp_bits_words (moid);
912 int pos = bits;
913 char *str = stack_string (p, 8 + bits);
914 ADDR_T pop_sp = A68_SP;
915 unt *row = stack_mp_bits (p, (MP_T *) item, moid);
916 str[pos--] = NULL_CHAR;
917 while (pos >= 0) {
918 unt bit = 0x1;
919 for (int j = 0; j < MP_BITS_BITS && pos >= 0; j++) {
920 str[pos--] = (char) ((row[word - 1] & bit) ? FLIP_CHAR : FLOP_CHAR);
921 bit <<= 1;
922 }
923 word--;
924 }
925 A68_SP = pop_sp;
926 return;
927 }
928 #endif
929 if (moid == M_LONG_INT) {
930 MP_T *z = (MP_T *) item;
931 PUSH_UNION (p, M_LONG_INT);
932 PUSH (p, z, SIZE (M_LONG_INT));
933 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_INT)));
934 if (mod == FORMAT_ITEM_G) {
935 PUSH_VALUE (p, A68_LONG_WIDTH + 1, A68_INT);
936 genie_whole (p);
937 } else if (mod == FORMAT_ITEM_H) {
938 PUSH_VALUE (p, A68_LONG_REAL_WIDTH + A68_LONG_EXP_WIDTH + 4, A68_INT);
939 PUSH_VALUE (p, A68_LONG_REAL_WIDTH - 1, A68_INT);
940 PUSH_VALUE (p, A68_LONG_EXP_WIDTH + 1, A68_INT);
941 PUSH_VALUE (p, 3, A68_INT);
942 genie_real (p);
943 }
944 return;
945 }
946 if (moid == M_LONG_LONG_INT) {
947 MP_T *z = (MP_T *) item;
948 PUSH_UNION (p, M_LONG_LONG_INT);
949 PUSH (p, z, SIZE (M_LONG_LONG_INT));
950 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_LONG_INT)));
951 if (mod == FORMAT_ITEM_G) {
952 PUSH_VALUE (p, A68_LONG_LONG_WIDTH + 1, A68_INT);
953 genie_whole (p);
954 } else if (mod == FORMAT_ITEM_H) {
955 PUSH_VALUE (p, A68_LONG_LONG_REAL_WIDTH + A68_LONG_LONG_EXP_WIDTH + 4, A68_INT);
956 PUSH_VALUE (p, A68_LONG_LONG_REAL_WIDTH - 1, A68_INT);
957 PUSH_VALUE (p, A68_LONG_LONG_EXP_WIDTH + 1, A68_INT);
958 PUSH_VALUE (p, 3, A68_INT);
959 genie_real (p);
960 }
961 return;
962 }
963 if (moid == M_REAL) {
964 A68_REAL *z = (A68_REAL *) item;
965 PUSH_UNION (p, M_REAL);
966 PUSH_VALUE (p, VALUE (z), A68_REAL);
967 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
968 PUSH_VALUE (p, A68_REAL_WIDTH + A68_EXP_WIDTH + 4, A68_INT);
969 PUSH_VALUE (p, A68_REAL_WIDTH - 1, A68_INT);
970 PUSH_VALUE (p, A68_EXP_WIDTH + 1, A68_INT);
971 if (mod == FORMAT_ITEM_G) {
972 genie_float (p);
973 } else if (mod == FORMAT_ITEM_H) {
974 PUSH_VALUE (p, 3, A68_INT);
975 genie_real (p);
976 }
977 return;
978 }
979 if (moid == M_LONG_REAL) {
980 MP_T *z = (MP_T *) item;
981 PUSH_UNION (p, M_LONG_REAL);
982 PUSH (p, z, (int) SIZE (M_LONG_REAL));
983 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL)));
984 PUSH_VALUE (p, A68_LONG_REAL_WIDTH + A68_LONG_EXP_WIDTH + 4, A68_INT);
985 PUSH_VALUE (p, A68_LONG_REAL_WIDTH - 1, A68_INT);
986 PUSH_VALUE (p, A68_LONG_EXP_WIDTH + 1, A68_INT);
987 if (mod == FORMAT_ITEM_G) {
988 genie_float (p);
989 } else if (mod == FORMAT_ITEM_H) {
990 PUSH_VALUE (p, 3, A68_INT);
991 genie_real (p);
992 }
993 return;
994 }
995 if (moid == M_LONG_LONG_REAL) {
996 MP_T *z = (MP_T *) item;
997 PUSH_UNION (p, M_LONG_LONG_REAL);
998 PUSH (p, z, (int) SIZE (M_LONG_LONG_REAL));
999 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_LONG_REAL)));
1000 PUSH_VALUE (p, A68_LONG_LONG_REAL_WIDTH + A68_LONG_LONG_EXP_WIDTH + 4, A68_INT);
1001 PUSH_VALUE (p, A68_LONG_LONG_REAL_WIDTH - 1, A68_INT);
1002 PUSH_VALUE (p, A68_LONG_LONG_EXP_WIDTH + 1, A68_INT);
1003 if (mod == FORMAT_ITEM_G) {
1004 genie_float (p);
1005 } else if (mod == FORMAT_ITEM_H) {
1006 PUSH_VALUE (p, 3, A68_INT);
1007 genie_real (p);
1008 }
1009 return;
1010 }
1011 if (moid == M_BITS) {
1012 A68_BITS *z = (A68_BITS *) item;
1013 char *str = stack_string (p, 8 + A68_BITS_WIDTH);
1014 UNSIGNED_T bit = 0x1;
1015 int j;
1016 for (j = 1; j < A68_BITS_WIDTH; j++) {
1017 bit <<= 1;
1018 }
1019 for (j = 0; j < A68_BITS_WIDTH; j++) {
1020 str[j] = (char) ((VALUE (z) & bit) ? FLIP_CHAR : FLOP_CHAR);
1021 bit >>= 1;
1022 }
1023 str[j] = NULL_CHAR;
1024 return;
1025 }
1026 }
1027
1028 //! @brief Print object to file.
1029
1030 void genie_write_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
1031 {
1032 errno = 0;
1033 ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1034 if (mode == M_PROC_REF_FILE_VOID) {
1035 genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
1036 } else if (mode == M_FORMAT) {
1037 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1038 exit_genie (p, A68_RUNTIME_ERROR);
1039 } else if (mode == M_SOUND) {
1040 write_sound (p, ref_file, (A68_SOUND *) item);
1041 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
1042 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1043 add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
1044 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
1045 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1046 add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER);
1047 } else if (mode == M_BOOL) {
1048 A68_BOOL *z = (A68_BOOL *) item;
1049 char flipflop = (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR);
1050 plusab_transput_buffer (p, UNFORMATTED_BUFFER, flipflop);
1051 } else if (mode == M_CHAR) {
1052 A68_CHAR *ch = (A68_CHAR *) item;
1053 plusab_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (ch));
1054 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
1055 char *str = (char *) STACK_TOP;
1056 genie_value_to_string (p, mode, item, FORMAT_ITEM_G);
1057 add_string_transput_buffer (p, UNFORMATTED_BUFFER, str);
1058 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1059 // Handle these separately since this is faster than straightening.
1060 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
1061 } else if (IS_UNION (mode)) {
1062 A68_UNION *z = (A68_UNION *) item;
1063 genie_write_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
1064 } else if (IS_STRUCT (mode)) {
1065 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1066 BYTE_T *elem = &item[OFFSET (q)];
1067 genie_check_initialisation (p, elem, MOID (q));
1068 genie_write_standard (p, MOID (q), elem, ref_file);
1069 }
1070 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1071 MOID_T *deflexed = DEFLEX (mode);
1072 A68_ARRAY *arr;
1073 A68_TUPLE *tup;
1074 CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
1075 GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1076 if (get_row_size (tup, DIM (arr)) > 0) {
1077 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1078 BOOL_T done = A68_FALSE;
1079 initialise_internal_index (tup, DIM (arr));
1080 while (!done) {
1081 ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
1082 ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
1083 BYTE_T *elem = &base_addr[elem_addr];
1084 genie_check_initialisation (p, elem, SUB (deflexed));
1085 genie_write_standard (p, SUB (deflexed), elem, ref_file);
1086 done = increment_internal_index (tup, DIM (arr));
1087 }
1088 }
1089 }
1090 if (errno != 0) {
1091 ABEND (IS_NIL (ref_file), ERROR_ACTION, error_specification ());
1092 transput_error (p, ref_file, mode);
1093 }
1094 }
1095
1096 //! @brief PROC ([] SIMPLOUT) VOID print, write
1097
1098 void genie_write (NODE_T * p)
1099 {
1100 A68_REF row;
1101 POP_REF (p, &row);
1102 genie_stand_out (p);
1103 PUSH_REF (p, row);
1104 genie_write_file (p);
1105 }
1106
1107 //! @brief Open for writing.
1108
1109 void open_for_writing (NODE_T * p, A68_REF ref_file)
1110 {
1111 A68_FILE *file = FILE_DEREF (&ref_file);
1112 if (!OPENED (file)) {
1113 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1114 exit_genie (p, A68_RUNTIME_ERROR);
1115 }
1116 if (DRAW_MOOD (file)) {
1117 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1118 exit_genie (p, A68_RUNTIME_ERROR);
1119 }
1120 if (READ_MOOD (file)) {
1121 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1122 exit_genie (p, A68_RUNTIME_ERROR);
1123 }
1124 if (!PUT (&CHANNEL (file))) {
1125 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1126 exit_genie (p, A68_RUNTIME_ERROR);
1127 }
1128 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1129 if (IS_NIL (STRING (file))) {
1130 if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILE) {
1131 open_error (p, ref_file, "putting");
1132 }
1133 } else {
1134 FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, 0);
1135 }
1136 DRAW_MOOD (file) = A68_FALSE;
1137 READ_MOOD (file) = A68_FALSE;
1138 WRITE_MOOD (file) = A68_TRUE;
1139 CHAR_MOOD (file) = A68_TRUE;
1140 }
1141 if (!CHAR_MOOD (file)) {
1142 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
1143 exit_genie (p, A68_RUNTIME_ERROR);
1144 }
1145 }
1146
1147 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put
1148
1149 void genie_write_file (NODE_T * p)
1150 {
1151 A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup;
1152 POP_REF (p, &row);
1153 CHECK_REF (p, row, M_ROW_SIMPLOUT);
1154 GET_DESCRIPTOR (arr, tup, &row);
1155 int elems = ROW_SIZE (tup);
1156 A68_REF ref_file;
1157 POP_REF (p, &ref_file);
1158 CHECK_REF (p, ref_file, M_REF_FILE);
1159 A68_FILE *file = FILE_DEREF (&ref_file);
1160 CHECK_INIT (p, INITIALISED (file), M_FILE);
1161 open_for_writing (p, ref_file);
1162 // Write.
1163 if (elems <= 0) {
1164 return;
1165 }
1166 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1167 int elem_index = 0;
1168 for (int k = 0; k < elems; k++) {
1169 A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
1170 MOID_T *mode = (MOID_T *) (VALUE (z));
1171 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
1172 reset_transput_buffer (UNFORMATTED_BUFFER);
1173 genie_write_standard (p, mode, item, ref_file);
1174 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);
1175 elem_index += SIZE (M_SIMPLOUT);
1176 }
1177 }
1178
1179 //! @brief Read object binary from file.
1180
1181 void genie_read_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
1182 {
1183 CHECK_REF (p, ref_file, M_REF_FILE);
1184 A68_FILE *f = FILE_DEREF (&ref_file);
1185 errno = 0;
1186 if (END_OF_FILE (f)) {
1187 end_of_file_error (p, ref_file);
1188 }
1189 if (mode == M_PROC_REF_FILE_VOID) {
1190 genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
1191 } else if (mode == M_FORMAT) {
1192 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1193 exit_genie (p, A68_RUNTIME_ERROR);
1194 } else if (mode == M_REF_SOUND) {
1195 read_sound (p, ref_file, (A68_SOUND *) ADDRESS ((A68_REF *) item));
1196 } else if (IS_REF (mode)) {
1197 CHECK_REF (p, *(A68_REF *) item, mode);
1198 genie_read_bin_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file);
1199 } else if (mode == M_INT) {
1200 A68_INT *z = (A68_INT *) item;
1201 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1202 STATUS (z) = INIT_MASK;
1203 } else if (mode == M_LONG_INT) {
1204 #if (A68_LEVEL >= 3)
1205 A68_LONG_INT *z = (A68_LONG_INT *) item;
1206 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1207 STATUS (z) = INIT_MASK;
1208 #else
1209 MP_T *z = (MP_T *) item;
1210 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1211 MP_STATUS (z) = (MP_T) INIT_MASK;
1212 #endif
1213 } else if (mode == M_LONG_LONG_INT) {
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 } else if (mode == M_REAL) {
1218 A68_REAL *z = (A68_REAL *) item;
1219 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1220 STATUS (z) = INIT_MASK;
1221 } else if (mode == M_LONG_REAL) {
1222 #if (A68_LEVEL >= 3)
1223 A68_LONG_REAL *z = (A68_LONG_REAL *) item;
1224 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1225 STATUS (z) = INIT_MASK;
1226 #else
1227 MP_T *z = (MP_T *) item;
1228 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1229 MP_STATUS (z) = (MP_T) INIT_MASK;
1230 #endif
1231 } else if (mode == M_LONG_LONG_REAL) {
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 } else if (mode == M_BOOL) {
1236 A68_BOOL *z = (A68_BOOL *) item;
1237 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1238 STATUS (z) = INIT_MASK;
1239 } else if (mode == M_CHAR) {
1240 A68_CHAR *z = (A68_CHAR *) item;
1241 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1242 STATUS (z) = INIT_MASK;
1243 } else if (mode == M_BITS) {
1244 A68_BITS *z = (A68_BITS *) item;
1245 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1246 STATUS (z) = INIT_MASK;
1247 } else if (mode == M_LONG_BITS) {
1248 #if (A68_LEVEL >= 3)
1249 A68_LONG_BITS *z = (A68_LONG_BITS *) item;
1250 ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1);
1251 STATUS (z) = INIT_MASK;
1252 #else
1253 MP_T *z = (MP_T *) item;
1254 ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1);
1255 MP_STATUS (z) = (MP_T) INIT_MASK;
1256 #endif
1257 } else if (mode == M_LONG_LONG_BITS) {
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 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1262 int len;
1263 ASSERT (io_read (FD (f), &(len), sizeof (len)) != -1);
1264 reset_transput_buffer (UNFORMATTED_BUFFER);
1265 for (int k = 0; k < len; k++) {
1266 char ch;
1267 ASSERT (io_read (FD (f), &(ch), sizeof (char)) != -1);
1268 plusab_transput_buffer (p, UNFORMATTED_BUFFER, ch);
1269 }
1270 *(A68_REF *) item = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH);
1271 } else if (IS_UNION (mode)) {
1272 A68_UNION *z = (A68_UNION *) item;
1273 if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) {
1274 diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
1275 exit_genie (p, A68_RUNTIME_ERROR);
1276 }
1277 genie_read_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
1278 } else if (IS_STRUCT (mode)) {
1279 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1280 genie_read_bin_standard (p, MOID (q), &item[OFFSET (q)], ref_file);
1281 }
1282 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1283 MOID_T *deflexed = DEFLEX (mode);
1284 A68_ARRAY *arr; A68_TUPLE *tup;
1285 CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
1286 GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1287 if (get_row_size (tup, DIM (arr)) > 0) {
1288 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1289 BOOL_T done = A68_FALSE;
1290 initialise_internal_index (tup, DIM (arr));
1291 while (!done) {
1292 ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
1293 ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
1294 genie_read_bin_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file);
1295 done = increment_internal_index (tup, DIM (arr));
1296 }
1297 }
1298 }
1299 if (errno != 0) {
1300 transput_error (p, ref_file, mode);
1301 }
1302 }
1303
1304 //! @brief PROC ([] SIMPLIN) VOID read bin
1305
1306 void genie_read_bin (NODE_T * p)
1307 {
1308 A68_REF row;
1309 POP_REF (p, &row);
1310 genie_stand_back (p);
1311 PUSH_REF (p, row);
1312 genie_read_bin_file (p);
1313 }
1314
1315 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get bin
1316
1317 void genie_read_bin_file (NODE_T * p)
1318 {
1319 A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup;
1320 POP_REF (p, &row);
1321 CHECK_REF (p, row, M_ROW_SIMPLIN);
1322 GET_DESCRIPTOR (arr, tup, &row);
1323 int elems = ROW_SIZE (tup);
1324 A68_REF ref_file;
1325 POP_REF (p, &ref_file);
1326 ref_file = *(A68_REF *) STACK_TOP;
1327 CHECK_REF (p, ref_file, M_REF_FILE);
1328 A68_FILE *file = FILE_DEREF (&ref_file);
1329 CHECK_INIT (p, INITIALISED (file), M_FILE);
1330 if (!OPENED (file)) {
1331 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1332 exit_genie (p, A68_RUNTIME_ERROR);
1333 }
1334 if (DRAW_MOOD (file)) {
1335 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1336 exit_genie (p, A68_RUNTIME_ERROR);
1337 }
1338 if (WRITE_MOOD (file)) {
1339 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
1340 exit_genie (p, A68_RUNTIME_ERROR);
1341 }
1342 if (!GET (&CHANNEL (file))) {
1343 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
1344 exit_genie (p, A68_RUNTIME_ERROR);
1345 }
1346 if (!BIN (&CHANNEL (file))) {
1347 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary getting");
1348 exit_genie (p, A68_RUNTIME_ERROR);
1349 }
1350 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1351 if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS | O_BINARY, 0)) == A68_NO_FILE) {
1352 open_error (p, ref_file, "binary getting");
1353 }
1354 DRAW_MOOD (file) = A68_FALSE;
1355 READ_MOOD (file) = A68_TRUE;
1356 WRITE_MOOD (file) = A68_FALSE;
1357 CHAR_MOOD (file) = A68_FALSE;
1358 }
1359 if (CHAR_MOOD (file)) {
1360 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
1361 exit_genie (p, A68_RUNTIME_ERROR);
1362 }
1363 // Read.
1364 if (elems <= 0) {
1365 return;
1366 }
1367 int elem_index = 0;
1368 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1369 for (int k = 0; k < elems; k++) {
1370 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
1371 MOID_T *mode = (MOID_T *) (VALUE (z));
1372 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
1373 genie_read_bin_standard (p, mode, item, ref_file);
1374 elem_index += SIZE (M_SIMPLIN);
1375 }
1376 }
1377
1378 //! @brief Write object binary to file.
1379
1380 void genie_write_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
1381 {
1382 CHECK_REF (p, ref_file, M_REF_FILE);
1383 A68_FILE *f = FILE_DEREF (&ref_file);
1384 errno = 0;
1385 if (mode == M_PROC_REF_FILE_VOID) {
1386 genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item);
1387 } else if (mode == M_FORMAT) {
1388 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_FORMAT);
1389 exit_genie (p, A68_RUNTIME_ERROR);
1390 } else if (mode == M_SOUND) {
1391 write_sound (p, ref_file, (A68_SOUND *) item);
1392 } else if (mode == M_INT) {
1393 ASSERT (io_write (FD (f), &(VALUE ((A68_INT *) item)), sizeof (VALUE ((A68_INT *) item))) != -1);
1394 } else if (mode == M_LONG_INT) {
1395 #if (A68_LEVEL >= 3)
1396 ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_INT *) item)), sizeof (VALUE ((A68_LONG_INT *) item))) != -1);
1397 #else
1398 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1399 #endif
1400 } else if (mode == M_LONG_LONG_INT) {
1401 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1402 } else if (mode == M_REAL) {
1403 ASSERT (io_write (FD (f), &(VALUE ((A68_REAL *) item)), sizeof (VALUE ((A68_REAL *) item))) != -1);
1404 } else if (mode == M_LONG_REAL) {
1405 #if (A68_LEVEL >= 3)
1406 ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_REAL *) item)), sizeof (VALUE ((A68_LONG_REAL *) item))) != -1);
1407 #else
1408 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1409 #endif
1410 } else if (mode == M_LONG_LONG_REAL) {
1411 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1412 } else if (mode == M_BOOL) {
1413 ASSERT (io_write (FD (f), &(VALUE ((A68_BOOL *) item)), sizeof (VALUE ((A68_BOOL *) item))) != -1);
1414 } else if (mode == M_CHAR) {
1415 ASSERT (io_write (FD (f), &(VALUE ((A68_CHAR *) item)), sizeof (VALUE ((A68_CHAR *) item))) != -1);
1416 } else if (mode == M_BITS) {
1417 ASSERT (io_write (FD (f), &(VALUE ((A68_BITS *) item)), sizeof (VALUE ((A68_BITS *) item))) != -1);
1418 } else if (mode == M_LONG_BITS) {
1419 #if (A68_LEVEL >= 3)
1420 ASSERT (io_write (FD (f), &(VALUE ((A68_LONG_BITS *) item)), sizeof (VALUE ((A68_LONG_BITS *) 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_BITS) {
1425 ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1);
1426 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1427 reset_transput_buffer (UNFORMATTED_BUFFER);
1428 add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item);
1429 int len = get_transput_buffer_index (UNFORMATTED_BUFFER);
1430 ASSERT (io_write (FD (f), &(len), sizeof (len)) != -1);
1431 WRITE (FD (f), get_transput_buffer (UNFORMATTED_BUFFER));
1432 } else if (IS_UNION (mode)) {
1433 A68_UNION *z = (A68_UNION *) item;
1434 genie_write_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file);
1435 } else if (IS_STRUCT (mode)) {
1436 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1437 BYTE_T *elem = &item[OFFSET (q)];
1438 genie_check_initialisation (p, elem, MOID (q));
1439 genie_write_bin_standard (p, MOID (q), elem, ref_file);
1440 }
1441 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1442 MOID_T *deflexed = DEFLEX (mode);
1443 A68_ARRAY *arr; A68_TUPLE *tup;
1444 CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
1445 GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1446 if (get_row_size (tup, DIM (arr)) > 0) {
1447 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1448 BOOL_T done = A68_FALSE;
1449 initialise_internal_index (tup, DIM (arr));
1450 while (!done) {
1451 ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
1452 ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
1453 BYTE_T *elem = &base_addr[elem_addr];
1454 genie_check_initialisation (p, elem, SUB (deflexed));
1455 genie_write_bin_standard (p, SUB (deflexed), elem, ref_file);
1456 done = increment_internal_index (tup, DIM (arr));
1457 }
1458 }
1459 }
1460 if (errno != 0) {
1461 transput_error (p, ref_file, mode);
1462 }
1463 }
1464
1465 //! @brief PROC ([] SIMPLOUT) VOID write bin, print bin
1466
1467 void genie_write_bin (NODE_T * p)
1468 {
1469 A68_REF row;
1470 POP_REF (p, &row);
1471 genie_stand_back (p);
1472 PUSH_REF (p, row);
1473 genie_write_bin_file (p);
1474 }
1475
1476 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put bin
1477
1478 void genie_write_bin_file (NODE_T * p)
1479 {
1480 A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup;
1481 POP_REF (p, &row);
1482 CHECK_REF (p, row, M_ROW_SIMPLOUT);
1483 GET_DESCRIPTOR (arr, tup, &row);
1484 int elems = ROW_SIZE (tup);
1485 A68_REF ref_file;
1486 POP_REF (p, &ref_file);
1487 ref_file = *(A68_REF *) STACK_TOP;
1488 CHECK_REF (p, ref_file, M_REF_FILE);
1489 A68_FILE *file = FILE_DEREF (&ref_file);
1490 CHECK_INIT (p, INITIALISED (file), M_FILE);
1491 if (!OPENED (file)) {
1492 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1493 exit_genie (p, A68_RUNTIME_ERROR);
1494 }
1495 if (DRAW_MOOD (file)) {
1496 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1497 exit_genie (p, A68_RUNTIME_ERROR);
1498 }
1499 if (READ_MOOD (file)) {
1500 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1501 exit_genie (p, A68_RUNTIME_ERROR);
1502 }
1503 if (!PUT (&CHANNEL (file))) {
1504 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1505 exit_genie (p, A68_RUNTIME_ERROR);
1506 }
1507 if (!BIN (&CHANNEL (file))) {
1508 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary putting");
1509 exit_genie (p, A68_RUNTIME_ERROR);
1510 }
1511 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1512 if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS | O_BINARY, A68_PROTECTION)) == A68_NO_FILE) {
1513 open_error (p, ref_file, "binary putting");
1514 }
1515 DRAW_MOOD (file) = A68_FALSE;
1516 READ_MOOD (file) = A68_FALSE;
1517 WRITE_MOOD (file) = A68_TRUE;
1518 CHAR_MOOD (file) = A68_FALSE;
1519 }
1520 if (CHAR_MOOD (file)) {
1521 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text");
1522 exit_genie (p, A68_RUNTIME_ERROR);
1523 }
1524 if (elems <= 0) {
1525 return;
1526 }
1527 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1528 int elem_index = 0;
1529 for (int k = 0; k < elems; k++) {
1530 A68_UNION *z = (A68_UNION *) & base_address[elem_index];
1531 MOID_T *mode = (MOID_T *) (VALUE (z));
1532 BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE];
1533 genie_write_bin_standard (p, mode, item, ref_file);
1534 elem_index += SIZE (M_SIMPLOUT);
1535 }
1536 }
1537
1538 // Next are formatting routines "whole", "fixed" and "float" for mode
1539 // INT, LONG INT and LONG LONG INT, and REAL, LONG REAL and LONG LONG REAL.
1540 // They are direct implementations of the routines described in the
1541 // Revised Report, although those were only meant as a specification.
1542 // The rest of Algol68G should only reference "genie_whole", "genie_fixed"
1543 // or "genie_float" since internal routines like "sub_fixed" may leave the
1544 // stack corrupted when called directly.
1545
1546 //! @brief Generate a string of error chars.
1547
1548 char *error_chars (char *s, int n)
1549 {
1550 int k = (n != 0 ? ABS (n) : 1);
1551 s[k] = NULL_CHAR;
1552 while (--k >= 0) {
1553 s[k] = ERROR_CHAR;
1554 }
1555 return s;
1556 }
1557
1558 //! @brief Convert temporary C string to A68 string.
1559
1560 A68_REF tmp_to_a68_string (NODE_T * p, char *temp_string)
1561 {
1562 // no compaction allowed since temp_string might be up for garbage collecting ...
1563 return c_to_a_string (p, temp_string, DEFAULT_WIDTH);
1564 }
1565
1566 //! @brief Add c to str, assuming that "str" is large enough.
1567
1568 char *plusto (char c, char *str)
1569 {
1570 MOVE (&str[1], &str[0], (unt) (strlen (str) + 1));
1571 str[0] = c;
1572 return str;
1573 }
1574
1575 //! @brief Add c to str, assuming that "str" is large enough.
1576
1577 char *string_plusab_char (char *str, char c, int strwid)
1578 {
1579 char z[2];
1580 z[0] = c;
1581 z[1] = NULL_CHAR;
1582 bufcat (str, z, strwid);
1583 return str;
1584 }
1585
1586 //! @brief Add leading spaces to str until length is width.
1587
1588 char *leading_spaces (char *str, int width)
1589 {
1590 int j = width - (int) strlen (str);
1591 while (--j >= 0) {
1592 (void) plusto (BLANK_CHAR, str);
1593 }
1594 return str;
1595 }
1596
1597 //! @brief Convert int to char using a table.
1598
1599 char digchar (int k)
1600 {
1601 char *s = "0123456789abcdefghijklmnopqrstuvwxyz";
1602 if (k >= 0 && k < (int) strlen (s)) {
1603 return s[k];
1604 } else {
1605 return ERROR_CHAR;
1606 }
1607 }
1608
1609 //! @brief Formatted string for HEX_NUMBER.
1610
1611 char *bits (NODE_T * p)
1612 {
1613 A68_INT width, base;
1614 POP_OBJECT (p, &base, A68_INT);
1615 POP_OBJECT (p, &width, A68_INT);
1616 DECREMENT_STACK_POINTER (p, SIZE (M_HEX_NUMBER));
1617 CHECK_INT_SHORTEN (p, VALUE (&base));
1618 CHECK_INT_SHORTEN (p, VALUE (&width));
1619 MOID_T *mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
1620 int length = ABS (VALUE (&width)), radix = ABS (VALUE (&base));
1621 if (radix < 2 || radix > 16) {
1622 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1623 exit_genie (p, A68_RUNTIME_ERROR);
1624 }
1625 reset_transput_buffer (EDIT_BUFFER);
1626 #if (A68_LEVEL <= 2)
1627 (void) mode;
1628 (void) length;
1629 (void) error_chars (get_transput_buffer (EDIT_BUFFER), VALUE (&width));
1630 #else
1631 {
1632 BOOL_T ret = A68_TRUE;
1633 if (mode == M_BOOL) {
1634 UNSIGNED_T z = VALUE ((A68_BOOL *) (STACK_OFFSET (A68_UNION_SIZE)));
1635 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
1636 } else if (mode == M_CHAR) {
1637 INT_T z = VALUE ((A68_CHAR *) (STACK_OFFSET (A68_UNION_SIZE)));
1638 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
1639 } else if (mode == M_INT) {
1640 INT_T z = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
1641 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
1642 } else if (mode == M_REAL) {
1643 // A trick to copy a REAL into an unt without truncating
1644 UNSIGNED_T z;
1645 memcpy (&z, (void *) &VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE))), 8);
1646 ret = convert_radix (p, z, radix, length);
1647 } else if (mode == M_BITS) {
1648 UNSIGNED_T z = VALUE ((A68_BITS *) (STACK_OFFSET (A68_UNION_SIZE)));
1649 ret = convert_radix (p, (UNSIGNED_T) z, radix, length);
1650 } else if (mode == M_LONG_INT) {
1651 DOUBLE_NUM_T z = VALUE ((A68_LONG_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
1652 ret = convert_radix_double (p, z, radix, length);
1653 } else if (mode == M_LONG_REAL) {
1654 DOUBLE_NUM_T z = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE)));
1655 ret = convert_radix_double (p, z, radix, length);
1656 } else if (mode == M_LONG_BITS) {
1657 DOUBLE_NUM_T z = VALUE ((A68_LONG_BITS *) (STACK_OFFSET (A68_UNION_SIZE)));
1658 ret = convert_radix_double (p, z, radix, length);
1659 }
1660 if (ret == A68_FALSE) {
1661 errno = EDOM;
1662 PRELUDE_ERROR (A68_TRUE, p, ERROR_OUT_OF_BOUNDS, mode);
1663 }
1664 }
1665 #endif
1666 return get_transput_buffer (EDIT_BUFFER);
1667 }
1668
1669 //! @brief Standard string for LONG INT.
1670
1671 #if (A68_LEVEL >= 3)
1672 char *long_sub_whole_double (NODE_T * p, DOUBLE_NUM_T n, int width)
1673 {
1674 char *s = stack_string (p, 8 + width);
1675 DOUBLE_NUM_T ten;
1676 set_lw (ten, 10);
1677 s[0] = NULL_CHAR;
1678 int len = 0;
1679 do {
1680 if (len < width) {
1681 DOUBLE_NUM_T w = double_udiv (p, M_LONG_INT, n, ten, 1);
1682 (void) plusto (digchar (LW (w)), s);
1683 }
1684 len++;
1685 n = double_udiv (p, M_LONG_INT, n, ten, 0);
1686 } while (!D_ZERO (n));
1687 if (len > width) {
1688 (void) error_chars (s, width);
1689 }
1690 return s;
1691 }
1692 #endif
1693
1694 char *long_sub_whole (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 = A68_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 A68_SP = pop_sp;
1715 return s;
1716 }
1717
1718 //! @brief Standard string for INT.
1719
1720 char *sub_whole (NODE_T * p, INT_T n, int width)
1721 {
1722 char *s = stack_string (p, 8 + width);
1723 int len = 0;
1724 s[0] = NULL_CHAR;
1725 do {
1726 if (len < width) {
1727 (void) plusto (digchar (n % 10), s);
1728 }
1729 len++;
1730 n /= 10;
1731 } while (n != 0);
1732 if (len > width) {
1733 (void) error_chars (s, width);
1734 }
1735 return s;
1736 }
1737
1738 //! @brief Formatted string for NUMBER.
1739
1740 char *whole (NODE_T * p)
1741 {
1742 A68_INT width;
1743 POP_OBJECT (p, &width, A68_INT);
1744 CHECK_INT_SHORTEN (p, VALUE (&width));
1745 int arg_sp = A68_SP;
1746 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1747 MOID_T *mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
1748 if (mode == M_INT) {
1749 INT_T x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
1750 INT_T n = ABS (x);
1751 int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0);
1752 int size = (x < 0 ? 1 : (VALUE (&width) > 0 ? 1 : 0));
1753 if (VALUE (&width) == 0) {
1754 INT_T m = n;
1755 length = 0;
1756 while ((m /= 10, length++, m != 0)) {
1757 ;
1758 }
1759 }
1760 size += length;
1761 size = 8 + (size > VALUE (&width) ? size : VALUE (&width));
1762 char *s = stack_string (p, size);
1763 bufcpy (s, sub_whole (p, n, length), size);
1764 if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
1765 (void) error_chars (s, VALUE (&width));
1766 } else {
1767 if (x < 0) {
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 (VALUE (&width)));
1774 }
1775 }
1776 return s;
1777 }
1778 #if (A68_LEVEL >= 3)
1779 if (mode == M_LONG_INT) {
1780 DOUBLE_NUM_T x = VALUE ((A68_LONG_INT *) (STACK_OFFSET (A68_UNION_SIZE))), n, ten;
1781 set_lw (ten, 10);
1782 n = abs_double_int (x);
1783 int length = ABS (VALUE (&width)) - (D_NEG (x) || VALUE (&width) > 0 ? 1 : 0);
1784 int size = (D_NEG (x) ? 1 : (VALUE (&width) > 0 ? 1 : 0));
1785 if (VALUE (&width) == 0) {
1786 DOUBLE_NUM_T m = n;
1787 length = 0;
1788 while ((m = double_udiv (p, M_LONG_INT, m, ten, 0), length++, !D_ZERO (m))) {
1789 ;
1790 }
1791 }
1792 size += length;
1793 size = 8 + (size > VALUE (&width) ? size : VALUE (&width));
1794 char *s = stack_string (p, size);
1795 bufcpy (s, long_sub_whole_double (p, n, length), size);
1796 if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
1797 (void) error_chars (s, VALUE (&width));
1798 } else {
1799 if (D_NEG (x)) {
1800 (void) plusto ('-', s);
1801 } else if (VALUE (&width) > 0) {
1802 (void) plusto ('+', s);
1803 }
1804 if (VALUE (&width) != 0) {
1805 (void) leading_spaces (s, ABS (VALUE (&width)));
1806 }
1807 }
1808 return s;
1809 }
1810 #endif
1811 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
1812 int digits = DIGITS (mode);
1813 MP_T *n = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
1814 A68_SP = arg_sp; // We keep the mp where it's at
1815 if (MP_EXPONENT (n) >= (MP_T) digits) {
1816 int max_length = (mode == M_LONG_INT ? A68_LONG_INT_WIDTH : A68_LONG_LONG_INT_WIDTH);
1817 int length = (VALUE (&width) == 0 ? max_length : VALUE (&width));
1818 char *s = stack_string (p, 1 + length);
1819 (void) error_chars (s, length);
1820 return s;
1821 }
1822 BOOL_T ltz = (BOOL_T) (MP_DIGIT (n, 1) < 0);
1823 int length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
1824 int size = (ltz ? 1 : (VALUE (&width) > 0 ? 1 : 0));
1825 MP_DIGIT (n, 1) = ABS (MP_DIGIT (n, 1));
1826 if (VALUE (&width) == 0) {
1827 MP_T *m = nil_mp (p, digits);
1828 (void) move_mp (m, n, digits);
1829 length = 0;
1830 while ((over_mp_digit (p, m, m, (MP_T) 10, digits), length++, MP_DIGIT (m, 1) != 0)) {
1831 ;
1832 }
1833 }
1834 size += length;
1835 size = 8 + (size > VALUE (&width) ? size : VALUE (&width));
1836 char *s = stack_string (p, size);
1837 bufcpy (s, long_sub_whole (p, n, digits, length), size);
1838 if (length == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
1839 (void) error_chars (s, VALUE (&width));
1840 } else {
1841 if (ltz) {
1842 (void) plusto ('-', s);
1843 } else if (VALUE (&width) > 0) {
1844 (void) plusto ('+', s);
1845 }
1846 if (VALUE (&width) != 0) {
1847 (void) leading_spaces (s, ABS (VALUE (&width)));
1848 }
1849 }
1850 return s;
1851 }
1852 if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
1853 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
1854 PUSH_VALUE (p, VALUE (&width), A68_INT);
1855 PUSH_VALUE (p, 0, A68_INT);
1856 return fixed (p);
1857 }
1858 return NO_TEXT;
1859 }
1860
1861 //! @brief Fetch next digit from LONG.
1862
1863 char long_choose_dig (NODE_T * p, MP_T * y, int digits)
1864 {
1865 // Assuming positive "y".
1866 ADDR_T pop_sp = A68_SP;
1867 (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
1868 int c = MP_EXPONENT (y) == 0 ? (MP_INT_T) MP_DIGIT (y, 1) : 0;
1869 if (c > 9) {
1870 c = 9;
1871 }
1872 MP_T *t = lit_mp (p, c, 0, digits);
1873 (void) sub_mp (p, y, y, t, digits);
1874 // Reset the stack to prevent overflow, there may be many digits.
1875 A68_SP = pop_sp;
1876 return digchar (c);
1877 }
1878
1879 //! @brief Standard string for LONG.
1880
1881 char *long_sub_fixed (NODE_T * p, MP_T * x, int digits, int width, int after)
1882 {
1883 ADDR_T pop_sp = A68_SP;
1884 MP_T *y = nil_mp (p, digits);
1885 MP_T *s = nil_mp (p, digits);
1886 MP_T *t = nil_mp (p, digits);
1887 (void) ten_up_mp (p, t, -after, digits);
1888 (void) half_mp (p, t, t, digits);
1889 (void) add_mp (p, y, x, t, digits);
1890 int before = 0;
1891 // Not RR - argument reduction.
1892 while (MP_EXPONENT (y) > 1) {
1893 int k = (int) round (MP_EXPONENT (y) - 1);
1894 MP_EXPONENT (y) -= k;
1895 before += k * LOG_MP_RADIX;
1896 }
1897 // Follow RR again.
1898 SET_MP_ONE (s, digits);
1899 while ((sub_mp (p, t, y, s, digits), MP_DIGIT (t, 1) >= 0)) {
1900 before++;
1901 (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
1902 }
1903 // Compose the number.
1904 if (before + after + (after > 0 ? 1 : 0) > width) {
1905 char *str = stack_string (p, width + 1);
1906 (void) error_chars (str, width);
1907 A68_SP = pop_sp;
1908 return str;
1909 }
1910 int strwid = 8 + before + after;
1911 char *str = stack_string (p, strwid);
1912 str[0] = NULL_CHAR;
1913 int len = 0;
1914 for (int j = 0; j < before; j++) {
1915 char ch = (char) (len < A68_LONG_LONG_REAL_WIDTH ? long_choose_dig (p, y, digits) : '0');
1916 (void) string_plusab_char (str, ch, strwid);
1917 len++;
1918 }
1919 if (after > 0) {
1920 (void) string_plusab_char (str, POINT_CHAR, strwid);
1921 }
1922 for (int j = 0; j < after; j++) {
1923 char ch = (char) (len < A68_LONG_LONG_REAL_WIDTH ? long_choose_dig (p, y, digits) : '0');
1924 (void) string_plusab_char (str, ch, strwid);
1925 len++;
1926 }
1927 if ((int) strlen (str) > width) {
1928 (void) error_chars (str, width);
1929 }
1930 A68_SP = pop_sp;
1931 return str;
1932 }
1933
1934 #if (A68_LEVEL >= 3)
1935
1936 //! @brief Fetch next digit from REAL.
1937
1938 char choose_dig_double (DOUBLE_T * y)
1939 {
1940 // Assuming positive "y".
1941 int c = (int) (*y *= 10);
1942 if (c > 9) {
1943 c = 9;
1944 }
1945 *y -= c;
1946 return digchar (c);
1947 }
1948
1949 #endif
1950
1951 #if (A68_LEVEL >= 3)
1952
1953 //! @brief Standard string for REAL.
1954
1955 char *sub_fixed_double (NODE_T * p, DOUBLE_T x, int width, int after, int precision)
1956 {
1957 ABEND (x < 0, ERROR_INTERNAL_CONSISTENCY, __func__);
1958 // Round and scale.
1959 DOUBLE_T z = x + 0.5q * ten_up_double (-after);
1960 DOUBLE_T y = z;
1961 int before = 0;
1962 // Not according RR - argument reduction to avoid long division loop.
1963 if (z >= 1.0e10q) { // Arbitrary, log10 must be worthwhile.
1964 before = (int) floor_double (log10_double (z)) - 1;
1965 z /= ten_up_double (before);
1966 }
1967 // Follow RR again.
1968 while (z >= 1.0q) {
1969 before++;
1970 z /= 10.0q;
1971 }
1972 // Scale number.
1973 y /= ten_up_double (before);
1974 // Put digits, prevent garbage from overstretching precision.
1975 // Many languages produce garbage when specifying more decimals
1976 // than the type actually has. A68G pads '0's in this case.
1977 // That is just as arbitrary, but at least recognisable.
1978 int strwid = 8 + before + after; // A bit too long.
1979 char *str = stack_string (p, strwid);
1980 int len = 0;
1981 for (int j = 0; j < before; j++) {
1982 char ch = (char) (len < precision ? choose_dig_double (&y) : '0');
1983 (void) string_plusab_char (str, ch, strwid);
1984 len++;
1985 }
1986 if (after > 0) {
1987 (void) string_plusab_char (str, POINT_CHAR, strwid);
1988 }
1989 for (int j = 0; j < after; j++) {
1990 char ch = (char) (len < precision ? choose_dig_double (&y) : '0');
1991 (void) string_plusab_char (str, ch, strwid);
1992 len++;
1993 }
1994 if ((int) strlen (str) > width) {
1995 (void) error_chars (str, width);
1996 }
1997 return str;
1998 }
1999
2000 //! @brief Standard string for REAL.
2001
2002 char *sub_fixed (NODE_T * p, REAL_T x, int width, int after)
2003 {
2004 // Better precision than the REAL only routine
2005 return sub_fixed_double (p, (DOUBLE_T) x, width, after, A68_REAL_WIDTH);
2006 }
2007
2008 #else
2009
2010 //! @brief Fetch next digit from REAL.
2011
2012 char choose_dig (REAL_T * y)
2013 {
2014 // Assuming positive "y".
2015 int c = (int) (*y *= 10);
2016 if (c > 9) {
2017 c = 9;
2018 }
2019 *y -= c;
2020 return digchar (c);
2021 }
2022
2023 //! @brief Standard string for REAL.
2024
2025 char *sub_fixed (NODE_T * p, REAL_T x, int width, int after)
2026 {
2027 ABEND (x < 0, ERROR_INTERNAL_CONSISTENCY, __func__);
2028 // Round and scale.
2029 REAL_T z = x + 0.5 * ten_up (-after);
2030 REAL_T y = z;
2031 int before = 0;
2032 // Not according RR - argument reduction to avoid long division loop.
2033 if (z >= 1.0e10) { // Arbitrary, log10 must be worthwhile.
2034 before = (int) floor (log10 (z)) - 1;
2035 z /= ten_up (before);
2036 }
2037 // Follow RR again.
2038 while (z >= 1.0) {
2039 before++;
2040 z /= 10.0;
2041 }
2042 // Scale number.
2043 y /= ten_up (before);
2044 // Put digits, prevent garbage from overstretching precision.
2045 // Many languages produce garbage when specifying more decimals
2046 // than the type actually has. A68G pads '0's in this case.
2047 // That is just as arbitrary, but at least recognisable.
2048 int strwid = 8 + before + after; // A bit too long.
2049 char *str = stack_string (p, strwid);
2050 int len = 0;
2051 for (int j = 0; j < before; j++) {
2052 char ch = (char) (len < A68_REAL_WIDTH ? choose_dig (&y) : '0');
2053 (void) string_plusab_char (str, ch, strwid);
2054 len++;
2055 }
2056 if (after > 0) {
2057 (void) string_plusab_char (str, POINT_CHAR, strwid);
2058 }
2059 for (int j = 0; j < after; j++) {
2060 char ch = (char) (len < A68_REAL_WIDTH ? choose_dig (&y) : '0');
2061 (void) string_plusab_char (str, ch, strwid);
2062 len++;
2063 }
2064 if ((int) strlen (str) > width) {
2065 (void) error_chars (str, width);
2066 }
2067 return str;
2068 }
2069
2070 #endif
2071
2072 //! @brief Formatted string for NUMBER.
2073
2074 char *fixed (NODE_T * p)
2075 {
2076 A68_INT width, after;
2077 POP_OBJECT (p, &after, A68_INT);
2078 POP_OBJECT (p, &width, A68_INT);
2079 CHECK_INT_SHORTEN (p, VALUE (&after));
2080 CHECK_INT_SHORTEN (p, VALUE (&width));
2081 ADDR_T arg_sp = A68_SP;
2082 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2083 MOID_T *mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
2084 ADDR_T pop_sp = A68_SP;
2085 if (mode == M_REAL) {
2086 REAL_T x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE)));
2087 int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0);
2088 CHECK_REAL (p, x);
2089 A68_SP = arg_sp;
2090 if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
2091 REAL_T y = ABS (x);
2092 if (VALUE (&width) == 0) {
2093 length = (VALUE (&after) == 0 ? 1 : 0);
2094 REAL_T z0 = ten_up (-VALUE (&after)), z1 = ten_up (length);
2095 while (y + 0.5 * z0 > z1) {
2096 length++;
2097 z1 *= 10.0;
2098 }
2099 length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
2100 }
2101 char *s = sub_fixed (p, y, length, VALUE (&after));
2102 if (strchr (s, ERROR_CHAR) == NO_TEXT) {
2103 if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && y < 1.0) {
2104 (void) plusto ('0', s);
2105 }
2106 if (x < 0) {
2107 (void) plusto ('-', s);
2108 } else if (VALUE (&width) > 0) {
2109 (void) plusto ('+', s);
2110 }
2111 if (VALUE (&width) != 0) {
2112 (void) leading_spaces (s, ABS (VALUE (&width)));
2113 }
2114 return s;
2115 } else if (VALUE (&after) > 0) {
2116 A68_SP = arg_sp;
2117 PUSH_VALUE (p, VALUE (&width), A68_INT);
2118 PUSH_VALUE (p, VALUE (&after) - 1, A68_INT);
2119 return fixed (p);
2120 } else {
2121 return error_chars (s, VALUE (&width));
2122 }
2123 } else {
2124 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2125 return error_chars (s, VALUE (&width));
2126 }
2127 }
2128 #if (A68_LEVEL >= 3)
2129 if (mode == M_LONG_REAL) {
2130 DOUBLE_T x = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE))).f;
2131 int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0);
2132 CHECK_DOUBLE_REAL (p, x);
2133 A68_SP = arg_sp;
2134 if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
2135 DOUBLE_T y = ABS (x);
2136 if (VALUE (&width) == 0) {
2137 length = (VALUE (&after) == 0 ? 1 : 0);
2138 DOUBLE_T z0 = ten_up_double (-VALUE (&after)), z1 = ten_up_double (length);
2139 while (y + 0.5 * z0 > z1) {
2140 length++;
2141 z1 *= 10.0;
2142 }
2143 length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
2144 }
2145 char *s = sub_fixed_double (p, y, length, VALUE (&after), A68_LONG_REAL_WIDTH);
2146 if (strchr (s, ERROR_CHAR) == NO_TEXT) {
2147 if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && y < 1.0) {
2148 (void) plusto ('0', s);
2149 }
2150 if (x < 0) {
2151 (void) plusto ('-', s);
2152 } else if (VALUE (&width) > 0) {
2153 (void) plusto ('+', s);
2154 }
2155 if (VALUE (&width) != 0) {
2156 (void) leading_spaces (s, ABS (VALUE (&width)));
2157 }
2158 return s;
2159 } else if (VALUE (&after) > 0) {
2160 A68_SP = arg_sp;
2161 PUSH_VALUE (p, VALUE (&width), A68_INT);
2162 PUSH_VALUE (p, VALUE (&after) - 1, A68_INT);
2163 return fixed (p);
2164 } else {
2165 return error_chars (s, VALUE (&width));
2166 }
2167 } else {
2168 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2169 return error_chars (s, VALUE (&width));
2170 }
2171 }
2172 #endif
2173 if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2174 int digits = DIGITS (mode);
2175 MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
2176 A68_SP = arg_sp;
2177 BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
2178 MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
2179 int length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0);
2180 if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) {
2181 MP_T *z0 = nil_mp (p, digits);
2182 MP_T *z1 = nil_mp (p, digits);
2183 MP_T *t = nil_mp (p, digits);
2184 if (VALUE (&width) == 0) {
2185 length = (VALUE (&after) == 0 ? 1 : 0);
2186 (void) set_mp (z0, (MP_T) (MP_RADIX / 10), -1, digits);
2187 (void) set_mp (z1, (MP_T) 10, 0, digits);
2188 (void) pow_mp_int (p, z0, z0, VALUE (&after), digits);
2189 (void) pow_mp_int (p, z1, z1, length, digits);
2190 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)) {
2191 length++;
2192 (void) mul_mp_digit (p, z1, z1, (MP_T) 10, digits);
2193 }
2194 length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1);
2195 }
2196 // char *s = stack_string (p, 8 + length);
2197 char *s = long_sub_fixed (p, x, digits, length, VALUE (&after));
2198 if (strchr (s, ERROR_CHAR) == NO_TEXT) {
2199 if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && (MP_EXPONENT (x) < 0 || MP_DIGIT (x, 1) == 0)) {
2200 (void) plusto ('0', s);
2201 }
2202 if (ltz) {
2203 (void) plusto ('-', s);
2204 } else if (VALUE (&width) > 0) {
2205 (void) plusto ('+', s);
2206 }
2207 if (VALUE (&width) != 0) {
2208 (void) leading_spaces (s, ABS (VALUE (&width)));
2209 }
2210 return s;
2211 } else if (VALUE (&after) > 0) {
2212 A68_SP = arg_sp;
2213 MP_DIGIT (x, 1) = ltz ? -ABS (MP_DIGIT (x, 1)) : ABS (MP_DIGIT (x, 1));
2214 PUSH_VALUE (p, VALUE (&width), A68_INT);
2215 PUSH_VALUE (p, VALUE (&after) - 1, A68_INT);
2216 return fixed (p);
2217 } else {
2218 return error_chars (s, VALUE (&width));
2219 }
2220 } else {
2221 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2222 return error_chars (s, VALUE (&width));
2223 }
2224 }
2225 if (mode == M_INT) {
2226 int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
2227 PUSH_UNION (p, M_REAL);
2228 PUSH_VALUE (p, (REAL_T) x, A68_REAL);
2229 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
2230 PUSH_VALUE (p, VALUE (&width), A68_INT);
2231 PUSH_VALUE (p, VALUE (&after), A68_INT);
2232 return fixed (p);
2233 }
2234 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2235 A68_SP = pop_sp;
2236 if (mode == M_LONG_INT) {
2237 VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_REAL;
2238 } else {
2239 VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL;
2240 } INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2241 PUSH_VALUE (p, VALUE (&width), A68_INT);
2242 PUSH_VALUE (p, VALUE (&after), A68_INT);
2243 return fixed (p);
2244 }
2245 return NO_TEXT;
2246 }
2247
2248 //! @brief Scale LONG for formatting.
2249
2250 void long_standardise (NODE_T * p, MP_T * y, int digits, int before, int after, int *q)
2251 {
2252 ADDR_T pop_sp = A68_SP;
2253 MP_T *f = nil_mp (p, digits);
2254 MP_T *g = nil_mp (p, digits);
2255 MP_T *h = nil_mp (p, digits);
2256 MP_T *t = nil_mp (p, digits);
2257 ten_up_mp (p, g, before, digits);
2258 (void) div_mp_digit (p, h, g, (MP_T) 10, digits);
2259 // Speed huge exponents.
2260 if ((MP_EXPONENT (y) - MP_EXPONENT (g)) > 1) {
2261 (*q) += LOG_MP_RADIX * ((int) MP_EXPONENT (y) - (int) MP_EXPONENT (g) - 1);
2262 MP_EXPONENT (y) = MP_EXPONENT (g) + 1;
2263 }
2264 while ((sub_mp (p, t, y, g, digits), MP_DIGIT (t, 1) >= 0)) {
2265 (void) div_mp_digit (p, y, y, (MP_T) 10, digits);
2266 (*q)++;
2267 }
2268 if (MP_DIGIT (y, 1) != 0) {
2269 // Speed huge exponents.
2270 if ((MP_EXPONENT (y) - MP_EXPONENT (h)) < -1) {
2271 (*q) -= LOG_MP_RADIX * ((int) MP_EXPONENT (h) - (int) MP_EXPONENT (y) - 1);
2272 MP_EXPONENT (y) = MP_EXPONENT (h) - 1;
2273 }
2274 while ((sub_mp (p, t, y, h, digits), MP_DIGIT (t, 1) < 0)) {
2275 (void) mul_mp_digit (p, y, y, (MP_T) 10, digits);
2276 (*q)--;
2277 }
2278 }
2279 ten_up_mp (p, f, -after, digits);
2280 (void) div_mp_digit (p, t, f, (MP_T) 2, digits);
2281 (void) add_mp (p, t, y, t, digits);
2282 (void) sub_mp (p, t, t, g, digits);
2283 if (MP_DIGIT (t, 1) >= 0) {
2284 (void) move_mp (y, h, digits);
2285 (*q)++;
2286 }
2287 A68_SP = pop_sp;
2288 }
2289
2290 #if (A68_LEVEL >= 3)
2291
2292 //! @brief Scale REAL for formatting.
2293
2294 void standardise_double (DOUBLE_T * y, int before, int after, int *p)
2295 {
2296 //int g = 1.0q; for (int j = 0; j < before; j++) { g *= 10.0q; }
2297 DOUBLE_T g = ten_up_double (before);
2298 DOUBLE_T h = g / 10.0q;
2299 while (*y >= g) {
2300 *y *= 0.1q;
2301 (*p)++;
2302 }
2303 if (*y != 0.0q) {
2304 while (*y < h) {
2305 *y *= 10.0q;
2306 (*p)--;
2307 }
2308 }
2309 //f = 1.0q; for (int j = 0; j < after; j++) { f *= 0.1q; }
2310 DOUBLE_T f = ten_up_double (-after);
2311 if (*y + 0.5q * f >= g) {
2312 *y = h;
2313 (*p)++;
2314 }
2315 }
2316
2317 //! @brief Scale REAL for formatting.
2318
2319 void standardise (REAL_T * y, int before, int after, int *p)
2320 {
2321 // Better precision than the REAL only routine
2322 DOUBLE_T z = (DOUBLE_T) * y;
2323 standardise_double (&z, before, after, p);
2324 *y = (REAL_T) z;
2325 }
2326
2327 #else
2328
2329 //! @brief Scale REAL for formatting.
2330
2331 void standardise (REAL_T * y, int before, int after, int *p)
2332 {
2333 // This according RR, but for REAL the last digits are approximate.
2334 // A68G 3 uses DOUBLE precision version.
2335 //int g = 1.0; for (int j = 0; j < before; j++) { g *= 10.0; }
2336 REAL_T g = ten_up (before);
2337 REAL_T h = g / 10.0;
2338 while (*y >= g) {
2339 *y *= 0.1;
2340 (*p)++;
2341 }
2342 if (*y != 0.0) {
2343 while (*y < h) {
2344 *y *= 10.0;
2345 (*p)--;
2346 }
2347 }
2348 //f = 1.0; for (int j = 0; j < after; j++) { f *= 0.1; }
2349 REAL_T f = ten_up (-after);
2350 if (*y + 0.5 * f >= g) {
2351 *y = h;
2352 (*p)++;
2353 }
2354 }
2355
2356 #endif
2357
2358 //! @brief Formatted string for NUMBER.
2359
2360 char *real (NODE_T * p)
2361 {
2362 // POP arguments.
2363 A68_INT width, after, expo, frmt;
2364 POP_OBJECT (p, &frmt, A68_INT);
2365 POP_OBJECT (p, &expo, A68_INT);
2366 POP_OBJECT (p, &after, A68_INT);
2367 POP_OBJECT (p, &width, A68_INT);
2368 CHECK_INT_SHORTEN (p, VALUE (&frmt));
2369 CHECK_INT_SHORTEN (p, VALUE (&expo));
2370 CHECK_INT_SHORTEN (p, VALUE (&after));
2371 CHECK_INT_SHORTEN (p, VALUE (&width));
2372 ADDR_T arg_sp = A68_SP;
2373 DECREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2374 MOID_T *mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP));
2375 ADDR_T pop_sp = A68_SP;
2376 if (mode == M_REAL) {
2377 REAL_T x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE)));
2378 int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
2379 A68_SP = arg_sp;
2380 CHECK_REAL (p, x);
2381 if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
2382 REAL_T y = ABS (x);
2383 int q = 0;
2384 standardise (&y, before, VALUE (&after), &q);
2385 if (VALUE (&frmt) > 0) {
2386 while (q % VALUE (&frmt) != 0) {
2387 y *= 10;
2388 q--;
2389 if (VALUE (&after) > 0) {
2390 VALUE (&after)--;
2391 }
2392 }
2393 } else {
2394 REAL_T upb = ten_up (-VALUE (&frmt)), lwb = ten_up (-VALUE (&frmt) - 1);
2395 while (y < lwb) {
2396 y *= 10;
2397 q--;
2398 if (VALUE (&after) > 0) {
2399 VALUE (&after)--;
2400 }
2401 }
2402 while (y > upb) {
2403 y /= 10;
2404 q++;
2405 if (VALUE (&after) > 0) {
2406 VALUE (&after)++;
2407 }
2408 }
2409 }
2410 PUSH_UNION (p, M_REAL);
2411 PUSH_VALUE (p, SIGN (x) * y, A68_REAL);
2412 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
2413 PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT);
2414 PUSH_VALUE (p, VALUE (&after), A68_INT);
2415 char *t1 = fixed (p);
2416 PUSH_UNION (p, M_INT);
2417 PUSH_VALUE (p, q, A68_INT);
2418 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT)));
2419 PUSH_VALUE (p, VALUE (&expo), A68_INT);
2420 char *t2 = whole (p);
2421 int strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2);
2422 char *s = stack_string (p, strwid);
2423 bufcpy (s, t1, strwid);
2424 (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
2425 bufcat (s, t2, strwid);
2426 if (VALUE (&expo) == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
2427 A68_SP = arg_sp;
2428 PUSH_VALUE (p, VALUE (&width), A68_INT);
2429 PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT);
2430 PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT);
2431 PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2432 return real (p);
2433 } else {
2434 return s;
2435 }
2436 } else {
2437 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2438 return error_chars (s, VALUE (&width));
2439 }
2440 }
2441 #if (A68_LEVEL >= 3)
2442 if (mode == M_LONG_REAL) {
2443 DOUBLE_T x = VALUE ((A68_LONG_REAL *) (STACK_OFFSET (A68_UNION_SIZE))).f;
2444 int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
2445 CHECK_DOUBLE_REAL (p, x);
2446 A68_SP = arg_sp;
2447 if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
2448 DOUBLE_T y = (x >= 0.0q ? x : -x);
2449 int q = 0;
2450 standardise_double (&y, before, VALUE (&after), &q);
2451 if (VALUE (&frmt) > 0) {
2452 while (q % VALUE (&frmt) != 0) {
2453 y *= 10.0q;
2454 q--;
2455 if (VALUE (&after) > 0) {
2456 VALUE (&after)--;
2457 }
2458 }
2459 } else {
2460 DOUBLE_T upb = ten_up_double (-VALUE (&frmt)), lwb = ten_up_double (-VALUE (&frmt) - 1);
2461 while (y < lwb) {
2462 y *= 10.0q;
2463 q--;
2464 if (VALUE (&after) > 0) {
2465 VALUE (&after)--;
2466 }
2467 }
2468 while (y > upb) {
2469 y /= 10.0q;
2470 q++;
2471 if (VALUE (&after) > 0) {
2472 VALUE (&after)++;
2473 }
2474 }
2475 }
2476 PUSH_UNION (p, M_LONG_REAL);
2477 {
2478 DOUBLE_NUM_T d;
2479 d.f = (x >= 0.0q ? y : -y);
2480 PUSH_VALUE (p, d, A68_LONG_REAL);
2481 }
2482 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_LONG_REAL)));
2483 PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT);
2484 PUSH_VALUE (p, VALUE (&after), A68_INT);
2485 char *t1 = fixed (p);
2486 PUSH_UNION (p, M_INT);
2487 PUSH_VALUE (p, q, A68_INT);
2488 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT)));
2489 PUSH_VALUE (p, VALUE (&expo), A68_INT);
2490 char *t2 = whole (p);
2491 int strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2);
2492 char *s = stack_string (p, strwid);
2493 bufcpy (s, t1, strwid);
2494 (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
2495 bufcat (s, t2, strwid);
2496 if (VALUE (&expo) == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
2497 A68_SP = arg_sp;
2498 PUSH_VALUE (p, VALUE (&width), A68_INT);
2499 PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT);
2500 PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT);
2501 PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2502 return real (p);
2503 } else {
2504 return s;
2505 }
2506 } else {
2507 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2508 return error_chars (s, VALUE (&width));
2509 }
2510 }
2511 #endif
2512 if (mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2513 int digits = DIGITS (mode);
2514 int before;
2515 MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE));
2516 CHECK_LONG_REAL (p, x, mode);
2517 BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0);
2518 A68_SP = arg_sp;
2519 MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1));
2520 before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2;
2521 if (SIGN (before) + SIGN (VALUE (&after)) > 0) {
2522 int q = 0;
2523 size_t N_mp = SIZE_MP (digits);
2524 MP_T *z = nil_mp (p, digits);
2525 (void) move_mp (z, x, digits);
2526 long_standardise (p, z, digits, before, VALUE (&after), &q);
2527 if (VALUE (&frmt) > 0) {
2528 while (q % VALUE (&frmt) != 0) {
2529 (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
2530 q--;
2531 if (VALUE (&after) > 0) {
2532 VALUE (&after)--;
2533 }
2534 }
2535 } else {
2536 ADDR_T sp1 = A68_SP;
2537 MP_T *dif = nil_mp (p, digits);
2538 MP_T *lim = nil_mp (p, digits);
2539 (void) ten_up_mp (p, lim, -VALUE (&frmt) - 1, digits);
2540 (void) sub_mp (p, dif, z, lim, digits);
2541 while (MP_DIGIT (dif, 1) < 0) {
2542 (void) mul_mp_digit (p, z, z, (MP_T) 10, digits);
2543 q--;
2544 if (VALUE (&after) > 0) {
2545 VALUE (&after)--;
2546 }
2547 (void) sub_mp (p, dif, z, lim, digits);
2548 }
2549 (void) mul_mp_digit (p, lim, lim, (MP_T) 10, digits);
2550 (void) sub_mp (p, dif, z, lim, digits);
2551 while (MP_DIGIT (dif, 1) > 0) {
2552 (void) div_mp_digit (p, z, z, (MP_T) 10, digits);
2553 q++;
2554 if (VALUE (&after) > 0) {
2555 VALUE (&after)++;
2556 }
2557 (void) sub_mp (p, dif, z, lim, digits);
2558 }
2559 A68_SP = sp1;
2560 }
2561 PUSH_UNION (p, mode);
2562 MP_DIGIT (z, 1) = (ltz ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1));
2563 PUSH (p, z, N_mp);
2564 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE_MP (digits)));
2565 PUSH_VALUE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT);
2566 PUSH_VALUE (p, VALUE (&after), A68_INT);
2567 char *t1 = fixed (p);
2568 PUSH_UNION (p, M_INT);
2569 PUSH_VALUE (p, q, A68_INT);
2570 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_INT)));
2571 PUSH_VALUE (p, VALUE (&expo), A68_INT);
2572 char *t2 = whole (p);
2573 int strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2);
2574 char *s = stack_string (p, strwid);
2575 bufcpy (s, t1, strwid);
2576 (void) string_plusab_char (s, EXPONENT_CHAR, strwid);
2577 bufcat (s, t2, strwid);
2578 if (VALUE (&expo) == 0 || strchr (s, ERROR_CHAR) != NO_TEXT) {
2579 A68_SP = arg_sp;
2580 PUSH_VALUE (p, VALUE (&width), A68_INT);
2581 PUSH_VALUE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT);
2582 PUSH_VALUE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT);
2583 PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2584 return real (p);
2585 } else {
2586 return s;
2587 }
2588 } else {
2589 char *s = stack_string (p, 8 + ABS (VALUE (&width)));
2590 return error_chars (s, VALUE (&width));
2591 }
2592 }
2593 if (mode == M_INT) {
2594 int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE)));
2595 PUSH_UNION (p, M_REAL);
2596 PUSH_VALUE (p, (REAL_T) x, A68_REAL);
2597 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
2598 PUSH_VALUE (p, VALUE (&width), A68_INT);
2599 PUSH_VALUE (p, VALUE (&after), A68_INT);
2600 PUSH_VALUE (p, VALUE (&expo), A68_INT);
2601 PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2602 return real (p);
2603 }
2604 if (mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2605 A68_SP = pop_sp;
2606 if (mode == M_LONG_INT) {
2607 VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_REAL;
2608 } else {
2609 VALUE ((A68_UNION *) STACK_TOP) = (void *) M_LONG_LONG_REAL;
2610 } INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER));
2611 PUSH_VALUE (p, VALUE (&width), A68_INT);
2612 PUSH_VALUE (p, VALUE (&after), A68_INT);
2613 PUSH_VALUE (p, VALUE (&expo), A68_INT);
2614 PUSH_VALUE (p, VALUE (&frmt), A68_INT);
2615 return real (p);
2616 }
2617 return NO_TEXT;
2618 }
2619
2620 //! @brief PROC (NUMBER, INT) STRING whole
2621
2622 void genie_whole (NODE_T * p)
2623 {
2624 ADDR_T pop_sp = A68_SP;
2625 char *str = whole (p);
2626 A68_SP = pop_sp - SIZE (M_INT) - SIZE (M_NUMBER);
2627 A68_REF ref = tmp_to_a68_string (p, str);
2628 PUSH_REF (p, ref);
2629 }
2630
2631 //! @brief PROC (NUMBER, INT, INT) STRING bits
2632
2633 void genie_bits (NODE_T * p)
2634 {
2635 ADDR_T pop_sp = A68_SP;
2636 char *str = bits (p);
2637 A68_SP = pop_sp - 2 * SIZE (M_INT) - SIZE (M_HEX_NUMBER);
2638 A68_REF ref = tmp_to_a68_string (p, str);
2639 PUSH_REF (p, ref);
2640 }
2641
2642 //! @brief PROC (NUMBER, INT, INT) STRING fixed
2643
2644 void genie_fixed (NODE_T * p)
2645 {
2646 ADDR_T pop_sp = A68_SP;
2647 char *str = fixed (p);
2648 A68_SP = pop_sp - 2 * SIZE (M_INT) - SIZE (M_NUMBER);
2649 A68_REF ref = tmp_to_a68_string (p, str);
2650 PUSH_REF (p, ref);
2651 }
2652
2653 //! @brief PROC (NUMBER, INT, INT, INT) STRING eng
2654
2655 void genie_real (NODE_T * p)
2656 {
2657 ADDR_T pop_sp = A68_SP;
2658 char *str = real (p);
2659 A68_SP = pop_sp - 4 * SIZE (M_INT) - SIZE (M_NUMBER);
2660 A68_REF ref = tmp_to_a68_string (p, str);
2661 PUSH_REF (p, ref);
2662 }
2663
2664 //! @brief PROC (NUMBER, INT, INT, INT) STRING float
2665
2666 void genie_float (NODE_T * p)
2667 {
2668 PUSH_VALUE (p, 1, A68_INT);
2669 genie_real (p);
2670 }
2671
2672 // ALGOL68C routines.
2673
2674 //! @def A68C_TRANSPUT
2675 //! @brief Generate Algol68C routines readint, getint, etcetera.
2676
2677 #define A68C_TRANSPUT(n, m)\
2678 void genie_get_##n (NODE_T * p)\
2679 {\
2680 A68_REF ref_file;\
2681 POP_REF (p, &ref_file);\
2682 CHECK_REF (p, ref_file, M_REF_FILE);\
2683 BYTE_T *z = STACK_TOP;\
2684 INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
2685 ADDR_T pop_sp = A68_SP;\
2686 open_for_reading (p, ref_file);\
2687 genie_read_standard (p, MODE (m), z, ref_file);\
2688 A68_SP = pop_sp;\
2689 }\
2690 void genie_put_##n (NODE_T * p)\
2691 {\
2692 int size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\
2693 A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\
2694 CHECK_REF (p, ref_file, M_REF_FILE);\
2695 reset_transput_buffer (UNFORMATTED_BUFFER);\
2696 open_for_writing (p, ref_file);\
2697 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
2698 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
2699 DECREMENT_STACK_POINTER (p, size + sizf);\
2700 }\
2701 void genie_read_##n (NODE_T * p)\
2702 {\
2703 BYTE_T *z = STACK_TOP;\
2704 INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\
2705 ADDR_T pop_sp = A68_SP;\
2706 open_for_reading (p, A68 (stand_in));\
2707 genie_read_standard (p, MODE (m), z, A68 (stand_in));\
2708 A68_SP = pop_sp;\
2709 }\
2710 void genie_print_##n (NODE_T * p)\
2711 {\
2712 int size = SIZE (MODE (m));\
2713 reset_transput_buffer (UNFORMATTED_BUFFER);\
2714 open_for_writing (p, A68 (stand_out));\
2715 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68 (stand_out));\
2716 write_purge_buffer (p, A68 (stand_out), UNFORMATTED_BUFFER);\
2717 DECREMENT_STACK_POINTER (p, size);\
2718 }
2719
2720 A68C_TRANSPUT (int, INT);
2721 A68C_TRANSPUT (long_int, LONG_INT);
2722 A68C_TRANSPUT (long_mp_int, LONG_LONG_INT);
2723 A68C_TRANSPUT (real, REAL);
2724 A68C_TRANSPUT (long_real, LONG_REAL);
2725 A68C_TRANSPUT (long_mp_real, LONG_LONG_REAL);
2726 A68C_TRANSPUT (bits, BITS);
2727 A68C_TRANSPUT (long_bits, LONG_BITS);
2728 A68C_TRANSPUT (long_mp_bits, LONG_LONG_BITS);
2729 A68C_TRANSPUT (bool, BOOL);
2730 A68C_TRANSPUT (char, CHAR);
2731 A68C_TRANSPUT (string, STRING);
2732
2733 #undef A68C_TRANSPUT
2734
2735 #define A68C_TRANSPUT(n, s, m)\
2736 void genie_get_##n (NODE_T * p) {\
2737 A68_REF ref_file;\
2738 POP_REF (p, &ref_file);\
2739 CHECK_REF (p, ref_file, M_REF_FILE);\
2740 PUSH_REF (p, ref_file);\
2741 genie_get_##s (p);\
2742 PUSH_REF (p, ref_file);\
2743 genie_get_##s (p);\
2744 }\
2745 void genie_put_##n (NODE_T * p) {\
2746 int size = SIZE (MODE (m)), sizf = SIZE (M_REF_FILE);\
2747 A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\
2748 CHECK_REF (p, ref_file, M_REF_FILE);\
2749 reset_transput_buffer (UNFORMATTED_BUFFER);\
2750 open_for_writing (p, ref_file);\
2751 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\
2752 write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\
2753 DECREMENT_STACK_POINTER (p, size + sizf);\
2754 }\
2755 void genie_read_##n (NODE_T * p) {\
2756 genie_read_##s (p);\
2757 genie_read_##s (p);\
2758 }\
2759 void genie_print_##n (NODE_T * p) {\
2760 int size = SIZE (MODE (m));\
2761 reset_transput_buffer (UNFORMATTED_BUFFER);\
2762 open_for_writing (p, A68 (stand_out));\
2763 genie_write_standard (p, MODE (m), STACK_OFFSET (-size), A68 (stand_out));\
2764 write_purge_buffer (p, A68 (stand_out), UNFORMATTED_BUFFER);\
2765 DECREMENT_STACK_POINTER (p, size);\
2766 }
2767
2768 A68C_TRANSPUT (complex, real, COMPLEX);
2769 A68C_TRANSPUT (mp_complex, long_real, LONG_COMPLEX);
2770 A68C_TRANSPUT (long_mp_complex, long_mp_real, LONG_LONG_COMPLEX);
2771
2772 #undef A68C_TRANSPUT
2773
2774 //! @brief PROC STRING read line
2775
2776 void genie_read_line (NODE_T * p)
2777 {
2778 #if defined (HAVE_READLINE)
2779 char *line = readline ("");
2780 if (line != NO_TEXT && (int) strlen (line) > 0) {
2781 add_history (line);
2782 }
2783 PUSH_REF (p, c_to_a_string (p, line, DEFAULT_WIDTH));
2784 a68_free (line);
2785 #else
2786 genie_read_string (p);
2787 genie_stand_in (p);
2788 genie_new_line (p);
2789 #endif
2790 }