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