rts-formatted.c
1 //! @file rts-formatted.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-2024 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 //! Formatted transput.
25
26 #include "a68g.h"
27 #include "a68g-genie.h"
28 #include "a68g-frames.h"
29 #include "a68g-prelude.h"
30 #include "a68g-mp.h"
31 #include "a68g-double.h"
32 #include "a68g-transput.h"
33
34 // Transput - Formatted transput.
35 // In Algol68G, a value of mode FORMAT looks like a routine text. The value
36 // comprises a pointer to its environment in the stack, and a pointer where the
37 // format text is at in the syntax tree.
38
39 #define INT_DIGITS "0123456789"
40 #define BITS_DIGITS "0123456789abcdefABCDEF"
41 #define INT_DIGITS_BLANK " 0123456789"
42 #define BITS_DIGITS_BLANK " 0123456789abcdefABCDEF"
43 #define SIGN_DIGITS " +-"
44
45 //! @brief Convert to other radix, binary up to hexadecimal.
46
47 BOOL_T convert_radix (NODE_T * p, UNSIGNED_T z, int radix, int width)
48 {
49 reset_transput_buffer (EDIT_BUFFER);
50 if (radix < 2 || radix > 16) {
51 radix = 16;
52 }
53 if (width > 0) {
54 while (width > 0) {
55 int digit = (int) (z % (UNSIGNED_T) radix);
56 plusto_transput_buffer (p, digchar (digit), EDIT_BUFFER);
57 width--;
58 z /= (UNSIGNED_T) radix;
59 }
60 return z == 0;
61 } else if (width == 0) {
62 do {
63 int digit = (int) (z % (UNSIGNED_T) radix);
64 plusto_transput_buffer (p, digchar (digit), EDIT_BUFFER);
65 z /= (UNSIGNED_T) radix;
66 } while (z > 0);
67 return A68_TRUE;
68 } else {
69 return A68_FALSE;
70 }
71 }
72
73 //! @brief Handle format error event.
74
75 void format_error (NODE_T * p, A68_REF ref_file, char *diag)
76 {
77 A68_FILE *f = FILE_DEREF (&ref_file);
78 on_event_handler (p, FORMAT_ERROR_MENDED (f), ref_file);
79 A68_BOOL z;
80 POP_OBJECT (p, &z, A68_BOOL);
81 if (VALUE (&z) == A68_FALSE) {
82 diagnostic (A68_RUNTIME_ERROR, p, diag);
83 exit_genie (p, A68_RUNTIME_ERROR);
84 }
85 }
86
87 //! @brief Initialise processing of pictures.
88
89 void initialise_collitems (NODE_T * p)
90 {
91 // Every picture has a counter that says whether it has not been used OR the number
92 // of times it can still be used.
93 for (; p != NO_NODE; FORWARD (p)) {
94 if (IS (p, PICTURE)) {
95 A68_COLLITEM *z = (A68_COLLITEM *) FRAME_LOCAL (A68_FP, OFFSET (TAX (p)));
96 STATUS (z) = INIT_MASK;
97 COUNT (z) = ITEM_NOT_USED;
98 }
99 // Don't dive into f, g, n frames and collections.
100 if (!(IS (p, ENCLOSED_CLAUSE) || IS (p, COLLECTION))) {
101 initialise_collitems (SUB (p));
102 }
103 }
104 }
105
106 //! @brief Initialise processing of format text.
107
108 void open_format_frame (NODE_T * p, A68_REF ref_file, A68_FORMAT * fmt, BOOL_T embedded, BOOL_T init)
109 {
110 // Open a new frame for the format text and save for return to embedding one.
111 A68_FILE *file = FILE_DEREF (&ref_file);
112 // Integrity check.
113 if ((STATUS (fmt) & SKIP_FORMAT_MASK) || (BODY (fmt) == NO_NODE)) {
114 format_error (p, ref_file, ERROR_FORMAT_UNDEFINED);
115 }
116 // Ok, seems usable.
117 NODE_T *dollar = SUB (BODY (fmt));
118 OPEN_PROC_FRAME (dollar, ENVIRON (fmt));
119 INIT_STATIC_FRAME (dollar);
120 // Save old format.
121 A68_FORMAT *save = (A68_FORMAT *) FRAME_LOCAL (A68_FP, OFFSET (TAX (dollar)));
122 *save = (embedded == EMBEDDED_FORMAT ? FORMAT (file) : nil_format);
123 FORMAT (file) = *fmt;
124 // Reset all collitems.
125 if (init) {
126 initialise_collitems (dollar);
127 }
128 }
129
130 //! @brief Handle end-of-format event.
131
132 int end_of_format (NODE_T * p, A68_REF ref_file)
133 {
134 // Format-items return immediately to the embedding format text. The outermost
135 //format text calls "on format end".
136 A68_FILE *file = FILE_DEREF (&ref_file);
137 NODE_T *dollar = SUB (BODY (&FORMAT (file)));
138 A68_FORMAT *save = (A68_FORMAT *) FRAME_LOCAL (A68_FP, OFFSET (TAX (dollar)));
139 if (IS_NIL_FORMAT (save)) {
140 // Not embedded, outermost format: execute event routine.
141 on_event_handler (p, FORMAT_END_MENDED (FILE_DEREF (&ref_file)), ref_file);
142 A68_BOOL z;
143 POP_OBJECT (p, &z, A68_BOOL);
144 if (VALUE (&z) == A68_FALSE) {
145 // Restart format.
146 A68_FP = FRAME_POINTER (file);
147 A68_SP = STACK_POINTER (file);
148 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_TRUE);
149 }
150 return NOT_EMBEDDED_FORMAT;
151 } else {
152 // Embedded format, return to embedding format, cf. RR.
153 CLOSE_FRAME;
154 FORMAT (file) = *save;
155 return EMBEDDED_FORMAT;
156 }
157 }
158
159 //! @brief Return integral value of replicator.
160
161 int get_replicator_value (NODE_T * p, BOOL_T check)
162 {
163 int z = 0;
164 if (IS (p, STATIC_REPLICATOR)) {
165 A68_INT u;
166 if (genie_string_to_value_internal (p, M_INT, NSYMBOL (p), (BYTE_T *) & u) == A68_FALSE) {
167 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_INT);
168 exit_genie (p, A68_RUNTIME_ERROR);
169 }
170 z = VALUE (&u);
171 } else if (IS (p, DYNAMIC_REPLICATOR)) {
172 A68_INT u;
173 GENIE_UNIT (NEXT_SUB (p));
174 POP_OBJECT (p, &u, A68_INT);
175 z = VALUE (&u);
176 } else if (IS (p, REPLICATOR)) {
177 z = get_replicator_value (SUB (p), check);
178 }
179 // Not conform RR as Andrew Herbert rightfully pointed out.
180 // if (check && z < 0) {
181 // diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INVALID_REPLICATOR);
182 // exit_genie (p, A68_RUNTIME_ERROR);
183 // }
184 if (z < 0) {
185 z = 0;
186 }
187 return z;
188 }
189
190 //! @brief Return first available pattern.
191
192 NODE_T *scan_format_pattern (NODE_T * p, A68_REF ref_file)
193 {
194 for (; p != NO_NODE; FORWARD (p)) {
195 if (IS (p, PICTURE_LIST)) {
196 NODE_T *prio = scan_format_pattern (SUB (p), ref_file);
197 if (prio != NO_NODE) {
198 return prio;
199 }
200 }
201 if (IS (p, PICTURE)) {
202 NODE_T *picture = SUB (p);
203 A68_COLLITEM *collitem = (A68_COLLITEM *) FRAME_LOCAL (A68_FP, OFFSET (TAX (p)));
204 if (COUNT (collitem) != 0) {
205 if (IS (picture, A68_PATTERN)) {
206 COUNT (collitem) = 0; // This pattern is now done
207 picture = SUB (picture);
208 if (ATTRIBUTE (picture) != FORMAT_PATTERN) {
209 return picture;
210 } else {
211 NODE_T *pat;
212 A68_FORMAT z;
213 A68_FILE *file = FILE_DEREF (&ref_file);
214 GENIE_UNIT (NEXT_SUB (picture));
215 POP_OBJECT (p, &z, A68_FORMAT);
216 open_format_frame (p, ref_file, &z, EMBEDDED_FORMAT, A68_TRUE);
217 pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
218 if (pat != NO_NODE) {
219 return pat;
220 } else {
221 (void) end_of_format (p, ref_file);
222 }
223 }
224 } else if (IS (picture, INSERTION)) {
225 A68_FILE *file = FILE_DEREF (&ref_file);
226 if (READ_MOOD (file)) {
227 read_insertion (picture, ref_file);
228 } else if (WRITE_MOOD (file)) {
229 write_insertion (picture, ref_file, INSERTION_NORMAL);
230 } else {
231 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
232 }
233 COUNT (collitem) = 0; // This insertion is now done
234 } else if (IS (picture, REPLICATOR) || IS (picture, COLLECTION)) {
235 BOOL_T siga = A68_TRUE;
236 NODE_T *a68_select = NO_NODE;
237 if (COUNT (collitem) == ITEM_NOT_USED) {
238 if (IS (picture, REPLICATOR)) {
239 COUNT (collitem) = get_replicator_value (SUB (p), A68_TRUE);
240 siga = (BOOL_T) (COUNT (collitem) > 0);
241 FORWARD (picture);
242 } else {
243 COUNT (collitem) = 1;
244 }
245 initialise_collitems (NEXT_SUB (picture));
246 } else if (IS (picture, REPLICATOR)) {
247 FORWARD (picture);
248 }
249 while (siga) {
250 // Get format item from collection. If collection is done, but repitition is not,
251 // then re-initialise the collection and repeat.
252 a68_select = scan_format_pattern (NEXT_SUB (picture), ref_file);
253 if (a68_select != NO_NODE) {
254 return a68_select;
255 } else {
256 COUNT (collitem)--;
257 siga = (BOOL_T) (COUNT (collitem) > 0);
258 if (siga) {
259 initialise_collitems (NEXT_SUB (picture));
260 }
261 }
262 }
263 }
264 }
265 }
266 }
267 return NO_NODE;
268 }
269
270 //! @brief Return first available pattern.
271
272 NODE_T *get_next_format_pattern (NODE_T * p, A68_REF ref_file, BOOL_T mood)
273 {
274 // "mood" can be WANT_PATTERN: pattern needed by caller, so perform end-of-format
275 // if needed or SKIP_PATTERN: just emptying current pattern/collection/format.
276 A68_FILE *file = FILE_DEREF (&ref_file);
277 if (BODY (&FORMAT (file)) == NO_NODE) {
278 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
279 exit_genie (p, A68_RUNTIME_ERROR);
280 return NO_NODE;
281 } else {
282 NODE_T *pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
283 if (pat == NO_NODE) {
284 if (mood == WANT_PATTERN) {
285 int z;
286 do {
287 z = end_of_format (p, ref_file);
288 pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file);
289 } while (z == EMBEDDED_FORMAT && pat == NO_NODE);
290 if (pat == NO_NODE) {
291 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
292 exit_genie (p, A68_RUNTIME_ERROR);
293 }
294 }
295 }
296 return pat;
297 }
298 }
299
300 //! @brief Diagnostic_node in case mode does not match picture.
301
302 void pattern_error (NODE_T * p, MOID_T * mode, int att)
303 {
304 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_CANNOT_TRANSPUT, mode, att);
305 exit_genie (p, A68_RUNTIME_ERROR);
306 }
307
308 //! @brief Unite value at top of stack to NUMBER.
309
310 void unite_to_number (NODE_T * p, MOID_T * mode, BYTE_T * item)
311 {
312 ADDR_T pop_sp = A68_SP;
313 PUSH_UNION (p, mode);
314 PUSH (p, item, (int) SIZE (mode));
315 A68_SP = pop_sp + SIZE (M_NUMBER);
316 }
317
318 //! @brief Write a group of insertions.
319
320 void write_insertion (NODE_T * p, A68_REF ref_file, MOOD_T mood)
321 {
322 for (; p != NO_NODE; FORWARD (p)) {
323 write_insertion (SUB (p), ref_file, mood);
324 if (IS (p, FORMAT_ITEM_L)) {
325 plusab_transput_buffer (p, FORMATTED_BUFFER, NEWLINE_CHAR);
326 write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
327 } else if (IS (p, FORMAT_ITEM_P)) {
328 plusab_transput_buffer (p, FORMATTED_BUFFER, FORMFEED_CHAR);
329 write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
330 } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
331 plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
332 } else if (IS (p, FORMAT_ITEM_Y)) {
333 PUSH_REF (p, ref_file);
334 PUSH_VALUE (p, -1, A68_INT);
335 genie_set (p);
336 } else if (IS (p, LITERAL)) {
337 if (mood & INSERTION_NORMAL) {
338 add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
339 } else if (mood & INSERTION_BLANK) {
340 int k = (int) strlen (NSYMBOL (p));
341 for (int j = 1; j <= k; j++) {
342 plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
343 }
344 }
345 } else if (IS (p, REPLICATOR)) {
346 int k = get_replicator_value (SUB (p), A68_TRUE);
347 if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
348 for (int j = 1; j <= k; j++) {
349 write_insertion (NEXT (p), ref_file, mood);
350 }
351 } else {
352 int pos = get_transput_buffer_index (FORMATTED_BUFFER);
353 for (int j = 1; j < (k - pos); j++) {
354 plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
355 }
356 }
357 return;
358 }
359 }
360 }
361
362 //! @brief Write string to file following current format.
363
364 void write_string_pattern (NODE_T * p, MOID_T * mode, A68_REF ref_file, char **str)
365 {
366 for (; p != NO_NODE; FORWARD (p)) {
367 if (IS (p, INSERTION)) {
368 write_insertion (SUB (p), ref_file, INSERTION_NORMAL);
369 } else if (IS (p, FORMAT_ITEM_A)) {
370 if ((*str)[0] != NULL_CHAR) {
371 plusab_transput_buffer (p, FORMATTED_BUFFER, (*str)[0]);
372 (*str)++;
373 } else {
374 value_error (p, mode, ref_file);
375 }
376 } else if (IS (p, FORMAT_ITEM_S)) {
377 if ((*str)[0] != NULL_CHAR) {
378 (*str)++;
379 } else {
380 value_error (p, mode, ref_file);
381 }
382 return;
383 } else if (IS (p, REPLICATOR)) {
384 int k = get_replicator_value (SUB (p), A68_TRUE);
385 for (int j = 1; j <= k; j++) {
386 write_string_pattern (NEXT (p), mode, ref_file, str);
387 }
388 return;
389 } else {
390 write_string_pattern (SUB (p), mode, ref_file, str);
391 }
392 }
393 }
394
395 //! @brief Scan c_pattern.
396
397 void scan_c_pattern (NODE_T * p, BOOL_T * right_align, BOOL_T * sign, int *width, int *after, int *letter)
398 {
399 if (IS (p, FORMAT_ITEM_ESCAPE)) {
400 FORWARD (p);
401 }
402 if (IS (p, FORMAT_ITEM_MINUS)) {
403 *right_align = A68_TRUE;
404 FORWARD (p);
405 } else {
406 *right_align = A68_FALSE;
407 }
408 if (IS (p, FORMAT_ITEM_PLUS)) {
409 *sign = A68_TRUE;
410 FORWARD (p);
411 } else {
412 *sign = A68_FALSE;
413 }
414 if (IS (p, REPLICATOR)) {
415 *width = get_replicator_value (SUB (p), A68_TRUE);
416 FORWARD (p);
417 }
418 if (IS (p, FORMAT_ITEM_POINT)) {
419 FORWARD (p);
420 }
421 if (IS (p, REPLICATOR)) {
422 *after = get_replicator_value (SUB (p), A68_TRUE);
423 FORWARD (p);
424 }
425 *letter = ATTRIBUTE (p);
426 }
427
428 //! @brief Write appropriate insertion from a choice pattern.
429
430 void write_choice_pattern (NODE_T * p, A68_REF ref_file, int *count)
431 {
432 for (; p != NO_NODE; FORWARD (p)) {
433 write_choice_pattern (SUB (p), ref_file, count);
434 if (IS (p, PICTURE)) {
435 (*count)--;
436 if (*count == 0) {
437 write_insertion (SUB (p), ref_file, INSERTION_NORMAL);
438 }
439 }
440 }
441 }
442
443 //! @brief Write appropriate insertion from a boolean pattern.
444
445 void write_boolean_pattern (NODE_T * p, A68_REF ref_file, BOOL_T z)
446 {
447 int k = (z ? 1 : 2);
448 write_choice_pattern (p, ref_file, &k);
449 }
450
451 //! @brief Write value according to a general pattern.
452
453 void write_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, int mod)
454 {
455 // Push arguments.
456 unite_to_number (p, mode, item);
457 GENIE_UNIT (NEXT_SUB (p));
458 A68_REF row;
459 POP_REF (p, &row);
460 A68_ARRAY *arr; A68_TUPLE *tup;
461 GET_DESCRIPTOR (arr, tup, &row);
462 int size = ROW_SIZE (tup);
463 if (size > 0) {
464 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
465 for (int i = LWB (tup); i <= UPB (tup); i++) {
466 int addr = INDEX_1_DIM (arr, tup, i);
467 int arg = VALUE ((A68_INT *) & (base_address[addr]));
468 PUSH_VALUE (p, arg, A68_INT);
469 }
470 }
471 // Make a string.
472 if (mod == FORMAT_ITEM_G) {
473 switch (size) {
474 case 1: {
475 genie_whole (p);
476 break;
477 }
478 case 2: {
479 genie_fixed (p);
480 break;
481 }
482 case 3: {
483 genie_float (p);
484 break;
485 }
486 default: {
487 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
488 exit_genie (p, A68_RUNTIME_ERROR);
489 break;
490 }
491 }
492 } else if (mod == FORMAT_ITEM_H) {
493 A68_INT a_width, a_after, a_expo, a_mult;
494 STATUS (&a_width) = INIT_MASK;
495 VALUE (&a_width) = 0;
496 STATUS (&a_after) = INIT_MASK;
497 VALUE (&a_after) = 0;
498 STATUS (&a_expo) = INIT_MASK;
499 VALUE (&a_expo) = 0;
500 STATUS (&a_mult) = INIT_MASK;
501 VALUE (&a_mult) = 0;
502 // Set default values
503 int def_expo = 0;
504 if (mode == M_REAL || mode == M_INT) {
505 def_expo = A68_EXP_WIDTH + 1;
506 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
507 def_expo = A68_LONG_EXP_WIDTH + 1;
508 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
509 def_expo = A68_LONG_LONG_EXP_WIDTH + 1;
510 }
511 int def_mult = 3;
512 // Pop user values
513 switch (size) {
514 case 1: {
515 POP_OBJECT (p, &a_after, A68_INT);
516 VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
517 VALUE (&a_expo) = def_expo;
518 VALUE (&a_mult) = def_mult;
519 break;
520 }
521 case 2: {
522 POP_OBJECT (p, &a_mult, A68_INT);
523 POP_OBJECT (p, &a_after, A68_INT);
524 VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
525 VALUE (&a_expo) = def_expo;
526 break;
527 }
528 case 3: {
529 POP_OBJECT (p, &a_mult, A68_INT);
530 POP_OBJECT (p, &a_after, A68_INT);
531 POP_OBJECT (p, &a_width, A68_INT);
532 VALUE (&a_expo) = def_expo;
533 break;
534 }
535 case 4: {
536 POP_OBJECT (p, &a_mult, A68_INT);
537 POP_OBJECT (p, &a_expo, A68_INT);
538 POP_OBJECT (p, &a_after, A68_INT);
539 POP_OBJECT (p, &a_width, A68_INT);
540 break;
541 }
542 default: {
543 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
544 exit_genie (p, A68_RUNTIME_ERROR);
545 break;
546 }
547 }
548 PUSH_VALUE (p, VALUE (&a_width), A68_INT);
549 PUSH_VALUE (p, VALUE (&a_after), A68_INT);
550 PUSH_VALUE (p, VALUE (&a_expo), A68_INT);
551 PUSH_VALUE (p, VALUE (&a_mult), A68_INT);
552 genie_real (p);
553 }
554 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
555 }
556
557 //! @brief Write %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.
558
559 void write_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
560 {
561 ADDR_T pop_sp = A68_SP;
562 BOOL_T right_align, sign, invalid;
563 int width = 0, after = 0, letter;
564 char *str = NO_TEXT;
565 char tmp[2]; // In same scope as str!
566 if (IS (p, CHAR_C_PATTERN)) {
567 A68_CHAR *z = (A68_CHAR *) item;
568 tmp[0] = (char) VALUE (z);
569 tmp[1] = NULL_CHAR;
570 str = (char *) &tmp;
571 width = (int) strlen (str);
572 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
573 } else if (IS (p, STRING_C_PATTERN)) {
574 str = (char *) item;
575 width = (int) strlen (str);
576 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
577 } else if (IS (p, INTEGRAL_C_PATTERN)) {
578 width = 0;
579 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
580 unite_to_number (p, mode, item);
581 PUSH_VALUE (p, (sign ? width : -width), A68_INT);
582 str = whole (p);
583 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
584 int att = ATTRIBUTE (p), expval = 0, expo = 0;
585 if (att == FLOAT_C_PATTERN || att == GENERAL_C_PATTERN) {
586 int digits = 0;
587 if (mode == M_REAL || mode == M_INT) {
588 width = A68_REAL_WIDTH + A68_EXP_WIDTH + 4;
589 after = A68_REAL_WIDTH - 1;
590 expo = A68_EXP_WIDTH + 1;
591 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
592 width = A68_LONG_REAL_WIDTH + A68_LONG_EXP_WIDTH + 4;
593 after = A68_LONG_REAL_WIDTH - 1;
594 expo = A68_LONG_EXP_WIDTH + 1;
595 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
596 width = A68_LONG_LONG_REAL_WIDTH + A68_LONG_LONG_EXP_WIDTH + 4;
597 after = A68_LONG_LONG_REAL_WIDTH - 1;
598 expo = A68_LONG_LONG_EXP_WIDTH + 1;
599 }
600 scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
601 if (digits == 0 && after > 0) {
602 width = after + expo + 4;
603 } else if (digits > 0) {
604 width = digits;
605 }
606 unite_to_number (p, mode, item);
607 PUSH_VALUE (p, (sign ? width : -width), A68_INT);
608 PUSH_VALUE (p, after, A68_INT);
609 PUSH_VALUE (p, expo, A68_INT);
610 PUSH_VALUE (p, 1, A68_INT);
611 str = real (p);
612 A68_SP = pop_sp;
613 }
614 if (att == GENERAL_C_PATTERN) {
615 char *expch = strchr (str, EXPONENT_CHAR);
616 if (expch != NO_TEXT) {
617 expval = (int) strtol (&(expch[1]), NO_VAR, 10);
618 }
619 }
620 if ((att == FIXED_C_PATTERN) || (att == GENERAL_C_PATTERN && (expval > -4 && expval <= after))) {
621 int digits = 0;
622 if (mode == M_REAL || mode == M_INT) {
623 width = A68_REAL_WIDTH + 2;
624 after = A68_REAL_WIDTH - 1;
625 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
626 width = A68_LONG_REAL_WIDTH + 2;
627 after = A68_LONG_REAL_WIDTH - 1;
628 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
629 width = A68_LONG_LONG_REAL_WIDTH + 2;
630 after = A68_LONG_LONG_REAL_WIDTH - 1;
631 }
632 scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
633 if (digits == 0 && after > 0) {
634 width = after + 2;
635 } else if (digits > 0) {
636 width = digits;
637 }
638 unite_to_number (p, mode, item);
639 PUSH_VALUE (p, (sign ? width : -width), A68_INT);
640 PUSH_VALUE (p, after, A68_INT);
641 str = fixed (p);
642 A68_SP = pop_sp;
643 }
644 } else if (IS (p, BITS_C_PATTERN)) {
645 int radix = 10, nibble = 1;
646 width = 0;
647 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
648 if (letter == FORMAT_ITEM_B) {
649 radix = 2;
650 nibble = 1;
651 } else if (letter == FORMAT_ITEM_O) {
652 radix = 8;
653 nibble = 3;
654 } else if (letter == FORMAT_ITEM_X) {
655 radix = 16;
656 nibble = 4;
657 }
658 if (width == 0) {
659 if (mode == M_BITS) {
660 width = (int) ceil ((REAL_T) A68_BITS_WIDTH / (REAL_T) nibble);
661 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
662 #if (A68_LEVEL <= 2)
663 width = (int) ceil ((REAL_T) get_mp_bits_width (mode) / (REAL_T) nibble);
664 #else
665 width = (int) ceil ((REAL_T) A68_LONG_BITS_WIDTH / (REAL_T) nibble);
666 #endif
667 }
668 }
669 if (mode == M_BITS) {
670 A68_BITS *z = (A68_BITS *) item;
671 reset_transput_buffer (EDIT_BUFFER);
672 if (!convert_radix (p, VALUE (z), radix, width)) {
673 errno = EDOM;
674 value_error (p, mode, ref_file);
675 }
676 str = get_transput_buffer (EDIT_BUFFER);
677 } else if (mode == M_LONG_BITS) {
678 #if (A68_LEVEL >= 3)
679 A68_LONG_BITS *z = (A68_LONG_BITS *) item;
680 reset_transput_buffer (EDIT_BUFFER);
681 if (!convert_radix_double (p, VALUE (z), radix, width)) {
682 errno = EDOM;
683 value_error (p, mode, ref_file);
684 }
685 str = get_transput_buffer (EDIT_BUFFER);
686 #else
687 int digits = DIGITS (mode);
688 MP_T *u = (MP_T *) item;
689 MP_T *v = nil_mp (p, digits);
690 MP_T *w = nil_mp (p, digits);
691 reset_transput_buffer (EDIT_BUFFER);
692 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
693 errno = EDOM;
694 value_error (p, mode, ref_file);
695 }
696 str = get_transput_buffer (EDIT_BUFFER);
697 #endif
698 } else if (mode == M_LONG_LONG_BITS) {
699 #if (A68_LEVEL <= 2)
700 int digits = DIGITS (mode);
701 MP_T *u = (MP_T *) item;
702 MP_T *v = nil_mp (p, digits);
703 MP_T *w = nil_mp (p, digits);
704 reset_transput_buffer (EDIT_BUFFER);
705 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
706 errno = EDOM;
707 value_error (p, mode, ref_file);
708 }
709 str = get_transput_buffer (EDIT_BUFFER);
710 #endif
711 }
712 }
713 // Did the conversion succeed?.
714 if (IS (p, CHAR_C_PATTERN) || IS (p, STRING_C_PATTERN)) {
715 invalid = A68_FALSE;
716 } else {
717 invalid = (strchr (str, ERROR_CHAR) != NO_TEXT);
718 }
719 if (invalid) {
720 value_error (p, mode, ref_file);
721 (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
722 } else {
723 // Align and output.
724 if (width == 0) {
725 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
726 } else {
727 if (right_align == A68_TRUE) {
728 while (str[0] == BLANK_CHAR) {
729 str++;
730 }
731 int blanks = width - (int) strlen (str);
732 if (blanks >= 0) {
733 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
734 while (blanks--) {
735 plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
736 }
737 } else {
738 value_error (p, mode, ref_file);
739 (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
740 }
741 } else {
742 while (str[0] == BLANK_CHAR) {
743 str++;
744 }
745 int blanks = width - (int) strlen (str);
746 if (blanks >= 0) {
747 while (blanks--) {
748 plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
749 }
750 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
751 } else {
752 value_error (p, mode, ref_file);
753 (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
754 }
755 }
756 }
757 }
758 }
759
760 //! @brief Read one char from file.
761
762 char read_single_char (NODE_T * p, A68_REF ref_file)
763 {
764 A68_FILE *file = FILE_DEREF (&ref_file);
765 int ch = char_scanner (file);
766 if (ch == EOF_CHAR) {
767 end_of_file_error (p, ref_file);
768 }
769 return (char) ch;
770 }
771
772 //! @brief Scan n chars from file to input buffer.
773
774 void scan_n_chars (NODE_T * p, int n, MOID_T * m, A68_REF ref_file)
775 {
776 (void) m;
777 for (int k = 0; k < n; k++) {
778 int ch = read_single_char (p, ref_file);
779 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
780 }
781 }
782
783 //! @brief Read %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.
784
785 void read_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
786 {
787 ADDR_T pop_sp = A68_SP;
788 BOOL_T right_align, sign;
789 int width, after, letter;
790 reset_transput_buffer (INPUT_BUFFER);
791 if (IS (p, CHAR_C_PATTERN)) {
792 width = 0;
793 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
794 if (width == 0) {
795 genie_read_standard (p, mode, item, ref_file);
796 } else {
797 scan_n_chars (p, width, mode, ref_file);
798 if (width > 1 && right_align == A68_FALSE) {
799 for (; width > 1; width--) {
800 (void) pop_char_transput_buffer (INPUT_BUFFER);
801 }
802 }
803 genie_string_to_value (p, mode, item, ref_file);
804 }
805 } else if (IS (p, STRING_C_PATTERN)) {
806 width = 0;
807 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
808 if (width == 0) {
809 genie_read_standard (p, mode, item, ref_file);
810 } else {
811 scan_n_chars (p, width, mode, ref_file);
812 genie_string_to_value (p, mode, item, ref_file);
813 }
814 } else if (IS (p, INTEGRAL_C_PATTERN)) {
815 if (mode != M_INT && mode != M_LONG_INT && mode != M_LONG_LONG_INT) {
816 pattern_error (p, mode, ATTRIBUTE (p));
817 } else {
818 width = 0;
819 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
820 if (width == 0) {
821 genie_read_standard (p, mode, item, ref_file);
822 } else {
823 scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
824 genie_string_to_value (p, mode, item, ref_file);
825 }
826 }
827 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
828 if (mode != M_REAL && mode != M_LONG_REAL && mode != M_LONG_LONG_REAL) {
829 pattern_error (p, mode, ATTRIBUTE (p));
830 } else {
831 width = 0;
832 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
833 if (width == 0) {
834 genie_read_standard (p, mode, item, ref_file);
835 } else {
836 scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
837 genie_string_to_value (p, mode, item, ref_file);
838 }
839 }
840 } else if (IS (p, BITS_C_PATTERN)) {
841 if (mode != M_BITS && mode != M_LONG_BITS && mode != M_LONG_LONG_BITS) {
842 pattern_error (p, mode, ATTRIBUTE (p));
843 } else {
844 int radix = 10;
845 char *str;
846 width = 0;
847 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
848 if (letter == FORMAT_ITEM_B) {
849 radix = 2;
850 } else if (letter == FORMAT_ITEM_O) {
851 radix = 8;
852 } else if (letter == FORMAT_ITEM_X) {
853 radix = 16;
854 }
855 str = get_transput_buffer (INPUT_BUFFER);
856 if (width == 0) {
857 A68_FILE *file = FILE_DEREF (&ref_file);
858 int ch;
859 ASSERT (a68_bufprt (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
860 set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str));
861 ch = char_scanner (file);
862 while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
863 if (IS_NL_FF (ch)) {
864 skip_nl_ff (p, &ch, ref_file);
865 } else {
866 ch = char_scanner (file);
867 }
868 }
869 while (ch != EOF_CHAR && IS_XDIGIT (ch)) {
870 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
871 ch = char_scanner (file);
872 }
873 unchar_scanner (p, file, (char) ch);
874 } else {
875 ASSERT (a68_bufprt (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
876 set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str));
877 scan_n_chars (p, width, mode, ref_file);
878 }
879 genie_string_to_value (p, mode, item, ref_file);
880 }
881 }
882 A68_SP = pop_sp;
883 }
884
885 // INTEGRAL, REAL, COMPLEX and BITS patterns.
886
887 //! @brief Count Z and D frames in a mould.
888
889 void count_zd_frames (NODE_T * p, int *z)
890 {
891 for (; p != NO_NODE; FORWARD (p)) {
892 if (IS (p, FORMAT_ITEM_D) || IS (p, FORMAT_ITEM_Z)) {
893 (*z)++;
894 } else if (IS (p, REPLICATOR)) {
895 int k = get_replicator_value (SUB (p), A68_TRUE);
896 for (int j = 1; j <= k; j++) {
897 count_zd_frames (NEXT (p), z);
898 }
899 return;
900 } else {
901 count_zd_frames (SUB (p), z);
902 }
903 }
904 }
905
906 //! @brief Get sign from sign mould.
907
908 NODE_T *get_sign (NODE_T * p)
909 {
910 for (; p != NO_NODE; FORWARD (p)) {
911 NODE_T *q = get_sign (SUB (p));
912 if (q != NO_NODE) {
913 return q;
914 } else if (IS (p, FORMAT_ITEM_PLUS) || IS (p, FORMAT_ITEM_MINUS)) {
915 return p;
916 }
917 }
918 return NO_NODE;
919 }
920
921 //! @brief Shift sign through Z frames until non-zero digit or D frame.
922
923 void shift_sign (NODE_T * p, char **q)
924 {
925 for (; p != NO_NODE && (*q) != NO_TEXT; FORWARD (p)) {
926 shift_sign (SUB (p), q);
927 if (IS (p, FORMAT_ITEM_Z)) {
928 if (((*q)[0] == '+' || (*q)[0] == '-') && (*q)[1] == '0') {
929 char ch = (*q)[0];
930 (*q)[0] = (*q)[1];
931 (*q)[1] = ch;
932 (*q)++;
933 }
934 } else if (IS (p, FORMAT_ITEM_D)) {
935 (*q) = NO_TEXT;
936 } else if (IS (p, REPLICATOR)) {
937 int k = get_replicator_value (SUB (p), A68_TRUE);
938 for (int j = 1; j <= k; j++) {
939 shift_sign (NEXT (p), q);
940 }
941 return;
942 }
943 }
944 }
945
946 //! @brief Pad trailing blanks to integral until desired width.
947
948 void put_zeroes_to_integral (NODE_T * p, int n)
949 {
950 for (; n > 0; n--) {
951 plusab_transput_buffer (p, EDIT_BUFFER, '0');
952 }
953 }
954
955 //! @brief Pad a sign to integral representation.
956
957 void put_sign_to_integral (NODE_T * p, int sign)
958 {
959 NODE_T *sign_node = get_sign (SUB (p));
960 if (IS (sign_node, FORMAT_ITEM_PLUS)) {
961 plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? '+' : '-'));
962 } else {
963 plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? BLANK_CHAR : '-'));
964 }
965 }
966
967 //! @brief Write point, exponent or plus-i-times symbol.
968
969 void write_pie_frame (NODE_T * p, A68_REF ref_file, int att, int sym)
970 {
971 for (; p != NO_NODE; FORWARD (p)) {
972 if (IS (p, INSERTION)) {
973 write_insertion (p, ref_file, INSERTION_NORMAL);
974 } else if (IS (p, att)) {
975 write_pie_frame (SUB (p), ref_file, att, sym);
976 return;
977 } else if (IS (p, sym)) {
978 add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
979 } else if (IS (p, FORMAT_ITEM_S)) {
980 return;
981 }
982 }
983 }
984
985 //! @brief Write sign when appropriate.
986
987 void write_mould_put_sign (NODE_T * p, char **q)
988 {
989 if ((*q)[0] == '+' || (*q)[0] == '-' || (*q)[0] == BLANK_CHAR) {
990 plusab_transput_buffer (p, FORMATTED_BUFFER, (*q)[0]);
991 (*q)++;
992 }
993 }
994
995 //! @brief Write character according to a mould.
996
997 void add_char_mould (NODE_T * p, char ch, char **q)
998 {
999 if (ch != NULL_CHAR) {
1000 plusab_transput_buffer (p, FORMATTED_BUFFER, ch);
1001 (*q)++;
1002 }
1003 }
1004
1005 //! @brief Write string according to a mould.
1006
1007 void write_mould (NODE_T * p, A68_REF ref_file, int type, char **q, MOOD_T * mood)
1008 {
1009 for (; p != NO_NODE; FORWARD (p)) {
1010 // Insertions are inserted straight away. Note that we can suppress them using "mood", which is not standard A68.
1011 if (IS (p, INSERTION)) {
1012 write_insertion (SUB (p), ref_file, *mood);
1013 } else {
1014 write_mould (SUB (p), ref_file, type, q, mood);
1015 // Z frames print blanks until first non-zero digits comes.
1016 if (IS (p, FORMAT_ITEM_Z)) {
1017 write_mould_put_sign (p, q);
1018 if ((*q)[0] == '0') {
1019 if (*mood & DIGIT_BLANK) {
1020 add_char_mould (p, BLANK_CHAR, q);
1021 *mood = (*mood & ~INSERTION_NORMAL) | INSERTION_BLANK;
1022 } else if (*mood & DIGIT_NORMAL) {
1023 add_char_mould (p, '0', q);
1024 *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1025 }
1026 } else {
1027 add_char_mould (p, (*q)[0], q);
1028 *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1029 }
1030 }
1031 // D frames print a digit.
1032 else if (IS (p, FORMAT_ITEM_D)) {
1033 write_mould_put_sign (p, q);
1034 add_char_mould (p, (*q)[0], q);
1035 *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1036 }
1037 // Suppressible frames.
1038 else if (IS (p, FORMAT_ITEM_S)) {
1039 // Suppressible frames are ignored in a sign-mould.
1040 if (type == SIGN_MOULD) {
1041 write_mould (NEXT (p), ref_file, type, q, mood);
1042 } else if (type == INTEGRAL_MOULD) {
1043 if ((*q)[0] != NULL_CHAR) {
1044 (*q)++;
1045 }
1046 }
1047 return;
1048 }
1049 // Replicator.
1050 else if (IS (p, REPLICATOR)) {
1051 int k = get_replicator_value (SUB (p), A68_TRUE);
1052 for (int j = 1; j <= k; j++) {
1053 write_mould (NEXT (p), ref_file, type, q, mood);
1054 }
1055 return;
1056 }
1057 }
1058 }
1059 }
1060
1061 //! @brief Write INT value using int pattern.
1062
1063 void write_integral_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file)
1064 {
1065 errno = 0;
1066 if (!(mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT)) {
1067 pattern_error (p, root, ATTRIBUTE (p));
1068 } else {
1069 ADDR_T pop_sp = A68_SP;
1070 char *str = "*";
1071 int width = 0, sign = 0;
1072 MOOD_T mood;
1073 // Dive into the pattern if needed.
1074 if (IS (p, INTEGRAL_PATTERN)) {
1075 p = SUB (p);
1076 }
1077 // Find width.
1078 count_zd_frames (p, &width);
1079 // Make string.
1080 reset_transput_buffer (EDIT_BUFFER);
1081 if (mode == M_INT) {
1082 A68_INT *z = (A68_INT *) item;
1083 sign = SIGN (VALUE (z));
1084 str = sub_whole (p, ABS (VALUE (z)), width);
1085 } else if (mode == M_LONG_INT) {
1086 #if (A68_LEVEL >= 3)
1087 A68_LONG_INT *z = (A68_LONG_INT *) item;
1088 DOUBLE_NUM_T w = VALUE (z);
1089 sign = sign_double_int (w);
1090 str = long_sub_whole_double (p, abs_double_int (w), width);
1091 #else
1092 MP_T *z = (MP_T *) item;
1093 sign = MP_SIGN (z);
1094 MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
1095 str = long_sub_whole (p, z, DIGITS (mode), width);
1096 #endif
1097 } else if (mode == M_LONG_LONG_INT) {
1098 MP_T *z = (MP_T *) item;
1099 sign = MP_SIGN (z);
1100 MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
1101 str = long_sub_whole (p, z, DIGITS (mode), width);
1102 }
1103 // Edit string and output.
1104 if (strchr (str, ERROR_CHAR) != NO_TEXT) {
1105 value_error (p, root, ref_file);
1106 }
1107 if (IS (p, SIGN_MOULD)) {
1108 put_sign_to_integral (p, sign);
1109 } else if (sign < 0) {
1110 value_sign_error (p, root, ref_file);
1111 }
1112 put_zeroes_to_integral (p, width - (int) strlen (str));
1113 add_string_transput_buffer (p, EDIT_BUFFER, str);
1114 str = get_transput_buffer (EDIT_BUFFER);
1115 mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1116 if (IS (p, SIGN_MOULD)) {
1117 if (str[0] == '+' || str[0] == '-') {
1118 shift_sign (SUB (p), &str);
1119 }
1120 str = get_transput_buffer (EDIT_BUFFER);
1121 write_mould (SUB (p), ref_file, SIGN_MOULD, &str, &mood);
1122 FORWARD (p);
1123 }
1124 if (IS (p, INTEGRAL_MOULD)) { // This *should* be the case
1125 write_mould (SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
1126 }
1127 A68_SP = pop_sp;
1128 }
1129 }
1130
1131 //! @brief Write REAL value using real pattern.
1132
1133 void write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file)
1134 {
1135 errno = 0;
1136 if (!(mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL || mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT)) {
1137 pattern_error (p, root, ATTRIBUTE (p));
1138 } else {
1139 ADDR_T pop_sp = A68_SP;
1140 int stag_digits = 0, frac_digits = 0, expo_digits = 0;
1141 int mant_length, sign = 0, exp_value;
1142 NODE_T *q, *sign_mould = NO_NODE, *stag_mould = NO_NODE, *point_frame = NO_NODE, *frac_mould = NO_NODE, *e_frame = NO_NODE, *expo_mould = NO_NODE;
1143 char *str = NO_TEXT, *stag_str = NO_TEXT, *frac_str = NO_TEXT;
1144 MOOD_T mood;
1145 // Dive into pattern.
1146 q = ((IS (p, REAL_PATTERN)) ? SUB (p) : p);
1147 // Dissect pattern and establish widths.
1148 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
1149 sign_mould = q;
1150 count_zd_frames (SUB (sign_mould), &stag_digits);
1151 FORWARD (q);
1152 }
1153 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
1154 stag_mould = q;
1155 count_zd_frames (SUB (stag_mould), &stag_digits);
1156 FORWARD (q);
1157 }
1158 if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
1159 point_frame = q;
1160 FORWARD (q);
1161 }
1162 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
1163 frac_mould = q;
1164 count_zd_frames (SUB (frac_mould), &frac_digits);
1165 FORWARD (q);
1166 }
1167 if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
1168 e_frame = SUB (q);
1169 expo_mould = NEXT_SUB (q);
1170 q = expo_mould;
1171 if (IS (q, SIGN_MOULD)) {
1172 count_zd_frames (SUB (q), &expo_digits);
1173 FORWARD (q);
1174 }
1175 if (IS (q, INTEGRAL_MOULD)) {
1176 count_zd_frames (SUB (q), &expo_digits);
1177 }
1178 }
1179 // Make string representation.
1180 if (point_frame == NO_NODE) {
1181 mant_length = stag_digits;
1182 } else {
1183 mant_length = 1 + stag_digits + frac_digits;
1184 }
1185 if (mode == M_REAL || mode == M_INT) {
1186 REAL_T x;
1187 if (mode == M_REAL) {
1188 x = VALUE ((A68_REAL *) item);
1189 } else {
1190 x = (REAL_T) VALUE ((A68_INT *) item);
1191 }
1192 CHECK_REAL (p, x);
1193 exp_value = 0;
1194 sign = SIGN (x);
1195 if (sign_mould != NO_NODE) {
1196 put_sign_to_integral (sign_mould, sign);
1197 }
1198 x = ABS (x);
1199 if (expo_mould != NO_NODE) {
1200 standardise (&x, stag_digits, frac_digits, &exp_value);
1201 }
1202 str = sub_fixed (p, x, mant_length, frac_digits);
1203 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
1204 #if (A68_LEVEL >= 3)
1205 DOUBLE_NUM_T x = VALUE ((A68_DOUBLE *) item);
1206 if (mode == M_LONG_INT) {
1207 x = double_int_to_double (p, x);
1208 }
1209 CHECK_DOUBLE_REAL (p, x.f);
1210 exp_value = 0;
1211 sign = sign_double (x);
1212 if (sign_mould != NO_NODE) {
1213 put_sign_to_integral (sign_mould, sign);
1214 }
1215 x.f = fabs_double (x.f);
1216 if (expo_mould != NO_NODE) {
1217 standardise_double (&(x.f), stag_digits, frac_digits, &exp_value);
1218 }
1219 str = sub_fixed_double (p, x.f, mant_length, frac_digits, A68_LONG_REAL_WIDTH);
1220 #else
1221 ADDR_T pop_sp2 = A68_SP;
1222 int digits = DIGITS (mode);
1223 MP_T *x = nil_mp (p, digits);
1224 (void) move_mp (x, (MP_T *) item, digits);
1225 exp_value = 0;
1226 sign = SIGN (x[2]);
1227 if (sign_mould != NO_NODE) {
1228 put_sign_to_integral (sign_mould, sign);
1229 }
1230 x[2] = ABS (x[2]);
1231 if (expo_mould != NO_NODE) {
1232 long_standardise (p, x, DIGITS (mode), stag_digits, frac_digits, &exp_value);
1233 }
1234 str = long_sub_fixed (p, x, DIGITS (mode), mant_length, frac_digits);
1235 A68_SP = pop_sp2;
1236 #endif
1237 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
1238 ADDR_T pop_sp2 = A68_SP;
1239 int digits = DIGITS (mode);
1240 MP_T *x = nil_mp (p, digits);
1241 (void) move_mp (x, (MP_T *) item, digits);
1242 exp_value = 0;
1243 sign = SIGN (x[2]);
1244 if (sign_mould != NO_NODE) {
1245 put_sign_to_integral (sign_mould, sign);
1246 }
1247 x[2] = ABS (x[2]);
1248 if (expo_mould != NO_NODE) {
1249 long_standardise (p, x, DIGITS (mode), stag_digits, frac_digits, &exp_value);
1250 }
1251 str = long_sub_fixed (p, x, DIGITS (mode), mant_length, frac_digits);
1252 A68_SP = pop_sp2;
1253 }
1254 // Edit and output the string.
1255 if (strchr (str, ERROR_CHAR) != NO_TEXT) {
1256 value_error (p, root, ref_file);
1257 }
1258 reset_transput_buffer (STRING_BUFFER);
1259 add_string_transput_buffer (p, STRING_BUFFER, str);
1260 stag_str = get_transput_buffer (STRING_BUFFER);
1261 if (strchr (stag_str, ERROR_CHAR) != NO_TEXT) {
1262 value_error (p, root, ref_file);
1263 }
1264 str = strchr (stag_str, POINT_CHAR);
1265 if (str != NO_TEXT) {
1266 frac_str = &str[1];
1267 str[0] = NULL_CHAR;
1268 } else {
1269 frac_str = NO_TEXT;
1270 }
1271 // Stagnant part.
1272 reset_transput_buffer (EDIT_BUFFER);
1273 if (sign_mould != NO_NODE) {
1274 put_sign_to_integral (sign_mould, sign);
1275 } else if (sign < 0) {
1276 value_sign_error (sign_mould, root, ref_file);
1277 }
1278 put_zeroes_to_integral (p, stag_digits - (int) strlen (stag_str));
1279 add_string_transput_buffer (p, EDIT_BUFFER, stag_str);
1280 stag_str = get_transput_buffer (EDIT_BUFFER);
1281 mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1282 if (sign_mould != NO_NODE) {
1283 if (stag_str[0] == '+' || stag_str[0] == '-') {
1284 shift_sign (SUB (p), &stag_str);
1285 }
1286 stag_str = get_transput_buffer (EDIT_BUFFER);
1287 write_mould (SUB (sign_mould), ref_file, SIGN_MOULD, &stag_str, &mood);
1288 }
1289 if (stag_mould != NO_NODE) {
1290 write_mould (SUB (stag_mould), ref_file, INTEGRAL_MOULD, &stag_str, &mood);
1291 }
1292 // Point frame.
1293 if (point_frame != NO_NODE) {
1294 write_pie_frame (point_frame, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT);
1295 }
1296 // Fraction.
1297 if (frac_mould != NO_NODE) {
1298 reset_transput_buffer (EDIT_BUFFER);
1299 add_string_transput_buffer (p, EDIT_BUFFER, frac_str);
1300 frac_str = get_transput_buffer (EDIT_BUFFER);
1301 mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1302 write_mould (SUB (frac_mould), ref_file, INTEGRAL_MOULD, &frac_str, &mood);
1303 }
1304 // Exponent.
1305 if (expo_mould != NO_NODE) {
1306 A68_INT z;
1307 STATUS (&z) = INIT_MASK;
1308 VALUE (&z) = exp_value;
1309 if (e_frame != NO_NODE) {
1310 write_pie_frame (e_frame, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E);
1311 }
1312 write_integral_pattern (expo_mould, M_INT, root, (BYTE_T *) & z, ref_file);
1313 }
1314 A68_SP = pop_sp;
1315 }
1316 }
1317
1318 //! @brief Write COMPLEX value using complex pattern.
1319
1320 void write_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * root, BYTE_T * re, BYTE_T * im, A68_REF ref_file)
1321 {
1322 errno = 0;
1323 // Dissect pattern.
1324 NODE_T *reel = SUB (p);
1325 NODE_T *plus_i_times = NEXT (reel);
1326 NODE_T *imag = NEXT (plus_i_times);
1327 // Write pattern.
1328 write_real_pattern (reel, comp, root, re, ref_file);
1329 write_pie_frame (plus_i_times, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I);
1330 write_real_pattern (imag, comp, root, im, ref_file);
1331 }
1332
1333 //! @brief Write BITS value using bits pattern.
1334
1335 void write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
1336 {
1337 ADDR_T pop_sp = A68_SP;
1338 int width = 0, radix;
1339 char *str;
1340 if (mode == M_BITS) {
1341 A68_BITS *z = (A68_BITS *) item;
1342 // Establish width and radix.
1343 count_zd_frames (SUB (p), &width);
1344 radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
1345 if (radix < 2 || radix > 16) {
1346 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1347 exit_genie (p, A68_RUNTIME_ERROR);
1348 }
1349 // Generate string of correct width.
1350 reset_transput_buffer (EDIT_BUFFER);
1351 if (!convert_radix (p, VALUE (z), radix, width)) {
1352 errno = EDOM;
1353 value_error (p, mode, ref_file);
1354 }
1355 } else if (mode == M_LONG_BITS) {
1356 #if (A68_LEVEL >= 3)
1357 A68_LONG_BITS *z = (A68_LONG_BITS *) item;
1358 // Establish width and radix.
1359 count_zd_frames (SUB (p), &width);
1360 radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
1361 if (radix < 2 || radix > 16) {
1362 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1363 exit_genie (p, A68_RUNTIME_ERROR);
1364 }
1365 // Generate string of correct width.
1366 reset_transput_buffer (EDIT_BUFFER);
1367 if (!convert_radix_double (p, VALUE (z), radix, width)) {
1368 errno = EDOM;
1369 value_error (p, mode, ref_file);
1370 }
1371 #else
1372 int digits = DIGITS (mode);
1373 MP_T *u = (MP_T *) item;
1374 MP_T *v = nil_mp (p, digits);
1375 MP_T *w = nil_mp (p, digits);
1376 // Establish width and radix.
1377 count_zd_frames (SUB (p), &width);
1378 radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
1379 if (radix < 2 || radix > 16) {
1380 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1381 exit_genie (p, A68_RUNTIME_ERROR);
1382 }
1383 // Generate string of correct width.
1384 reset_transput_buffer (EDIT_BUFFER);
1385 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
1386 errno = EDOM;
1387 value_error (p, mode, ref_file);
1388 }
1389 #endif
1390 } else if (mode == M_LONG_LONG_BITS) {
1391 #if (A68_LEVEL <= 2)
1392 int digits = DIGITS (mode);
1393 MP_T *u = (MP_T *) item;
1394 MP_T *v = nil_mp (p, digits);
1395 MP_T *w = nil_mp (p, digits);
1396 // Establish width and radix.
1397 count_zd_frames (SUB (p), &width);
1398 radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
1399 if (radix < 2 || radix > 16) {
1400 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1401 exit_genie (p, A68_RUNTIME_ERROR);
1402 }
1403 // Generate string of correct width.
1404 reset_transput_buffer (EDIT_BUFFER);
1405 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
1406 errno = EDOM;
1407 value_error (p, mode, ref_file);
1408 }
1409 #endif
1410 }
1411 // Output the edited string.
1412 MOOD_T mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1413 str = get_transput_buffer (EDIT_BUFFER);
1414 write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
1415 A68_SP = pop_sp;
1416 }
1417
1418 //! @brief Write value to file.
1419
1420 void genie_write_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
1421 {
1422 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1423 genie_value_to_string (p, M_REAL, item, ATTRIBUTE (SUB (p)));
1424 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1425 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1426 write_number_generic (p, M_REAL, item, ATTRIBUTE (SUB (p)));
1427 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1428 write_c_pattern (p, M_REAL, item, ref_file);
1429 } else if (IS (p, REAL_PATTERN)) {
1430 write_real_pattern (p, M_REAL, M_REAL, item, ref_file);
1431 } else if (IS (p, COMPLEX_PATTERN)) {
1432 A68_REAL im;
1433 STATUS (&im) = INIT_MASK;
1434 VALUE (&im) = 0.0;
1435 write_complex_pattern (p, M_REAL, M_COMPLEX, (BYTE_T *) item, (BYTE_T *) & im, ref_file);
1436 } else {
1437 pattern_error (p, M_REAL, ATTRIBUTE (p));
1438 }
1439 }
1440
1441 //! @brief Write value to file.
1442
1443 void genie_write_long_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
1444 {
1445 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1446 genie_value_to_string (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1447 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1448 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1449 write_number_generic (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1450 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1451 write_c_pattern (p, M_LONG_REAL, item, ref_file);
1452 } else if (IS (p, REAL_PATTERN)) {
1453 write_real_pattern (p, M_LONG_REAL, M_LONG_REAL, item, ref_file);
1454 } else if (IS (p, COMPLEX_PATTERN)) {
1455 #if (A68_LEVEL >= 3)
1456 ADDR_T pop_sp = A68_SP;
1457 A68_LONG_REAL *z = (A68_LONG_REAL *) STACK_TOP;
1458 DOUBLE_NUM_T im;
1459 im.f = 0.0q;
1460 PUSH_VALUE (p, im, A68_LONG_REAL);
1461 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1462 A68_SP = pop_sp;
1463 #else
1464 ADDR_T pop_sp = A68_SP;
1465 MP_T *z = nil_mp (p, DIGITS (M_LONG_REAL));
1466 z[0] = (MP_T) INIT_MASK;
1467 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1468 A68_SP = pop_sp;
1469 #endif
1470 } else {
1471 pattern_error (p, M_LONG_REAL, ATTRIBUTE (p));
1472 }
1473 }
1474
1475 //! @brief Write value to file.
1476
1477 void genie_write_long_mp_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file)
1478 {
1479 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1480 genie_value_to_string (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1481 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1482 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1483 write_number_generic (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1484 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1485 write_c_pattern (p, M_LONG_LONG_REAL, item, ref_file);
1486 } else if (IS (p, REAL_PATTERN)) {
1487 write_real_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_REAL, item, ref_file);
1488 } else if (IS (p, COMPLEX_PATTERN)) {
1489 ADDR_T pop_sp = A68_SP;
1490 MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
1491 z[0] = (MP_T) INIT_MASK;
1492 write_complex_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1493 A68_SP = pop_sp;
1494 } else {
1495 pattern_error (p, M_LONG_LONG_REAL, ATTRIBUTE (p));
1496 }
1497 }
1498
1499 //! @brief At end of write purge all insertions.
1500
1501 void purge_format_write (NODE_T * p, A68_REF ref_file)
1502 {
1503 // Problem here is shutting down embedded formats.
1504 BOOL_T siga;
1505 do {
1506 A68_FILE *file;
1507 NODE_T *dollar, *pat;
1508 A68_FORMAT *old_fmt;
1509 while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
1510 format_error (p, ref_file, ERROR_FORMAT_PICTURES);
1511 }
1512 file = FILE_DEREF (&ref_file);
1513 dollar = SUB (BODY (&FORMAT (file)));
1514 old_fmt = (A68_FORMAT *) FRAME_LOCAL (A68_FP, OFFSET (TAX (dollar)));
1515 siga = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
1516 if (siga) {
1517 // Pop embedded format and proceed.
1518 (void) end_of_format (p, ref_file);
1519 }
1520 } while (siga);
1521 }
1522
1523 //! @brief Write value to file.
1524
1525 void genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file, int *formats)
1526 {
1527 errno = 0;
1528 ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1529 if (mode == M_FORMAT) {
1530 A68_FILE *file;
1531 CHECK_REF (p, ref_file, M_REF_FILE);
1532 file = FILE_DEREF (&ref_file);
1533 // Forget about eventual active formats and set up new one.
1534 if (*formats > 0) {
1535 purge_format_write (p, ref_file);
1536 }
1537 (*formats)++;
1538 A68_FP = FRAME_POINTER (file);
1539 A68_SP = STACK_POINTER (file);
1540 open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE);
1541 } else if (mode == M_PROC_REF_FILE_VOID) {
1542 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
1543 exit_genie (p, A68_RUNTIME_ERROR);
1544 } else if (mode == M_SOUND) {
1545 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_SOUND);
1546 exit_genie (p, A68_RUNTIME_ERROR);
1547 } else if (mode == M_INT) {
1548 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1549 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1550 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1551 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1552 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1553 write_number_generic (pat, M_INT, item, ATTRIBUTE (SUB (pat)));
1554 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1555 write_c_pattern (pat, M_INT, item, ref_file);
1556 } else if (IS (pat, INTEGRAL_PATTERN)) {
1557 write_integral_pattern (pat, M_INT, M_INT, item, ref_file);
1558 } else if (IS (pat, REAL_PATTERN)) {
1559 write_real_pattern (pat, M_INT, M_INT, item, ref_file);
1560 } else if (IS (pat, COMPLEX_PATTERN)) {
1561 A68_REAL re, im;
1562 STATUS (&re) = INIT_MASK;
1563 VALUE (&re) = (REAL_T) VALUE ((A68_INT *) item);
1564 STATUS (&im) = INIT_MASK;
1565 VALUE (&im) = 0.0;
1566 write_complex_pattern (pat, M_REAL, M_COMPLEX, (BYTE_T *) & re, (BYTE_T *) & im, ref_file);
1567 } else if (IS (pat, CHOICE_PATTERN)) {
1568 int k = VALUE ((A68_INT *) item);
1569 write_choice_pattern (NEXT_SUB (pat), ref_file, &k);
1570 } else {
1571 pattern_error (p, mode, ATTRIBUTE (pat));
1572 }
1573 } else if (mode == M_LONG_INT) {
1574 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1575 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1576 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1577 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1578 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1579 write_number_generic (pat, M_LONG_INT, item, ATTRIBUTE (SUB (pat)));
1580 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1581 write_c_pattern (pat, M_LONG_INT, item, ref_file);
1582 } else if (IS (pat, INTEGRAL_PATTERN)) {
1583 write_integral_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
1584 } else if (IS (pat, REAL_PATTERN)) {
1585 write_real_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
1586 } else if (IS (pat, COMPLEX_PATTERN)) {
1587 #if (A68_LEVEL >= 3)
1588 ADDR_T pop_sp = A68_SP;
1589 A68_LONG_REAL *z = (A68_LONG_REAL *) STACK_TOP;
1590 DOUBLE_NUM_T im;
1591 im.f = 0.0q;
1592 PUSH_VALUE (p, im, A68_LONG_REAL);
1593 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1594 A68_SP = pop_sp;
1595 #else
1596 ADDR_T pop_sp = A68_SP;
1597 MP_T *z = nil_mp (p, DIGITS (mode));
1598 z[0] = (MP_T) INIT_MASK;
1599 write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1600 A68_SP = pop_sp;
1601 #endif
1602 } else if (IS (pat, CHOICE_PATTERN)) {
1603 INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
1604 int sk;
1605 CHECK_INT_SHORTEN (p, k);
1606 sk = (int) k;
1607 write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
1608 } else {
1609 pattern_error (p, mode, ATTRIBUTE (pat));
1610 }
1611 } else if (mode == M_LONG_LONG_INT) {
1612 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1613 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1614 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1615 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1616 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1617 write_number_generic (pat, M_LONG_LONG_INT, item, ATTRIBUTE (SUB (pat)));
1618 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1619 write_c_pattern (pat, M_LONG_LONG_INT, item, ref_file);
1620 } else if (IS (pat, INTEGRAL_PATTERN)) {
1621 write_integral_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
1622 } else if (IS (pat, REAL_PATTERN)) {
1623 write_real_pattern (pat, M_INT, M_INT, item, ref_file);
1624 } else if (IS (pat, REAL_PATTERN)) {
1625 write_real_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
1626 } else if (IS (pat, COMPLEX_PATTERN)) {
1627 ADDR_T pop_sp = A68_SP;
1628 MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
1629 z[0] = (MP_T) INIT_MASK;
1630 write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1631 A68_SP = pop_sp;
1632 } else if (IS (pat, CHOICE_PATTERN)) {
1633 INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
1634 int sk;
1635 CHECK_INT_SHORTEN (p, k);
1636 sk = (int) k;
1637 write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
1638 } else {
1639 pattern_error (p, mode, ATTRIBUTE (pat));
1640 }
1641 } else if (mode == M_REAL) {
1642 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1643 genie_write_real_format (pat, item, ref_file);
1644 } else if (mode == M_LONG_REAL) {
1645 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1646 genie_write_long_real_format (pat, item, ref_file);
1647 } else if (mode == M_LONG_LONG_REAL) {
1648 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1649 genie_write_long_mp_real_format (pat, item, ref_file);
1650 } else if (mode == M_COMPLEX) {
1651 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1652 if (IS (pat, COMPLEX_PATTERN)) {
1653 write_complex_pattern (pat, M_REAL, M_COMPLEX, &item[0], &item[SIZE (M_REAL)], ref_file);
1654 } else {
1655 // Try writing as two REAL values.
1656 genie_write_real_format (pat, item, ref_file);
1657 genie_write_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
1658 }
1659 } else if (mode == M_LONG_COMPLEX) {
1660 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1661 if (IS (pat, COMPLEX_PATTERN)) {
1662 write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_REAL)], ref_file);
1663 } else {
1664 // Try writing as two LONG REAL values.
1665 genie_write_long_real_format (pat, item, ref_file);
1666 genie_write_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
1667 }
1668 } else if (mode == M_LONG_LONG_COMPLEX) {
1669 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1670 if (IS (pat, COMPLEX_PATTERN)) {
1671 write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_LONG_REAL)], ref_file);
1672 } else {
1673 // Try writing as two LONG LONG REAL values.
1674 genie_write_long_mp_real_format (pat, item, ref_file);
1675 genie_write_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
1676 }
1677 } else if (mode == M_BOOL) {
1678 A68_BOOL *z = (A68_BOOL *) item;
1679 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1680 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1681 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR));
1682 } else if (IS (pat, BOOLEAN_PATTERN)) {
1683 if (NEXT_SUB (pat) == NO_NODE) {
1684 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR));
1685 } else {
1686 write_boolean_pattern (pat, ref_file, (BOOL_T) (VALUE (z) == A68_TRUE));
1687 }
1688 } else {
1689 pattern_error (p, mode, ATTRIBUTE (pat));
1690 }
1691 } else if (mode == M_BITS) {
1692 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1693 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1694 char *str = (char *) STACK_TOP;
1695 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
1696 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
1697 } else if (IS (pat, BITS_PATTERN)) {
1698 write_bits_pattern (pat, M_BITS, item, ref_file);
1699 } else if (IS (pat, BITS_C_PATTERN)) {
1700 write_c_pattern (pat, M_BITS, item, ref_file);
1701 } else {
1702 pattern_error (p, mode, ATTRIBUTE (pat));
1703 }
1704 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
1705 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1706 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1707 char *str = (char *) STACK_TOP;
1708 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
1709 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
1710 } else if (IS (pat, BITS_PATTERN)) {
1711 write_bits_pattern (pat, mode, item, ref_file);
1712 } else if (IS (pat, BITS_C_PATTERN)) {
1713 write_c_pattern (pat, mode, item, ref_file);
1714 } else {
1715 pattern_error (p, mode, ATTRIBUTE (pat));
1716 }
1717 } else if (mode == M_CHAR) {
1718 A68_CHAR *z = (A68_CHAR *) item;
1719 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1720 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1721 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) VALUE (z));
1722 } else if (IS (pat, STRING_PATTERN)) {
1723 char *q = get_transput_buffer (EDIT_BUFFER);
1724 reset_transput_buffer (EDIT_BUFFER);
1725 plusab_transput_buffer (p, EDIT_BUFFER, (char) VALUE (z));
1726 write_string_pattern (pat, mode, ref_file, &q);
1727 if (q[0] != NULL_CHAR) {
1728 value_error (p, mode, ref_file);
1729 }
1730 } else if (IS (pat, STRING_C_PATTERN)) {
1731 char zz[2];
1732 zz[0] = VALUE (z);
1733 zz[1] = '\0';
1734 (void) c_to_a_string (pat, zz, 1);
1735 write_c_pattern (pat, mode, (BYTE_T *) zz, ref_file);
1736 } else {
1737 pattern_error (p, mode, ATTRIBUTE (pat));
1738 }
1739 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1740 // Handle these separately instead of printing [] CHAR.
1741 A68_REF row = *(A68_REF *) item;
1742 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1743 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1744 PUSH_REF (p, row);
1745 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1746 } else if (IS (pat, STRING_PATTERN)) {
1747 char *q;
1748 PUSH_REF (p, row);
1749 reset_transput_buffer (EDIT_BUFFER);
1750 add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
1751 q = get_transput_buffer (EDIT_BUFFER);
1752 write_string_pattern (pat, mode, ref_file, &q);
1753 if (q[0] != NULL_CHAR) {
1754 value_error (p, mode, ref_file);
1755 }
1756 } else if (IS (pat, STRING_C_PATTERN)) {
1757 char *q;
1758 PUSH_REF (p, row);
1759 reset_transput_buffer (EDIT_BUFFER);
1760 add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
1761 q = get_transput_buffer (EDIT_BUFFER);
1762 write_c_pattern (pat, mode, (BYTE_T *) q, ref_file);
1763 } else {
1764 pattern_error (p, mode, ATTRIBUTE (pat));
1765 }
1766 } else if (IS_UNION (mode)) {
1767 A68_UNION *z = (A68_UNION *) item;
1768 genie_write_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file, formats);
1769 } else if (IS_STRUCT (mode)) {
1770 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1771 BYTE_T *elem = &item[OFFSET (q)];
1772 genie_check_initialisation (p, elem, MOID (q));
1773 genie_write_standard_format (p, MOID (q), elem, ref_file, formats);
1774 }
1775 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1776 MOID_T *deflexed = DEFLEX (mode);
1777 CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
1778 A68_ARRAY *arr; A68_TUPLE *tup;
1779 GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
1780 if (get_row_size (tup, DIM (arr)) > 0) {
1781 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1782 BOOL_T done = A68_FALSE;
1783 initialise_internal_index (tup, DIM (arr));
1784 while (!done) {
1785 ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
1786 ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
1787 BYTE_T *elem = &base_addr[elem_addr];
1788 genie_check_initialisation (p, elem, SUB (deflexed));
1789 genie_write_standard_format (p, SUB (deflexed), elem, ref_file, formats);
1790 done = increment_internal_index (tup, DIM (arr));
1791 }
1792 }
1793 }
1794 if (errno != 0) {
1795 transput_error (p, ref_file, mode);
1796 }
1797 }
1798
1799 //! @brief PROC ([] SIMPLOUT) VOID print f, write f
1800
1801 void genie_write_format (NODE_T * p)
1802 {
1803 A68_REF row;
1804 POP_REF (p, &row);
1805 genie_stand_out (p);
1806 PUSH_REF (p, row);
1807 genie_write_file_format (p);
1808 }
1809
1810 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put f
1811
1812 void genie_write_file_format (NODE_T * p)
1813 {
1814 A68_REF row;
1815 POP_REF (p, &row);
1816 CHECK_REF (p, row, M_ROW_SIMPLOUT);
1817 A68_ARRAY *arr; A68_TUPLE *tup;
1818 GET_DESCRIPTOR (arr, tup, &row);
1819 int elems = ROW_SIZE (tup);
1820 A68_REF ref_file;
1821 POP_REF (p, &ref_file);
1822 CHECK_REF (p, ref_file, M_REF_FILE);
1823 A68_FILE *file = FILE_DEREF (&ref_file);
1824 CHECK_INIT (p, INITIALISED (file), M_FILE);
1825 if (!OPENED (file)) {
1826 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1827 exit_genie (p, A68_RUNTIME_ERROR);
1828 }
1829 if (DRAW_MOOD (file)) {
1830 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1831 exit_genie (p, A68_RUNTIME_ERROR);
1832 }
1833 if (READ_MOOD (file)) {
1834 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1835 exit_genie (p, A68_RUNTIME_ERROR);
1836 }
1837 if (!PUT (&CHANNEL (file))) {
1838 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1839 exit_genie (p, A68_RUNTIME_ERROR);
1840 }
1841 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1842 if (IS_NIL (STRING (file))) {
1843 if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILE) {
1844 open_error (p, ref_file, "putting");
1845 }
1846 } else {
1847 FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, 0);
1848 }
1849 DRAW_MOOD (file) = A68_FALSE;
1850 READ_MOOD (file) = A68_FALSE;
1851 WRITE_MOOD (file) = A68_TRUE;
1852 CHAR_MOOD (file) = A68_TRUE;
1853 }
1854 if (!CHAR_MOOD (file)) {
1855 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
1856 exit_genie (p, A68_RUNTIME_ERROR);
1857 }
1858 // Save stack state since formats have frames.
1859 ADDR_T pop_fp = FRAME_POINTER (file), pop_sp = STACK_POINTER (file);
1860 FRAME_POINTER (file) = A68_FP;
1861 STACK_POINTER (file) = A68_SP;
1862 // Process [] SIMPLOUT.
1863 if (BODY (&FORMAT (file)) != NO_NODE) {
1864 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
1865 }
1866 if (elems <= 0) {
1867 return;
1868 }
1869 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1870 int elem_index = 0, formats = 0;
1871 for (int k = 0; k < elems; k++) {
1872 A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
1873 MOID_T *mode = (MOID_T *) (VALUE (z));
1874 BYTE_T *item = &(base_address[elem_index + A68_UNION_SIZE]);
1875 genie_write_standard_format (p, mode, item, ref_file, &formats);
1876 elem_index += SIZE (M_SIMPLOUT);
1877 }
1878 // Empty the format to purge insertions.
1879 purge_format_write (p, ref_file);
1880 BODY (&FORMAT (file)) = NO_NODE;
1881 // Dump the buffer.
1882 write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
1883 // Forget about active formats.
1884 A68_FP = FRAME_POINTER (file);
1885 A68_SP = STACK_POINTER (file);
1886 FRAME_POINTER (file) = pop_fp;
1887 STACK_POINTER (file) = pop_sp;
1888 }
1889
1890 //! @brief Give a value error in case a character is not among expected ones.
1891
1892 BOOL_T expect (NODE_T * p, MOID_T * m, A68_REF ref_file, const char *items, char ch)
1893 {
1894 if (strchr ((char *) items, ch) == NO_TEXT) {
1895 value_error (p, m, ref_file);
1896 return A68_FALSE;
1897 } else {
1898 return A68_TRUE;
1899 }
1900 }
1901
1902 //! @brief Read a group of insertions.
1903
1904 void read_insertion (NODE_T * p, A68_REF ref_file)
1905 {
1906
1907 // Algol68G does not check whether the insertions are textually there. It just
1908 // skips them. This because we blank literals in sign moulds before the sign is
1909 // put, which is non-standard Algol68, but convenient.
1910
1911 A68_FILE *file = FILE_DEREF (&ref_file);
1912 for (; p != NO_NODE; FORWARD (p)) {
1913 read_insertion (SUB (p), ref_file);
1914 if (IS (p, FORMAT_ITEM_L)) {
1915 BOOL_T siga = (BOOL_T) ! END_OF_FILE (file);
1916 while (siga) {
1917 int ch = read_single_char (p, ref_file);
1918 siga = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1919 }
1920 } else if (IS (p, FORMAT_ITEM_P)) {
1921 BOOL_T siga = (BOOL_T) ! END_OF_FILE (file);
1922 while (siga) {
1923 int ch = read_single_char (p, ref_file);
1924 siga = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1925 }
1926 } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
1927 if (!END_OF_FILE (file)) {
1928 (void) read_single_char (p, ref_file);
1929 }
1930 } else if (IS (p, FORMAT_ITEM_Y)) {
1931 PUSH_REF (p, ref_file);
1932 PUSH_VALUE (p, -1, A68_INT);
1933 genie_set (p);
1934 } else if (IS (p, LITERAL)) {
1935 // Skip characters, but don't check the literal.
1936 int len = (int) strlen (NSYMBOL (p));
1937 while (len-- && !END_OF_FILE (file)) {
1938 (void) read_single_char (p, ref_file);
1939 }
1940 } else if (IS (p, REPLICATOR)) {
1941 int k = get_replicator_value (SUB (p), A68_TRUE);
1942 if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
1943 for (int j = 1; j <= k; j++) {
1944 read_insertion (NEXT (p), ref_file);
1945 }
1946 } else {
1947 int pos = get_transput_buffer_index (INPUT_BUFFER);
1948 for (int j = 1; j < (k - pos); j++) {
1949 if (!END_OF_FILE (file)) {
1950 (void) read_single_char (p, ref_file);
1951 }
1952 }
1953 }
1954 return; // From REPLICATOR, don't delete this!
1955 }
1956 }
1957 }
1958
1959 //! @brief Read string from file according current format.
1960
1961 void read_string_pattern (NODE_T * p, MOID_T * m, A68_REF ref_file)
1962 {
1963 for (; p != NO_NODE; FORWARD (p)) {
1964 if (IS (p, INSERTION)) {
1965 read_insertion (SUB (p), ref_file);
1966 } else if (IS (p, FORMAT_ITEM_A)) {
1967 scan_n_chars (p, 1, m, ref_file);
1968 } else if (IS (p, FORMAT_ITEM_S)) {
1969 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
1970 return;
1971 } else if (IS (p, REPLICATOR)) {
1972 int k = get_replicator_value (SUB (p), A68_TRUE);
1973 for (int j = 1; j <= k; j++) {
1974 read_string_pattern (NEXT (p), m, ref_file);
1975 }
1976 return;
1977 } else {
1978 read_string_pattern (SUB (p), m, ref_file);
1979 }
1980 }
1981 }
1982
1983 //! @brief Traverse choice pattern.
1984
1985 void traverse_choice_pattern (NODE_T * p, char *str, int len, int *count, int *matches, int *first_match, BOOL_T * full_match)
1986 {
1987 for (; p != NO_NODE; FORWARD (p)) {
1988 traverse_choice_pattern (SUB (p), str, len, count, matches, first_match, full_match);
1989 if (IS (p, LITERAL)) {
1990 (*count)++;
1991 if (strncmp (NSYMBOL (p), str, (size_t) len) == 0) {
1992 (*matches)++;
1993 (*full_match) = (BOOL_T) ((*full_match) | (strcmp (NSYMBOL (p), str) == 0));
1994 if (*first_match == 0 && *full_match) {
1995 *first_match = *count;
1996 }
1997 }
1998 }
1999 }
2000 }
2001
2002 //! @brief Read appropriate insertion from a choice pattern.
2003
2004 int read_choice_pattern (NODE_T * p, A68_REF ref_file)
2005 {
2006
2007 // This implementation does not have the RR peculiarity that longest
2008 // matching literal must be first, in case of non-unique first chars.
2009
2010 A68_FILE *file = FILE_DEREF (&ref_file);
2011 BOOL_T cont = A68_TRUE;
2012 int longest_match = 0, longest_match_len = 0;
2013 while (cont) {
2014 int ch = char_scanner (file);
2015 if (!END_OF_FILE (file)) {
2016 int len, count = 0, matches = 0, first_match = 0;
2017 BOOL_T full_match = A68_FALSE;
2018 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2019 len = get_transput_buffer_index (INPUT_BUFFER);
2020 traverse_choice_pattern (p, get_transput_buffer (INPUT_BUFFER), len, &count, &matches, &first_match, &full_match);
2021 if (full_match && matches == 1 && first_match > 0) {
2022 return first_match;
2023 } else if (full_match && matches > 1 && first_match > 0) {
2024 longest_match = first_match;
2025 longest_match_len = len;
2026 } else if (matches == 0) {
2027 cont = A68_FALSE;
2028 }
2029 } else {
2030 cont = A68_FALSE;
2031 }
2032 }
2033 if (longest_match > 0) {
2034 // Push back look-ahead chars.
2035 if (get_transput_buffer_index (INPUT_BUFFER) > 0) {
2036 char *z = get_transput_buffer (INPUT_BUFFER);
2037 END_OF_FILE (file) = A68_FALSE;
2038 add_string_transput_buffer (p, TRANSPUT_BUFFER (file), &z[longest_match_len]);
2039 }
2040 return longest_match;
2041 } else {
2042 value_error (p, M_INT, ref_file);
2043 return 0;
2044 }
2045 }
2046
2047 //! @brief Read value according to a general-pattern.
2048
2049 void read_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
2050 {
2051 GENIE_UNIT (NEXT_SUB (p));
2052 // RR says to ignore parameters just calculated, so we will.
2053 A68_REF row;
2054 POP_REF (p, &row);
2055 genie_read_standard (p, mode, item, ref_file);
2056 }
2057
2058 // INTEGRAL, REAL, COMPLEX and BITS patterns.
2059
2060 //! @brief Read sign-mould according current format.
2061
2062 void read_sign_mould (NODE_T * p, MOID_T * m, A68_REF ref_file, int *sign)
2063 {
2064 for (; p != NO_NODE; FORWARD (p)) {
2065 if (IS (p, INSERTION)) {
2066 read_insertion (SUB (p), ref_file);
2067 } else if (IS (p, REPLICATOR)) {
2068 int k = get_replicator_value (SUB (p), A68_TRUE);
2069 for (int j = 1; j <= k; j++) {
2070 read_sign_mould (NEXT (p), m, ref_file, sign);
2071 }
2072 return; // Leave this!
2073 } else {
2074 switch (ATTRIBUTE (p)) {
2075 case FORMAT_ITEM_Z:
2076 case FORMAT_ITEM_D:
2077 case FORMAT_ITEM_S:
2078 case FORMAT_ITEM_PLUS:
2079 case FORMAT_ITEM_MINUS: {
2080 int ch = read_single_char (p, ref_file);
2081 // When a sign has been read, digits are expected.
2082 if (*sign != 0) {
2083 if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
2084 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2085 } else {
2086 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2087 }
2088 // When a sign has not been read, a sign is expected. If there is a digit
2089 // in stead of a sign, the digit is accepted and '+' is assumed; RR demands a
2090 // space to preceed the digit, Algol68G does not.
2091 } else {
2092 if (strchr (SIGN_DIGITS, ch) != NO_TEXT) {
2093 if (ch == '+') {
2094 *sign = 1;
2095 } else if (ch == '-') {
2096 *sign = -1;
2097 } else if (ch == BLANK_CHAR) {
2098 ;
2099 }
2100 } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
2101 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2102 *sign = 1;
2103 }
2104 }
2105 break;
2106 }
2107 default: {
2108 read_sign_mould (SUB (p), m, ref_file, sign);
2109 break;
2110 }
2111 }
2112 }
2113 }
2114 }
2115
2116 //! @brief Read mould according current format.
2117
2118 void read_integral_mould (NODE_T * p, MOID_T * m, A68_REF ref_file)
2119 {
2120 for (; p != NO_NODE; FORWARD (p)) {
2121 if (IS (p, INSERTION)) {
2122 read_insertion (SUB (p), ref_file);
2123 } else if (IS (p, REPLICATOR)) {
2124 int k = get_replicator_value (SUB (p), A68_TRUE);
2125 for (int j = 1; j <= k; j++) {
2126 read_integral_mould (NEXT (p), m, ref_file);
2127 }
2128 return; // Leave this!
2129 } else if (IS (p, FORMAT_ITEM_Z)) {
2130 int ch = read_single_char (p, ref_file);
2131 const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK;
2132 if (expect (p, m, ref_file, digits, (char) ch)) {
2133 plusab_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch));
2134 } else {
2135 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2136 }
2137 } else if (IS (p, FORMAT_ITEM_D)) {
2138 int ch = read_single_char (p, ref_file);
2139 const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS : INT_DIGITS;
2140 if (expect (p, m, ref_file, digits, (char) ch)) {
2141 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2142 } else {
2143 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2144 }
2145 } else if (IS (p, FORMAT_ITEM_S)) {
2146 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2147 } else {
2148 read_integral_mould (SUB (p), m, ref_file);
2149 }
2150 }
2151 }
2152
2153 //! @brief Read mould according current format.
2154
2155 void read_integral_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
2156 {
2157 NODE_T *q = SUB (p);
2158 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2159 int sign = 0;
2160 char *z;
2161 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2162 read_sign_mould (SUB (q), m, ref_file, &sign);
2163 z = get_transput_buffer (INPUT_BUFFER);
2164 z[0] = (char) ((sign == -1) ? '-' : '+');
2165 FORWARD (q);
2166 }
2167 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2168 read_integral_mould (SUB (q), m, ref_file);
2169 }
2170 genie_string_to_value (p, m, item, ref_file);
2171 }
2172
2173 //! @brief Read point, exponent or i-frame.
2174
2175 void read_pie_frame (NODE_T * p, MOID_T * m, A68_REF ref_file, int att, int item, char ch)
2176 {
2177 // Widen ch to a stringlet.
2178 char sym[3];
2179 sym[0] = ch;
2180 sym[1] = (char) TO_LOWER (ch);
2181 sym[2] = NULL_CHAR;
2182 // Now read the frame.
2183 for (; p != NO_NODE; FORWARD (p)) {
2184 if (IS (p, INSERTION)) {
2185 read_insertion (p, ref_file);
2186 } else if (IS (p, att)) {
2187 read_pie_frame (SUB (p), m, ref_file, att, item, ch);
2188 return;
2189 } else if (IS (p, FORMAT_ITEM_S)) {
2190 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2191 return;
2192 } else if (IS (p, item)) {
2193 int ch0 = read_single_char (p, ref_file);
2194 if (expect (p, m, ref_file, sym, (char) ch0)) {
2195 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2196 } else {
2197 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2198 }
2199 }
2200 }
2201 }
2202
2203 //! @brief Read REAL value using real pattern.
2204
2205 void read_real_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
2206 {
2207 // Dive into pattern.
2208 NODE_T *q = (IS (p, REAL_PATTERN)) ? SUB (p) : p;
2209 // Dissect pattern.
2210 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2211 int sign = 0;
2212 char *z;
2213 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2214 read_sign_mould (SUB (q), m, ref_file, &sign);
2215 z = get_transput_buffer (INPUT_BUFFER);
2216 z[0] = (char) ((sign == -1) ? '-' : '+');
2217 FORWARD (q);
2218 }
2219 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2220 read_integral_mould (SUB (q), m, ref_file);
2221 FORWARD (q);
2222 }
2223 if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
2224 read_pie_frame (SUB (q), m, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, POINT_CHAR);
2225 FORWARD (q);
2226 }
2227 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2228 read_integral_mould (SUB (q), m, ref_file);
2229 FORWARD (q);
2230 }
2231 if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
2232 read_pie_frame (SUB (q), m, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E, EXPONENT_CHAR);
2233 q = NEXT_SUB (q);
2234 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2235 int k, sign = 0;
2236 char *z;
2237 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2238 k = get_transput_buffer_index (INPUT_BUFFER);
2239 read_sign_mould (SUB (q), m, ref_file, &sign);
2240 z = get_transput_buffer (INPUT_BUFFER);
2241 z[k - 1] = (char) ((sign == -1) ? '-' : '+');
2242 FORWARD (q);
2243 }
2244 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2245 read_integral_mould (SUB (q), m, ref_file);
2246 FORWARD (q);
2247 }
2248 }
2249 genie_string_to_value (p, m, item, ref_file);
2250 }
2251
2252 //! @brief Read COMPLEX value using complex pattern.
2253
2254 void read_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * m, BYTE_T * re, BYTE_T * im, A68_REF ref_file)
2255 {
2256 // Dissect pattern.
2257 NODE_T *reel = SUB (p);
2258 NODE_T *plus_i_times = NEXT (reel);
2259 NODE_T *imag = NEXT (plus_i_times);
2260 // Read pattern.
2261 read_real_pattern (reel, m, re, ref_file);
2262 reset_transput_buffer (INPUT_BUFFER);
2263 read_pie_frame (plus_i_times, comp, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I, 'I');
2264 reset_transput_buffer (INPUT_BUFFER);
2265 read_real_pattern (imag, m, im, ref_file);
2266 }
2267
2268 //! @brief Read BITS value according pattern.
2269
2270 void read_bits_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file)
2271 {
2272 int radix = get_replicator_value (SUB_SUB (p), A68_TRUE);
2273 if (radix < 2 || radix > 16) {
2274 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
2275 exit_genie (p, A68_RUNTIME_ERROR);
2276 }
2277 char *z = get_transput_buffer (INPUT_BUFFER);
2278 ASSERT (a68_bufprt (z, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
2279 set_transput_buffer_index (INPUT_BUFFER, (int) strlen (z));
2280 read_integral_mould (NEXT_SUB (p), m, ref_file);
2281 genie_string_to_value (p, m, item, ref_file);
2282 }
2283
2284 //! @brief Read object with from file and store.
2285
2286 void genie_read_real_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file)
2287 {
2288 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
2289 genie_read_standard (p, mode, item, ref_file);
2290 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
2291 read_number_generic (p, mode, item, ref_file);
2292 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
2293 read_c_pattern (p, mode, item, ref_file);
2294 } else if (IS (p, REAL_PATTERN)) {
2295 read_real_pattern (p, mode, item, ref_file);
2296 } else {
2297 pattern_error (p, mode, ATTRIBUTE (p));
2298 }
2299 }
2300
2301 //! @brief At end of read purge all insertions.
2302
2303 void purge_format_read (NODE_T * p, A68_REF ref_file)
2304 {
2305 BOOL_T siga;
2306 do {
2307 NODE_T *pat;
2308 while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
2309 format_error (p, ref_file, ERROR_FORMAT_PICTURES);
2310 }
2311 A68_FILE *file = FILE_DEREF (&ref_file);
2312 NODE_T *dollar = SUB (BODY (&FORMAT (file)));
2313 A68_FORMAT *old_fmt = (A68_FORMAT *) FRAME_LOCAL (A68_FP, OFFSET (TAX (dollar)));
2314 siga = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
2315 if (siga) {
2316 // Pop embedded format and proceed.
2317 (void) end_of_format (p, ref_file);
2318 }
2319 } while (siga);
2320 }
2321
2322 //! @brief Read object with from file and store.
2323
2324 void genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file, int *formats)
2325 {
2326 errno = 0;
2327 reset_transput_buffer (INPUT_BUFFER);
2328 if (mode == M_FORMAT) {
2329 CHECK_REF (p, ref_file, M_REF_FILE);
2330 A68_FILE *file = FILE_DEREF (&ref_file);
2331 // Forget about eventual active formats and set up new one.
2332 if (*formats > 0) {
2333 purge_format_read (p, ref_file);
2334 }
2335 (*formats)++;
2336 A68_FP = FRAME_POINTER (file);
2337 A68_SP = STACK_POINTER (file);
2338 open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE);
2339 } else if (mode == M_PROC_REF_FILE_VOID) {
2340 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
2341 exit_genie (p, A68_RUNTIME_ERROR);
2342 } else if (mode == M_REF_SOUND) {
2343 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_REF_SOUND);
2344 exit_genie (p, A68_RUNTIME_ERROR);
2345 } else if (IS_REF (mode)) {
2346 CHECK_REF (p, *(A68_REF *) item, mode);
2347 genie_read_standard_format (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file, formats);
2348 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2349 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2350 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2351 genie_read_standard (pat, mode, item, ref_file);
2352 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
2353 read_number_generic (pat, mode, item, ref_file);
2354 } else if (IS (pat, INTEGRAL_C_PATTERN)) {
2355 read_c_pattern (pat, mode, item, ref_file);
2356 } else if (IS (pat, INTEGRAL_PATTERN)) {
2357 read_integral_pattern (pat, mode, item, ref_file);
2358 } else if (IS (pat, CHOICE_PATTERN)) {
2359 int k = read_choice_pattern (pat, ref_file);
2360 if (mode == M_INT) {
2361 A68_INT *z = (A68_INT *) item;
2362 VALUE (z) = k;
2363 STATUS (z) = (STATUS_MASK_T) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK);
2364 } else {
2365 diagnostic (A68_RUNTIME_ERROR, p, ERROR_DEPRECATED, mode);
2366 exit_genie (p, A68_RUNTIME_ERROR);
2367 }
2368 } else {
2369 pattern_error (p, mode, ATTRIBUTE (pat));
2370 }
2371 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2372 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2373 genie_read_real_format (pat, mode, item, ref_file);
2374 } else if (mode == M_COMPLEX) {
2375 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2376 if (IS (pat, COMPLEX_PATTERN)) {
2377 read_complex_pattern (pat, mode, M_REAL, item, &item[SIZE (M_REAL)], ref_file);
2378 } else {
2379 // Try reading as two REAL values.
2380 genie_read_real_format (pat, M_REAL, item, ref_file);
2381 genie_read_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
2382 }
2383 } else if (mode == M_LONG_COMPLEX) {
2384 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2385 if (IS (pat, COMPLEX_PATTERN)) {
2386 read_complex_pattern (pat, mode, M_LONG_REAL, item, &item[SIZE (M_LONG_REAL)], ref_file);
2387 } else {
2388 // Try reading as two LONG REAL values.
2389 genie_read_real_format (pat, M_LONG_REAL, item, ref_file);
2390 genie_read_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
2391 }
2392 } else if (mode == M_LONG_LONG_COMPLEX) {
2393 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2394 if (IS (pat, COMPLEX_PATTERN)) {
2395 read_complex_pattern (pat, mode, M_LONG_LONG_REAL, item, &item[SIZE (M_LONG_LONG_REAL)], ref_file);
2396 } else {
2397 // Try reading as two LONG LONG REAL values.
2398 genie_read_real_format (pat, M_LONG_LONG_REAL, item, ref_file);
2399 genie_read_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
2400 }
2401 } else if (mode == M_BOOL) {
2402 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2403 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2404 genie_read_standard (p, mode, item, ref_file);
2405 } else if (IS (pat, BOOLEAN_PATTERN)) {
2406 if (NEXT_SUB (pat) == NO_NODE) {
2407 genie_read_standard (p, mode, item, ref_file);
2408 } else {
2409 A68_BOOL *z = (A68_BOOL *) item;
2410 int k = read_choice_pattern (pat, ref_file);
2411 if (k == 1 || k == 2) {
2412 VALUE (z) = (BOOL_T) ((k == 1) ? A68_TRUE : A68_FALSE);
2413 STATUS (z) = INIT_MASK;
2414 } else {
2415 STATUS (z) = NULL_MASK;
2416 }
2417 }
2418 } else {
2419 pattern_error (p, mode, ATTRIBUTE (pat));
2420 }
2421 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
2422 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2423 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2424 genie_read_standard (p, mode, item, ref_file);
2425 } else if (IS (pat, BITS_PATTERN)) {
2426 read_bits_pattern (pat, mode, item, ref_file);
2427 } else if (IS (pat, BITS_C_PATTERN)) {
2428 read_c_pattern (pat, mode, item, ref_file);
2429 } else {
2430 pattern_error (p, mode, ATTRIBUTE (pat));
2431 }
2432 } else if (mode == M_CHAR) {
2433 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2434 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2435 genie_read_standard (p, mode, item, ref_file);
2436 } else if (IS (pat, STRING_PATTERN)) {
2437 read_string_pattern (pat, M_CHAR, ref_file);
2438 genie_string_to_value (p, mode, item, ref_file);
2439 } else if (IS (pat, CHAR_C_PATTERN)) {
2440 read_c_pattern (pat, mode, item, ref_file);
2441 } else {
2442 pattern_error (p, mode, ATTRIBUTE (pat));
2443 }
2444 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
2445 // Handle these separately instead of reading [] CHAR.
2446 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2447 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2448 genie_read_standard (p, mode, item, ref_file);
2449 } else if (IS (pat, STRING_PATTERN)) {
2450 read_string_pattern (pat, mode, ref_file);
2451 genie_string_to_value (p, mode, item, ref_file);
2452 } else if (IS (pat, STRING_C_PATTERN)) {
2453 read_c_pattern (pat, mode, item, ref_file);
2454 } else {
2455 pattern_error (p, mode, ATTRIBUTE (pat));
2456 }
2457 } else if (IS_UNION (mode)) {
2458 A68_UNION *z = (A68_UNION *) item;
2459 genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file, formats);
2460 } else if (IS_STRUCT (mode)) {
2461 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
2462 BYTE_T *elem = &item[OFFSET (q)];
2463 genie_read_standard_format (p, MOID (q), elem, ref_file, formats);
2464 }
2465 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
2466 MOID_T *deflexed = DEFLEX (mode);
2467 A68_ARRAY *arr;
2468 A68_TUPLE *tup;
2469 CHECK_INIT (p, INITIALISED ((A68_REF *) item), M_ROWS);
2470 GET_DESCRIPTOR (arr, tup, (A68_REF *) item);
2471 if (get_row_size (tup, DIM (arr)) > 0) {
2472 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
2473 BOOL_T done = A68_FALSE;
2474 initialise_internal_index (tup, DIM (arr));
2475 while (!done) {
2476 ADDR_T a68_index = calculate_internal_index (tup, DIM (arr));
2477 ADDR_T elem_addr = ROW_ELEMENT (arr, a68_index);
2478 BYTE_T *elem = &base_addr[elem_addr];
2479 genie_read_standard_format (p, SUB (deflexed), elem, ref_file, formats);
2480 done = increment_internal_index (tup, DIM (arr));
2481 }
2482 }
2483 }
2484 if (errno != 0) {
2485 transput_error (p, ref_file, mode);
2486 }
2487 }
2488
2489 //! @brief PROC ([] SIMPLIN) VOID read f
2490
2491 void genie_read_format (NODE_T * p)
2492 {
2493 A68_REF row;
2494 POP_REF (p, &row);
2495 genie_stand_in (p);
2496 PUSH_REF (p, row);
2497 genie_read_file_format (p);
2498 }
2499
2500 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get f
2501
2502 void genie_read_file_format (NODE_T * p)
2503 {
2504 A68_REF row;
2505 POP_REF (p, &row);
2506 CHECK_REF (p, row, M_ROW_SIMPLIN);
2507 A68_ARRAY *arr; A68_TUPLE *tup;
2508 GET_DESCRIPTOR (arr, tup, &row);
2509 int elems = ROW_SIZE (tup);
2510 A68_REF ref_file;
2511 POP_REF (p, &ref_file);
2512 CHECK_REF (p, ref_file, M_REF_FILE);
2513 A68_FILE *file = FILE_DEREF (&ref_file);
2514 CHECK_INIT (p, INITIALISED (file), M_FILE);
2515 if (!OPENED (file)) {
2516 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
2517 exit_genie (p, A68_RUNTIME_ERROR);
2518 }
2519 if (DRAW_MOOD (file)) {
2520 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
2521 exit_genie (p, A68_RUNTIME_ERROR);
2522 }
2523 if (WRITE_MOOD (file)) {
2524 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
2525 exit_genie (p, A68_RUNTIME_ERROR);
2526 }
2527 if (!GET (&CHANNEL (file))) {
2528 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
2529 exit_genie (p, A68_RUNTIME_ERROR);
2530 }
2531 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
2532 if (IS_NIL (STRING (file))) {
2533 if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILE) {
2534 open_error (p, ref_file, "getting");
2535 }
2536 } else {
2537 FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0);
2538 }
2539 DRAW_MOOD (file) = A68_FALSE;
2540 READ_MOOD (file) = A68_TRUE;
2541 WRITE_MOOD (file) = A68_FALSE;
2542 CHAR_MOOD (file) = A68_TRUE;
2543 }
2544 if (!CHAR_MOOD (file)) {
2545 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
2546 exit_genie (p, A68_RUNTIME_ERROR);
2547 }
2548 // Save stack state since formats have frames.
2549 ADDR_T pop_fp = FRAME_POINTER (file), pop_sp = STACK_POINTER (file);
2550 FRAME_POINTER (file) = A68_FP;
2551 STACK_POINTER (file) = A68_SP;
2552 // Process [] SIMPLIN.
2553 if (BODY (&FORMAT (file)) != NO_NODE) {
2554 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE);
2555 }
2556 if (elems <= 0) {
2557 return;
2558 }
2559 int elem_index = 0, formats = 0;
2560 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
2561 for (int k = 0; k < elems; k++) {
2562 A68_UNION *z = (A68_UNION *) & (base_address[elem_index]);
2563 MOID_T *mode = (MOID_T *) (VALUE (z));
2564 BYTE_T *item = (BYTE_T *) & (base_address[elem_index + A68_UNION_SIZE]);
2565 genie_read_standard_format (p, mode, item, ref_file, &formats);
2566 elem_index += SIZE (M_SIMPLIN);
2567 }
2568 // Empty the format to purge insertions.
2569 purge_format_read (p, ref_file);
2570 BODY (&FORMAT (file)) = NO_NODE;
2571 // Forget about active formats.
2572 A68_FP = FRAME_POINTER (file);
2573 A68_SP = STACK_POINTER (file);
2574 FRAME_POINTER (file) = pop_fp;
2575 STACK_POINTER (file) = pop_sp;
2576 }
