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