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