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