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