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 A68G_TRUE;
68 } else {
69 return A68G_FALSE;
70 }
71 }
72
73 //! @brief Handle format error event.
74
75 void format_error (NODE_T * p, A68G_REF ref_file, char *diag)
76 {
77 A68G_FILE *f = FILE_DEREF (&ref_file);
78 on_event_handler (p, FORMAT_ERROR_MENDED (f), ref_file);
79 A68G_BOOL z;
80 POP_OBJECT (p, &z, A68G_BOOL);
81 if (VALUE (&z) == A68G_FALSE) {
82 diagnostic (A68G_RUNTIME_ERROR, p, diag);
83 exit_genie (p, A68G_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 A68G_COLLITEM *z = (A68G_COLLITEM *) FRAME_LOCAL (A68G_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, A68G_REF ref_file, A68G_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 A68G_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 A68G_FORMAT *save = (A68G_FORMAT *) FRAME_LOCAL (A68G_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, A68G_REF ref_file)
133 {
134 // Format-items return immediately to the embedding format text. The outermost
135 //format text calls "on format end".
136 A68G_FILE *file = FILE_DEREF (&ref_file);
137 NODE_T *dollar = SUB (BODY (&FORMAT (file)));
138 A68G_FORMAT *save = (A68G_FORMAT *) FRAME_LOCAL (A68G_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 A68G_BOOL z;
143 POP_OBJECT (p, &z, A68G_BOOL);
144 if (VALUE (&z) == A68G_FALSE) {
145 // Restart format.
146 A68G_FP = FRAME_POINTER (file);
147 A68G_SP = STACK_POINTER (file);
148 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68G_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 A68G_INT u;
166 if (genie_string_to_value_internal (p, M_INT, NSYMBOL (p), (BYTE_T *) & u) == A68G_FALSE) {
167 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, M_INT);
168 exit_genie (p, A68G_RUNTIME_ERROR);
169 }
170 z = VALUE (&u);
171 } else if (IS (p, DYNAMIC_REPLICATOR)) {
172 A68G_INT u;
173 GENIE_UNIT (NEXT_SUB (p));
174 POP_OBJECT (p, &u, A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_INVALID_REPLICATOR);
182 // exit_genie (p, A68G_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, A68G_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 A68G_COLLITEM *collitem = (A68G_COLLITEM *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (p)));
204 if (COUNT (collitem) != 0) {
205 if (IS (picture, A68G_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 A68G_FORMAT z;
213 A68G_FILE *file = FILE_DEREF (&ref_file);
214 GENIE_UNIT (NEXT_SUB (picture));
215 POP_OBJECT (p, &z, A68G_FORMAT);
216 open_format_frame (p, ref_file, &z, EMBEDDED_FORMAT, A68G_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 A68G_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 (A68G_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 = A68G_TRUE;
236 NODE_T *a68g_select = NO_NODE;
237 if (COUNT (collitem) == ITEM_NOT_USED) {
238 if (IS (picture, REPLICATOR)) {
239 COUNT (collitem) = get_replicator_value (SUB (p), A68G_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 a68g_select = scan_format_pattern (NEXT_SUB (picture), ref_file);
253 if (a68g_select != NO_NODE) {
254 return a68g_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, A68G_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 A68G_FILE *file = FILE_DEREF (&ref_file);
277 if (BODY (&FORMAT (file)) == NO_NODE) {
278 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
279 exit_genie (p, A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED);
292 exit_genie (p, A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_CANNOT_TRANSPUT, mode, att);
305 exit_genie (p, A68G_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 = A68G_SP;
313 PUSH_UNION (p, mode);
314 PUSH (p, item, (int) SIZE (mode));
315 A68G_SP = pop_sp + SIZE (M_NUMBER);
316 }
317
318 //! @brief Write a group of insertions.
319
320 void write_insertion (NODE_T * p, A68G_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, A68G_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 size_t k = strlen (NSYMBOL (p));
341 for (size_t 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), A68G_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, A68G_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), A68G_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 = A68G_TRUE;
404 FORWARD (p);
405 } else {
406 *right_align = A68G_FALSE;
407 }
408 if (IS (p, FORMAT_ITEM_PLUS)) {
409 *sign = A68G_TRUE;
410 FORWARD (p);
411 } else {
412 *sign = A68G_FALSE;
413 }
414 if (IS (p, REPLICATOR)) {
415 *width = get_replicator_value (SUB (p), A68G_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), A68G_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, A68G_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, A68G_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 A68G_REF row;
459 POP_REF (p, &row);
460 A68G_ARRAY *arr; A68G_TUPLE *tup;
461 GET_DESCRIPTOR (arr, tup, &row);
462 size_t 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 ((A68G_INT *) & (base_address[addr]));
468 PUSH_VALUE (p, arg, A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
488 exit_genie (p, A68G_RUNTIME_ERROR);
489 break;
490 }
491 }
492 } else if (mod == FORMAT_ITEM_H) {
493 A68G_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 = A68G_EXP_WIDTH + 1;
506 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
507 def_expo = A68G_LONG_EXP_WIDTH + 1;
508 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
509 def_expo = A68G_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, A68G_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, A68G_INT);
523 POP_OBJECT (p, &a_after, A68G_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, A68G_INT);
530 POP_OBJECT (p, &a_after, A68G_INT);
531 POP_OBJECT (p, &a_width, A68G_INT);
532 VALUE (&a_expo) = def_expo;
533 break;
534 }
535 case 4: {
536 POP_OBJECT (p, &a_mult, A68G_INT);
537 POP_OBJECT (p, &a_expo, A68G_INT);
538 POP_OBJECT (p, &a_after, A68G_INT);
539 POP_OBJECT (p, &a_width, A68G_INT);
540 break;
541 }
542 default: {
543 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
544 exit_genie (p, A68G_RUNTIME_ERROR);
545 break;
546 }
547 }
548 PUSH_VALUE (p, VALUE (&a_width), A68G_INT);
549 PUSH_VALUE (p, VALUE (&a_after), A68G_INT);
550 PUSH_VALUE (p, VALUE (&a_expo), A68G_INT);
551 PUSH_VALUE (p, VALUE (&a_mult), A68G_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, A68G_REF ref_file)
560 {
561 ADDR_T pop_sp = A68G_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 A68G_CHAR *z = (A68G_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), A68G_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 = A68G_REAL_WIDTH + A68G_EXP_WIDTH + 4;
589 after = A68G_REAL_WIDTH - 1;
590 expo = A68G_EXP_WIDTH + 1;
591 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
592 width = A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4;
593 after = A68G_LONG_REAL_WIDTH - 1;
594 expo = A68G_LONG_EXP_WIDTH + 1;
595 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
596 width = A68G_LONG_LONG_REAL_WIDTH + A68G_LONG_LONG_EXP_WIDTH + 4;
597 after = A68G_LONG_LONG_REAL_WIDTH - 1;
598 expo = A68G_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), A68G_INT);
608 PUSH_VALUE (p, after, A68G_INT);
609 PUSH_VALUE (p, expo, A68G_INT);
610 PUSH_VALUE (p, 1, A68G_INT);
611 str = real (p);
612 A68G_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_REF, 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 = A68G_REAL_WIDTH + 2;
624 after = A68G_REAL_WIDTH - 1;
625 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
626 width = A68G_LONG_REAL_WIDTH + 2;
627 after = A68G_LONG_REAL_WIDTH - 1;
628 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
629 width = A68G_LONG_LONG_REAL_WIDTH + 2;
630 after = A68G_LONG_LONG_REAL_WIDTH - 1;
631 }
632 scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
633 if (digits == 0) {
634 width = 0;
635 } else if (digits > 0) {
636 width = digits + after + 2;
637 }
638 unite_to_number (p, mode, item);
639 PUSH_VALUE (p, (sign ? width : -width), A68G_INT);
640 PUSH_VALUE (p, after, A68G_INT);
641 str = fixed (p);
642 A68G_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) A68G_BITS_WIDTH / (REAL_T) nibble);
661 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
662 #if (A68G_LEVEL <= 2)
663 width = (int) ceil ((REAL_T) get_mp_bits_width (mode) / (REAL_T) nibble);
664 #else
665 width = (int) ceil ((REAL_T) A68G_LONG_BITS_WIDTH / (REAL_T) nibble);
666 #endif
667 }
668 }
669 if (mode == M_BITS) {
670 A68G_BITS *z = (A68G_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 (A68G_LEVEL >= 3)
679 A68G_LONG_BITS *z = (A68G_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 (A68G_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 = A68G_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 == A68G_TRUE) {
728 while (str[0] == BLANK_CHAR) {
729 str++;
730 }
731 int blanks = width - 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 - 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, A68G_REF ref_file)
763 {
764 A68G_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, A68G_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, A68G_REF ref_file)
786 {
787 ADDR_T pop_sp = A68G_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 == A68G_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 A68G_FILE *file = FILE_DEREF (&ref_file);
858 int ch;
859 ASSERT (a68g_bufprt (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
860 set_transput_buffer_index (INPUT_BUFFER, 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 (a68g_bufprt (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
876 set_transput_buffer_index (INPUT_BUFFER, 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 A68G_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), A68G_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), A68G_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, A68G_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, 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 //! @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, A68G_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 = A68G_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 int digits = DIGITS (M_LONG_LONG_INT);
1082 MP_T *z = nil_mp (p, digits);
1083 if (mode == M_INT) {
1084 int_to_mp (p, z, VALUE ((A68G_INT *) item), digits);
1085 } else if (mode == M_LONG_INT) {
1086 #if (A68G_LEVEL >= 3)
1087 DOUBLE_NUM_T w = VALUE ((A68G_LONG_INT *) item);
1088 double_int_to_mp (p, z, w, digits);
1089 #else
1090 (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_INT));
1091 #endif
1092 } else if (mode == M_LONG_LONG_INT) {
1093 (void) move_mp (z, (MP_T *) item, digits);
1094 }
1095 sign = MP_SIGN (z);
1096 MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
1097 str = sub_whole_mp (p, z, digits, width);
1098 // Edit string and output.
1099 if (strchr (str, ERROR_CHAR) != NO_TEXT) {
1100 value_error (p, root, ref_file);
1101 }
1102 if (IS (p, SIGN_MOULD)) {
1103 put_sign_to_integral (p, sign);
1104 } else if (sign < 0) {
1105 value_sign_error (p, root, ref_file);
1106 }
1107 put_zeroes_to_integral (p, width - strlen (str));
1108 add_string_transput_buffer (p, EDIT_BUFFER, str);
1109 str = get_transput_buffer (EDIT_BUFFER);
1110 mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1111 if (IS (p, SIGN_MOULD)) {
1112 if (str[0] == '+' || str[0] == '-') {
1113 shift_sign (SUB (p), &str);
1114 }
1115 str = get_transput_buffer (EDIT_BUFFER);
1116 write_mould (SUB (p), ref_file, SIGN_MOULD, &str, &mood);
1117 FORWARD (p);
1118 }
1119 if (IS (p, INTEGRAL_MOULD)) { // This *should* be the case
1120 write_mould (SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
1121 }
1122 A68G_SP = pop_sp;
1123 }
1124 }
1125
1126 //! @brief Write REAL value using real pattern.
1127
1128 void write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68G_REF ref_file)
1129 {
1130 errno = 0;
1131 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)) {
1132 pattern_error (p, root, ATTRIBUTE (p));
1133 } else {
1134 ADDR_T pop_sp = A68G_SP;
1135 int stag_digits = 0, frac_digits = 0, expo_digits = 0;
1136 int mant_length, sign = 0, exp_value;
1137 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;
1138 char *str = NO_TEXT, *stag_str = NO_TEXT, *frac_str = NO_TEXT;
1139 MOOD_T mood;
1140 // Dive into pattern.
1141 q = ((IS (p, REAL_PATTERN)) ? SUB (p) : p);
1142 // Dissect pattern and establish widths.
1143 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
1144 sign_mould = q;
1145 count_zd_frames (SUB (sign_mould), &stag_digits);
1146 FORWARD (q);
1147 }
1148 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
1149 stag_mould = q;
1150 count_zd_frames (SUB (stag_mould), &stag_digits);
1151 FORWARD (q);
1152 }
1153 if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
1154 point_frame = q;
1155 FORWARD (q);
1156 }
1157 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
1158 frac_mould = q;
1159 count_zd_frames (SUB (frac_mould), &frac_digits);
1160 FORWARD (q);
1161 }
1162 if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
1163 e_frame = SUB (q);
1164 expo_mould = NEXT_SUB (q);
1165 q = expo_mould;
1166 if (IS (q, SIGN_MOULD)) {
1167 count_zd_frames (SUB (q), &expo_digits);
1168 FORWARD (q);
1169 }
1170 if (IS (q, INTEGRAL_MOULD)) {
1171 count_zd_frames (SUB (q), &expo_digits);
1172 }
1173 }
1174 // Make string representation.
1175 if (point_frame == NO_NODE) {
1176 mant_length = stag_digits;
1177 } else {
1178 mant_length = 1 + stag_digits + frac_digits;
1179 }
1180 //
1181 ADDR_T pop_sp2 = A68G_SP;
1182 int digits = DIGITS (M_LONG_LONG_REAL);
1183 MP_T *z = nil_mp (p, digits);
1184 if (mode == M_INT) {
1185 INT_T x = VALUE ((A68G_INT *) item);
1186 (void) int_to_mp (p, z, x, digits);
1187 } else if (mode == M_REAL) {
1188 REAL_T x = VALUE ((A68G_REAL *) item);
1189 CHECK_REAL (p, x);
1190 #if (A68G_LEVEL >= 3)
1191 (void) double_to_mp (p, z, (DOUBLE_T) x, A68G_REAL_DIG, A68G_TRUE, digits);
1192 #else
1193 (void) real_to_mp (p, z, x, digits);
1194 #endif
1195 } else if (mode == M_LONG_INT) {
1196 #if (A68G_LEVEL >= 3)
1197 DOUBLE_NUM_T x = VALUE ((A68G_DOUBLE *) item);
1198 (void) double_int_to_mp (p, z, x, digits);
1199 #else
1200 (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_INT));
1201 #endif
1202 } else if (mode == M_LONG_REAL) {
1203 #if (A68G_LEVEL >= 3)
1204 DOUBLE_T x = VALUE ((A68G_DOUBLE *) item).f;
1205 CHECK_DOUBLE_REAL (p, x);
1206 (void) double_to_mp (p, z, x, A68G_REAL_DIG, A68G_TRUE, digits);
1207 #else
1208 (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_REAL));
1209 #endif
1210 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
1211 (void) move_mp (z, (MP_T *) item, digits);
1212 }
1213 exp_value = 0;
1214 sign = SIGN (z[2]);
1215 if (sign_mould != NO_NODE) {
1216 put_sign_to_integral (sign_mould, sign);
1217 }
1218 z[2] = ABS (z[2]);
1219 if (expo_mould != NO_NODE) {
1220 standardize_mp (p, z, digits, stag_digits, frac_digits, &exp_value);
1221 }
1222 str = sub_fixed_mp (p, z, digits, mant_length, frac_digits);
1223 A68G_SP = pop_sp2;
1224 // Edit and output the string.
1225 if (strchr (str, ERROR_CHAR) != NO_TEXT) {
1226 value_error (p, root, ref_file);
1227 }
1228 reset_transput_buffer (STRING_BUFFER);
1229 add_string_transput_buffer (p, STRING_BUFFER, str);
1230 stag_str = get_transput_buffer (STRING_BUFFER);
1231 if (strchr (stag_str, ERROR_CHAR) != NO_TEXT) {
1232 value_error (p, root, ref_file);
1233 }
1234 str = strchr (stag_str, POINT_CHAR);
1235 if (str != NO_TEXT) {
1236 frac_str = &str[1];
1237 str[0] = NULL_CHAR;
1238 } else {
1239 frac_str = NO_TEXT;
1240 }
1241 // Stagnant part.
1242 reset_transput_buffer (EDIT_BUFFER);
1243 if (sign_mould != NO_NODE) {
1244 put_sign_to_integral (sign_mould, sign);
1245 } else if (sign < 0) {
1246 value_sign_error (sign_mould, root, ref_file);
1247 }
1248 put_zeroes_to_integral (p, stag_digits - strlen (stag_str));
1249 add_string_transput_buffer (p, EDIT_BUFFER, stag_str);
1250 stag_str = get_transput_buffer (EDIT_BUFFER);
1251 mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1252 if (sign_mould != NO_NODE) {
1253 if (stag_str[0] == '+' || stag_str[0] == '-') {
1254 shift_sign (SUB (p), &stag_str);
1255 }
1256 stag_str = get_transput_buffer (EDIT_BUFFER);
1257 write_mould (SUB (sign_mould), ref_file, SIGN_MOULD, &stag_str, &mood);
1258 }
1259 if (stag_mould != NO_NODE) {
1260 write_mould (SUB (stag_mould), ref_file, INTEGRAL_MOULD, &stag_str, &mood);
1261 }
1262 // Point frame.
1263 if (point_frame != NO_NODE) {
1264 write_pie_frame (point_frame, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT);
1265 }
1266 // Fraction.
1267 if (frac_mould != NO_NODE) {
1268 reset_transput_buffer (EDIT_BUFFER);
1269 add_string_transput_buffer (p, EDIT_BUFFER, frac_str);
1270 frac_str = get_transput_buffer (EDIT_BUFFER);
1271 mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1272 write_mould (SUB (frac_mould), ref_file, INTEGRAL_MOULD, &frac_str, &mood);
1273 }
1274 // Exponent.
1275 if (expo_mould != NO_NODE) {
1276 A68G_INT k;
1277 STATUS (&k) = INIT_MASK;
1278 VALUE (&k) = exp_value;
1279 if (e_frame != NO_NODE) {
1280 write_pie_frame (e_frame, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E);
1281 }
1282 write_integral_pattern (expo_mould, M_INT, root, (BYTE_T *) & k, ref_file);
1283 }
1284 A68G_SP = pop_sp;
1285 }
1286 }
1287
1288 //! @brief Write COMPLEX value using complex pattern.
1289
1290 void write_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * root, BYTE_T * re, BYTE_T * im, A68G_REF ref_file)
1291 {
1292 errno = 0;
1293 // Dissect pattern.
1294 NODE_T *reel = SUB (p);
1295 NODE_T *plus_i_times = NEXT (reel);
1296 NODE_T *imag = NEXT (plus_i_times);
1297 // Write pattern.
1298 write_real_pattern (reel, comp, root, re, ref_file);
1299 write_pie_frame (plus_i_times, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I);
1300 write_real_pattern (imag, comp, root, im, ref_file);
1301 }
1302
1303 //! @brief Write BITS value using bits pattern.
1304
1305 void write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
1306 {
1307 ADDR_T pop_sp = A68G_SP;
1308 int width = 0, radix;
1309 char *str;
1310 if (mode == M_BITS) {
1311 A68G_BITS *z = (A68G_BITS *) item;
1312 // Establish width and radix.
1313 count_zd_frames (SUB (p), &width);
1314 radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
1315 if (radix < 2 || radix > 16) {
1316 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1317 exit_genie (p, A68G_RUNTIME_ERROR);
1318 }
1319 // Generate string of correct width.
1320 reset_transput_buffer (EDIT_BUFFER);
1321 if (!convert_radix (p, VALUE (z), radix, width)) {
1322 errno = EDOM;
1323 value_error (p, mode, ref_file);
1324 }
1325 } else if (mode == M_LONG_BITS) {
1326 #if (A68G_LEVEL >= 3)
1327 A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
1328 // Establish width and radix.
1329 count_zd_frames (SUB (p), &width);
1330 radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
1331 if (radix < 2 || radix > 16) {
1332 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1333 exit_genie (p, A68G_RUNTIME_ERROR);
1334 }
1335 // Generate string of correct width.
1336 reset_transput_buffer (EDIT_BUFFER);
1337 if (!convert_radix_double (p, VALUE (z), radix, width)) {
1338 errno = EDOM;
1339 value_error (p, mode, ref_file);
1340 }
1341 #else
1342 int digits = DIGITS (mode);
1343 MP_T *u = (MP_T *) item;
1344 MP_T *v = nil_mp (p, digits);
1345 MP_T *w = nil_mp (p, digits);
1346 // Establish width and radix.
1347 count_zd_frames (SUB (p), &width);
1348 radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
1349 if (radix < 2 || radix > 16) {
1350 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1351 exit_genie (p, A68G_RUNTIME_ERROR);
1352 }
1353 // Generate string of correct width.
1354 reset_transput_buffer (EDIT_BUFFER);
1355 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
1356 errno = EDOM;
1357 value_error (p, mode, ref_file);
1358 }
1359 #endif
1360 } else if (mode == M_LONG_LONG_BITS) {
1361 #if (A68G_LEVEL <= 2)
1362 int digits = DIGITS (mode);
1363 MP_T *u = (MP_T *) item;
1364 MP_T *v = nil_mp (p, digits);
1365 MP_T *w = nil_mp (p, digits);
1366 // Establish width and radix.
1367 count_zd_frames (SUB (p), &width);
1368 radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
1369 if (radix < 2 || radix > 16) {
1370 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1371 exit_genie (p, A68G_RUNTIME_ERROR);
1372 }
1373 // Generate string of correct width.
1374 reset_transput_buffer (EDIT_BUFFER);
1375 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
1376 errno = EDOM;
1377 value_error (p, mode, ref_file);
1378 }
1379 #endif
1380 }
1381 // Output the edited string.
1382 MOOD_T mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1383 str = get_transput_buffer (EDIT_BUFFER);
1384 write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
1385 A68G_SP = pop_sp;
1386 }
1387
1388 //! @brief Write value to file.
1389
1390 void genie_write_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
1391 {
1392 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1393 genie_value_to_string (p, M_REAL, item, ATTRIBUTE (SUB (p)));
1394 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1395 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1396 write_number_generic (p, M_REAL, item, ATTRIBUTE (SUB (p)));
1397 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1398 write_c_pattern (p, M_REAL, item, ref_file);
1399 } else if (IS (p, REAL_PATTERN)) {
1400 write_real_pattern (p, M_REAL, M_REAL, item, ref_file);
1401 } else if (IS (p, COMPLEX_PATTERN)) {
1402 A68G_REAL im;
1403 STATUS (&im) = INIT_MASK;
1404 VALUE (&im) = 0.0;
1405 write_complex_pattern (p, M_REAL, M_COMPLEX, (BYTE_T *) item, (BYTE_T *) & im, ref_file);
1406 } else {
1407 pattern_error (p, M_REAL, ATTRIBUTE (p));
1408 }
1409 }
1410
1411 //! @brief Write value to file.
1412
1413 void genie_write_long_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
1414 {
1415 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1416 genie_value_to_string (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1417 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1418 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1419 write_number_generic (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1420 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1421 write_c_pattern (p, M_LONG_REAL, item, ref_file);
1422 } else if (IS (p, REAL_PATTERN)) {
1423 write_real_pattern (p, M_LONG_REAL, M_LONG_REAL, item, ref_file);
1424 } else if (IS (p, COMPLEX_PATTERN)) {
1425 #if (A68G_LEVEL >= 3)
1426 ADDR_T pop_sp = A68G_SP;
1427 A68G_LONG_REAL *z = (A68G_LONG_REAL *) STACK_TOP;
1428 DOUBLE_NUM_T im;
1429 im.f = 0.0q;
1430 PUSH_VALUE (p, im, A68G_LONG_REAL);
1431 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1432 A68G_SP = pop_sp;
1433 #else
1434 ADDR_T pop_sp = A68G_SP;
1435 MP_T *z = nil_mp (p, DIGITS (M_LONG_REAL));
1436 z[0] = (MP_T) INIT_MASK;
1437 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1438 A68G_SP = pop_sp;
1439 #endif
1440 } else {
1441 pattern_error (p, M_LONG_REAL, ATTRIBUTE (p));
1442 }
1443 }
1444
1445 //! @brief Write value to file.
1446
1447 void genie_write_long_mp_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
1448 {
1449 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1450 genie_value_to_string (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1451 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1452 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1453 write_number_generic (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1454 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1455 write_c_pattern (p, M_LONG_LONG_REAL, item, ref_file);
1456 } else if (IS (p, REAL_PATTERN)) {
1457 write_real_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_REAL, item, ref_file);
1458 } else if (IS (p, COMPLEX_PATTERN)) {
1459 ADDR_T pop_sp = A68G_SP;
1460 MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
1461 z[0] = (MP_T) INIT_MASK;
1462 write_complex_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1463 A68G_SP = pop_sp;
1464 } else {
1465 pattern_error (p, M_LONG_LONG_REAL, ATTRIBUTE (p));
1466 }
1467 }
1468
1469 //! @brief At end of write purge all insertions.
1470
1471 void purge_format_write (NODE_T * p, A68G_REF ref_file)
1472 {
1473 // Problem here is shutting down embedded formats.
1474 BOOL_T siga;
1475 do {
1476 A68G_FILE *file;
1477 NODE_T *dollar, *pat;
1478 A68G_FORMAT *old_fmt;
1479 while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
1480 format_error (p, ref_file, ERROR_FORMAT_PICTURES);
1481 }
1482 file = FILE_DEREF (&ref_file);
1483 dollar = SUB (BODY (&FORMAT (file)));
1484 old_fmt = (A68G_FORMAT *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (dollar)));
1485 siga = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
1486 if (siga) {
1487 // Pop embedded format and proceed.
1488 (void) end_of_format (p, ref_file);
1489 }
1490 } while (siga);
1491 }
1492
1493 //! @brief Write value to file.
1494
1495 void genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file, int *formats)
1496 {
1497 errno = 0;
1498 ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1499 if (mode == M_FORMAT) {
1500 A68G_FILE *file;
1501 CHECK_REF (p, ref_file, M_REF_FILE);
1502 file = FILE_DEREF (&ref_file);
1503 // Forget about eventual active formats and set up new one.
1504 if (*formats > 0) {
1505 purge_format_write (p, ref_file);
1506 }
1507 (*formats)++;
1508 A68G_FP = FRAME_POINTER (file);
1509 A68G_SP = STACK_POINTER (file);
1510 open_format_frame (p, ref_file, (A68G_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68G_TRUE);
1511 } else if (mode == M_PROC_REF_FILE_VOID) {
1512 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
1513 exit_genie (p, A68G_RUNTIME_ERROR);
1514 } else if (mode == M_SOUND) {
1515 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_SOUND);
1516 exit_genie (p, A68G_RUNTIME_ERROR);
1517 } else if (mode == M_INT) {
1518 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1519 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1520 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1521 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1522 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1523 write_number_generic (pat, M_INT, item, ATTRIBUTE (SUB (pat)));
1524 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1525 write_c_pattern (pat, M_INT, item, ref_file);
1526 } else if (IS (pat, INTEGRAL_PATTERN)) {
1527 write_integral_pattern (pat, M_INT, M_INT, item, ref_file);
1528 } else if (IS (pat, REAL_PATTERN)) {
1529 write_real_pattern (pat, M_INT, M_INT, item, ref_file);
1530 } else if (IS (pat, COMPLEX_PATTERN)) {
1531 A68G_REAL re, im;
1532 STATUS (&re) = INIT_MASK;
1533 VALUE (&re) = (REAL_T) VALUE ((A68G_INT *) item);
1534 STATUS (&im) = INIT_MASK;
1535 VALUE (&im) = 0.0;
1536 write_complex_pattern (pat, M_REAL, M_COMPLEX, (BYTE_T *) & re, (BYTE_T *) & im, ref_file);
1537 } else if (IS (pat, CHOICE_PATTERN)) {
1538 int k = VALUE ((A68G_INT *) item);
1539 write_choice_pattern (NEXT_SUB (pat), ref_file, &k);
1540 } else {
1541 pattern_error (p, mode, ATTRIBUTE (pat));
1542 }
1543 } else if (mode == M_LONG_INT) {
1544 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1545 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1546 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1547 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1548 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1549 write_number_generic (pat, M_LONG_INT, item, ATTRIBUTE (SUB (pat)));
1550 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1551 write_c_pattern (pat, M_LONG_INT, item, ref_file);
1552 } else if (IS (pat, INTEGRAL_PATTERN)) {
1553 write_integral_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
1554 } else if (IS (pat, REAL_PATTERN)) {
1555 write_real_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
1556 } else if (IS (pat, COMPLEX_PATTERN)) {
1557 #if (A68G_LEVEL >= 3)
1558 ADDR_T pop_sp = A68G_SP;
1559 A68G_LONG_REAL *z = (A68G_LONG_REAL *) STACK_TOP;
1560 DOUBLE_NUM_T im;
1561 im.f = 0.0q;
1562 PUSH_VALUE (p, im, A68G_LONG_REAL);
1563 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1564 A68G_SP = pop_sp;
1565 #else
1566 ADDR_T pop_sp = A68G_SP;
1567 MP_T *z = nil_mp (p, DIGITS (mode));
1568 z[0] = (MP_T) INIT_MASK;
1569 write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1570 A68G_SP = pop_sp;
1571 #endif
1572 } else if (IS (pat, CHOICE_PATTERN)) {
1573 INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
1574 int sk;
1575 CHECK_INT_SHORTEN (p, k);
1576 sk = (int) k;
1577 write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
1578 } else {
1579 pattern_error (p, mode, ATTRIBUTE (pat));
1580 }
1581 } else if (mode == M_LONG_LONG_INT) {
1582 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1583 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1584 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1585 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1586 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1587 write_number_generic (pat, M_LONG_LONG_INT, item, ATTRIBUTE (SUB (pat)));
1588 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1589 write_c_pattern (pat, M_LONG_LONG_INT, item, ref_file);
1590 } else if (IS (pat, INTEGRAL_PATTERN)) {
1591 write_integral_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
1592 } else if (IS (pat, REAL_PATTERN)) {
1593 write_real_pattern (pat, M_INT, M_INT, item, ref_file);
1594 } else if (IS (pat, REAL_PATTERN)) {
1595 write_real_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
1596 } else if (IS (pat, COMPLEX_PATTERN)) {
1597 ADDR_T pop_sp = A68G_SP;
1598 MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
1599 z[0] = (MP_T) INIT_MASK;
1600 write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1601 A68G_SP = pop_sp;
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_REAL) {
1612 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1613 genie_write_real_format (pat, item, ref_file);
1614 } else if (mode == M_LONG_REAL) {
1615 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1616 genie_write_long_real_format (pat, item, ref_file);
1617 } else if (mode == M_LONG_LONG_REAL) {
1618 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1619 genie_write_long_mp_real_format (pat, item, ref_file);
1620 } else if (mode == M_COMPLEX) {
1621 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1622 if (IS (pat, COMPLEX_PATTERN)) {
1623 write_complex_pattern (pat, M_REAL, M_COMPLEX, &item[0], &item[SIZE (M_REAL)], ref_file);
1624 } else {
1625 // Try writing as two REAL values.
1626 genie_write_real_format (pat, item, ref_file);
1627 genie_write_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
1628 }
1629 } else if (mode == M_LONG_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_LONG_REAL, M_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_REAL)], ref_file);
1633 } else {
1634 // Try writing as two LONG REAL values.
1635 genie_write_long_real_format (pat, item, ref_file);
1636 genie_write_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
1637 }
1638 } else if (mode == M_LONG_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_LONG_REAL, M_LONG_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_LONG_REAL)], ref_file);
1642 } else {
1643 // Try writing as two LONG LONG REAL values.
1644 genie_write_long_mp_real_format (pat, item, ref_file);
1645 genie_write_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
1646 }
1647 } else if (mode == M_BOOL) {
1648 A68G_BOOL *z = (A68G_BOOL *) item;
1649 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1650 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1651 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68G_TRUE ? FLIP_CHAR : FLOP_CHAR));
1652 } else if (IS (pat, BOOLEAN_PATTERN)) {
1653 if (NEXT_SUB (pat) == NO_NODE) {
1654 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68G_TRUE ? FLIP_CHAR : FLOP_CHAR));
1655 } else {
1656 write_boolean_pattern (pat, ref_file, (BOOL_T) (VALUE (z) == A68G_TRUE));
1657 }
1658 } else {
1659 pattern_error (p, mode, ATTRIBUTE (pat));
1660 }
1661 } else if (mode == M_BITS) {
1662 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1663 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1664 char *str = (char *) STACK_TOP;
1665 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
1666 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
1667 } else if (IS (pat, BITS_PATTERN)) {
1668 write_bits_pattern (pat, M_BITS, item, ref_file);
1669 } else if (IS (pat, BITS_C_PATTERN)) {
1670 write_c_pattern (pat, M_BITS, item, ref_file);
1671 } else {
1672 pattern_error (p, mode, ATTRIBUTE (pat));
1673 }
1674 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
1675 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1676 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1677 char *str = (char *) STACK_TOP;
1678 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
1679 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
1680 } else if (IS (pat, BITS_PATTERN)) {
1681 write_bits_pattern (pat, mode, item, ref_file);
1682 } else if (IS (pat, BITS_C_PATTERN)) {
1683 write_c_pattern (pat, mode, item, ref_file);
1684 } else {
1685 pattern_error (p, mode, ATTRIBUTE (pat));
1686 }
1687 } else if (mode == M_CHAR) {
1688 A68G_CHAR *z = (A68G_CHAR *) item;
1689 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1690 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1691 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) VALUE (z));
1692 } else if (IS (pat, STRING_PATTERN)) {
1693 char *q = get_transput_buffer (EDIT_BUFFER);
1694 reset_transput_buffer (EDIT_BUFFER);
1695 plusab_transput_buffer (p, EDIT_BUFFER, (char) VALUE (z));
1696 write_string_pattern (pat, mode, ref_file, &q);
1697 if (q[0] != NULL_CHAR) {
1698 value_error (p, mode, ref_file);
1699 }
1700 } else if (IS (pat, STRING_C_PATTERN)) {
1701 char zz[2];
1702 zz[0] = VALUE (z);
1703 zz[1] = '\0';
1704 (void) c_to_a_string (pat, zz, 1);
1705 write_c_pattern (pat, mode, (BYTE_T *) zz, ref_file);
1706 } else {
1707 pattern_error (p, mode, ATTRIBUTE (pat));
1708 }
1709 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1710 // Handle these separately instead of printing [] CHAR.
1711 A68G_REF row = *(A68G_REF *) item;
1712 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1713 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1714 PUSH_REF (p, row);
1715 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1716 } else if (IS (pat, STRING_PATTERN)) {
1717 char *q;
1718 PUSH_REF (p, row);
1719 reset_transput_buffer (EDIT_BUFFER);
1720 add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
1721 q = get_transput_buffer (EDIT_BUFFER);
1722 write_string_pattern (pat, mode, ref_file, &q);
1723 if (q[0] != NULL_CHAR) {
1724 value_error (p, mode, ref_file);
1725 }
1726 } else if (IS (pat, STRING_C_PATTERN)) {
1727 char *q;
1728 PUSH_REF (p, row);
1729 reset_transput_buffer (EDIT_BUFFER);
1730 add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
1731 q = get_transput_buffer (EDIT_BUFFER);
1732 write_c_pattern (pat, mode, (BYTE_T *) q, ref_file);
1733 } else {
1734 pattern_error (p, mode, ATTRIBUTE (pat));
1735 }
1736 } else if (IS_UNION (mode)) {
1737 A68G_UNION *z = (A68G_UNION *) item;
1738 MOID_T *um = (MOID_T *) (VALUE (z));
1739 BYTE_T *ui = &item[A68G_UNION_SIZE];
1740 if (um == NO_MOID) {
1741 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
1742 exit_genie (p, A68G_RUNTIME_ERROR);
1743 }
1744 genie_write_standard_format (p, um, ui, ref_file, formats);
1745 } else if (IS_STRUCT (mode)) {
1746 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1747 BYTE_T *elem = &item[OFFSET (q)];
1748 genie_check_initialisation (p, elem, MOID (q));
1749 genie_write_standard_format (p, MOID (q), elem, ref_file, formats);
1750 }
1751 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1752 MOID_T *deflexed = DEFLEX (mode);
1753 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
1754 A68G_ARRAY *arr; A68G_TUPLE *tup;
1755 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
1756 if (get_row_size (tup, DIM (arr)) > 0) {
1757 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1758 BOOL_T done = A68G_FALSE;
1759 initialise_internal_index (tup, DIM (arr));
1760 while (!done) {
1761 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
1762 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
1763 BYTE_T *elem = &base_addr[elem_addr];
1764 genie_check_initialisation (p, elem, SUB (deflexed));
1765 genie_write_standard_format (p, SUB (deflexed), elem, ref_file, formats);
1766 done = increment_internal_index (tup, DIM (arr));
1767 }
1768 }
1769 }
1770 if (errno != 0) {
1771 transput_error (p, ref_file, mode);
1772 }
1773 }
1774
1775 //! @brief PROC ([] SIMPLOUT) VOID print f, write f
1776
1777 void genie_write_format (NODE_T * p)
1778 {
1779 A68G_REF row;
1780 POP_REF (p, &row);
1781 genie_stand_out (p);
1782 PUSH_REF (p, row);
1783 genie_write_file_format (p);
1784 }
1785
1786 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put f
1787
1788 void genie_write_file_format (NODE_T * p)
1789 {
1790 A68G_REF row;
1791 POP_REF (p, &row);
1792 CHECK_REF (p, row, M_ROW_SIMPLOUT);
1793 A68G_ARRAY *arr; A68G_TUPLE *tup;
1794 GET_DESCRIPTOR (arr, tup, &row);
1795 int elems = ROW_SIZE (tup);
1796 A68G_REF ref_file;
1797 POP_REF (p, &ref_file);
1798 CHECK_REF (p, ref_file, M_REF_FILE);
1799 A68G_FILE *file = FILE_DEREF (&ref_file);
1800 CHECK_INIT (p, INITIALISED (file), M_FILE);
1801 if (!OPENED (file)) {
1802 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1803 exit_genie (p, A68G_RUNTIME_ERROR);
1804 }
1805 if (DRAW_MOOD (file)) {
1806 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1807 exit_genie (p, A68G_RUNTIME_ERROR);
1808 }
1809 if (READ_MOOD (file)) {
1810 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1811 exit_genie (p, A68G_RUNTIME_ERROR);
1812 }
1813 if (!PUT (&CHANNEL (file))) {
1814 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1815 exit_genie (p, A68G_RUNTIME_ERROR);
1816 }
1817 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1818 if (IS_NIL (STRING (file))) {
1819 if ((FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, A68G_PROTECTION)) == A68G_NO_FILE) {
1820 open_error (p, ref_file, "putting");
1821 }
1822 } else {
1823 FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, 0);
1824 }
1825 DRAW_MOOD (file) = A68G_FALSE;
1826 READ_MOOD (file) = A68G_FALSE;
1827 WRITE_MOOD (file) = A68G_TRUE;
1828 CHAR_MOOD (file) = A68G_TRUE;
1829 }
1830 if (!CHAR_MOOD (file)) {
1831 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
1832 exit_genie (p, A68G_RUNTIME_ERROR);
1833 }
1834 // Save stack state since formats have frames.
1835 ADDR_T pop_fp = FRAME_POINTER (file), pop_sp = STACK_POINTER (file);
1836 FRAME_POINTER (file) = A68G_FP;
1837 STACK_POINTER (file) = A68G_SP;
1838 // Process [] SIMPLOUT.
1839 if (BODY (&FORMAT (file)) != NO_NODE) {
1840 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68G_FALSE);
1841 }
1842 if (elems <= 0) {
1843 return;
1844 }
1845 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1846 int elem_index = 0, formats = 0;
1847 for (int k = 0; k < elems; k++) {
1848 A68G_UNION *z = (A68G_UNION *) & (base_address[elem_index]);
1849 MOID_T *mode = (MOID_T *) (VALUE (z));
1850 BYTE_T *item = &(base_address[elem_index + A68G_UNION_SIZE]);
1851 genie_write_standard_format (p, mode, item, ref_file, &formats);
1852 elem_index += SIZE (M_SIMPLOUT);
1853 }
1854 // Empty the format to purge insertions.
1855 purge_format_write (p, ref_file);
1856 BODY (&FORMAT (file)) = NO_NODE;
1857 // Dump the buffer.
1858 write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
1859 // Forget about active formats.
1860 A68G_FP = FRAME_POINTER (file);
1861 A68G_SP = STACK_POINTER (file);
1862 FRAME_POINTER (file) = pop_fp;
1863 STACK_POINTER (file) = pop_sp;
1864 }
1865
1866 //! @brief Give a value error in case a character is not among expected ones.
1867
1868 BOOL_T expect (NODE_T * p, MOID_T * m, A68G_REF ref_file, const char *items, char ch)
1869 {
1870 if (strchr ((char *) items, ch) == NO_TEXT) {
1871 value_error (p, m, ref_file);
1872 return A68G_FALSE;
1873 } else {
1874 return A68G_TRUE;
1875 }
1876 }
1877
1878 //! @brief Read a group of insertions.
1879
1880 void read_insertion (NODE_T * p, A68G_REF ref_file)
1881 {
1882
1883 // Algol68G does not check whether the insertions are textually there. It just
1884 // skips them. This because we blank literals in sign moulds before the sign is
1885 // put, which is non-standard Algol68, but convenient.
1886
1887 A68G_FILE *file = FILE_DEREF (&ref_file);
1888 for (; p != NO_NODE; FORWARD (p)) {
1889 read_insertion (SUB (p), ref_file);
1890 if (IS (p, FORMAT_ITEM_L)) {
1891 BOOL_T siga = (BOOL_T) ! END_OF_FILE (file);
1892 while (siga) {
1893 int ch = read_single_char (p, ref_file);
1894 siga = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1895 }
1896 } else if (IS (p, FORMAT_ITEM_P)) {
1897 BOOL_T siga = (BOOL_T) ! END_OF_FILE (file);
1898 while (siga) {
1899 int ch = read_single_char (p, ref_file);
1900 siga = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1901 }
1902 } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
1903 if (!END_OF_FILE (file)) {
1904 (void) read_single_char (p, ref_file);
1905 }
1906 } else if (IS (p, FORMAT_ITEM_Y)) {
1907 PUSH_REF (p, ref_file);
1908 PUSH_VALUE (p, -1, A68G_INT);
1909 genie_set (p);
1910 } else if (IS (p, LITERAL)) {
1911 // Skip characters, but don't check the literal.
1912 size_t len = strlen (NSYMBOL (p));
1913 while (len-- && !END_OF_FILE (file)) {
1914 (void) read_single_char (p, ref_file);
1915 }
1916 } else if (IS (p, REPLICATOR)) {
1917 int k = get_replicator_value (SUB (p), A68G_TRUE);
1918 if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
1919 for (int j = 1; j <= k; j++) {
1920 read_insertion (NEXT (p), ref_file);
1921 }
1922 } else {
1923 int pos = get_transput_buffer_index (INPUT_BUFFER);
1924 for (int j = 1; j < (k - pos); j++) {
1925 if (!END_OF_FILE (file)) {
1926 (void) read_single_char (p, ref_file);
1927 }
1928 }
1929 }
1930 return; // From REPLICATOR, don't delete this!
1931 }
1932 }
1933 }
1934
1935 //! @brief Read string from file according current format.
1936
1937 void read_string_pattern (NODE_T * p, MOID_T * m, A68G_REF ref_file)
1938 {
1939 for (; p != NO_NODE; FORWARD (p)) {
1940 if (IS (p, INSERTION)) {
1941 read_insertion (SUB (p), ref_file);
1942 } else if (IS (p, FORMAT_ITEM_A)) {
1943 scan_n_chars (p, 1, m, ref_file);
1944 } else if (IS (p, FORMAT_ITEM_S)) {
1945 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
1946 return;
1947 } else if (IS (p, REPLICATOR)) {
1948 int k = get_replicator_value (SUB (p), A68G_TRUE);
1949 for (int j = 1; j <= k; j++) {
1950 read_string_pattern (NEXT (p), m, ref_file);
1951 }
1952 return;
1953 } else {
1954 read_string_pattern (SUB (p), m, ref_file);
1955 }
1956 }
1957 }
1958
1959 //! @brief Traverse choice pattern.
1960
1961 void traverse_choice_pattern (NODE_T * p, char *str, int len, int *count, int *matches, int *first_match, BOOL_T * full_match)
1962 {
1963 for (; p != NO_NODE; FORWARD (p)) {
1964 traverse_choice_pattern (SUB (p), str, len, count, matches, first_match, full_match);
1965 if (IS (p, LITERAL)) {
1966 (*count)++;
1967 if (strncmp (NSYMBOL (p), str, (size_t) len) == 0) {
1968 (*matches)++;
1969 (*full_match) = (BOOL_T) ((*full_match) | (strcmp (NSYMBOL (p), str) == 0));
1970 if (*first_match == 0 && *full_match) {
1971 *first_match = *count;
1972 }
1973 }
1974 }
1975 }
1976 }
1977
1978 //! @brief Read appropriate insertion from a choice pattern.
1979
1980 int read_choice_pattern (NODE_T * p, A68G_REF ref_file)
1981 {
1982
1983 // This implementation does not have the RR peculiarity that longest
1984 // matching literal must be first, in case of non-unique first chars.
1985
1986 A68G_FILE *file = FILE_DEREF (&ref_file);
1987 BOOL_T cont = A68G_TRUE;
1988 int longest_match = 0, longest_match_len = 0;
1989 while (cont) {
1990 int ch = char_scanner (file);
1991 if (!END_OF_FILE (file)) {
1992 int len, count = 0, matches = 0, first_match = 0;
1993 BOOL_T full_match = A68G_FALSE;
1994 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
1995 len = get_transput_buffer_index (INPUT_BUFFER);
1996 traverse_choice_pattern (p, get_transput_buffer (INPUT_BUFFER), len, &count, &matches, &first_match, &full_match);
1997 if (full_match && matches == 1 && first_match > 0) {
1998 return first_match;
1999 } else if (full_match && matches > 1 && first_match > 0) {
2000 longest_match = first_match;
2001 longest_match_len = len;
2002 } else if (matches == 0) {
2003 cont = A68G_FALSE;
2004 }
2005 } else {
2006 cont = A68G_FALSE;
2007 }
2008 }
2009 if (longest_match > 0) {
2010 // Push back look-ahead chars.
2011 if (get_transput_buffer_index (INPUT_BUFFER) > 0) {
2012 char *z = get_transput_buffer (INPUT_BUFFER);
2013 END_OF_FILE (file) = A68G_FALSE;
2014 add_string_transput_buffer (p, TRANSPUT_BUFFER (file), &z[longest_match_len]);
2015 }
2016 return longest_match;
2017 } else {
2018 value_error (p, M_INT, ref_file);
2019 return 0;
2020 }
2021 }
2022
2023 //! @brief Read value according to a general-pattern.
2024
2025 void read_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
2026 {
2027 GENIE_UNIT (NEXT_SUB (p));
2028 // RR says to ignore parameters just calculated, so we will.
2029 A68G_REF row;
2030 POP_REF (p, &row);
2031 genie_read_standard (p, mode, item, ref_file);
2032 }
2033
2034 // INTEGRAL, REAL, COMPLEX and BITS patterns.
2035
2036 //! @brief Read sign-mould according current format.
2037
2038 void read_sign_mould (NODE_T * p, MOID_T * m, A68G_REF ref_file, int *sign)
2039 {
2040 for (; p != NO_NODE; FORWARD (p)) {
2041 if (IS (p, INSERTION)) {
2042 read_insertion (SUB (p), ref_file);
2043 } else if (IS (p, REPLICATOR)) {
2044 int k = get_replicator_value (SUB (p), A68G_TRUE);
2045 for (int j = 1; j <= k; j++) {
2046 read_sign_mould (NEXT (p), m, ref_file, sign);
2047 }
2048 return; // Leave this!
2049 } else {
2050 switch (ATTRIBUTE (p)) {
2051 case FORMAT_ITEM_Z:
2052 case FORMAT_ITEM_D:
2053 case FORMAT_ITEM_S:
2054 case FORMAT_ITEM_PLUS:
2055 case FORMAT_ITEM_MINUS: {
2056 int ch = read_single_char (p, ref_file);
2057 // When a sign has been read, digits are expected.
2058 if (*sign != 0) {
2059 if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
2060 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2061 } else {
2062 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2063 }
2064 // When a sign has not been read, a sign is expected. If there is a digit
2065 // in stead of a sign, the digit is accepted and '+' is assumed; RR demands a
2066 // space to preceed the digit, Algol68G does not.
2067 } else {
2068 if (strchr (SIGN_DIGITS, ch) != NO_TEXT) {
2069 if (ch == '+') {
2070 *sign = 1;
2071 } else if (ch == '-') {
2072 *sign = -1;
2073 } else if (ch == BLANK_CHAR) {
2074 ;
2075 }
2076 } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
2077 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2078 *sign = 1;
2079 }
2080 }
2081 break;
2082 }
2083 default: {
2084 read_sign_mould (SUB (p), m, ref_file, sign);
2085 break;
2086 }
2087 }
2088 }
2089 }
2090 }
2091
2092 //! @brief Read mould according current format.
2093
2094 void read_integral_mould (NODE_T * p, MOID_T * m, A68G_REF ref_file)
2095 {
2096 for (; p != NO_NODE; FORWARD (p)) {
2097 if (IS (p, INSERTION)) {
2098 read_insertion (SUB (p), ref_file);
2099 } else if (IS (p, REPLICATOR)) {
2100 int k = get_replicator_value (SUB (p), A68G_TRUE);
2101 for (int j = 1; j <= k; j++) {
2102 read_integral_mould (NEXT (p), m, ref_file);
2103 }
2104 return; // Leave this!
2105 } else if (IS (p, FORMAT_ITEM_Z)) {
2106 int ch = read_single_char (p, ref_file);
2107 const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK;
2108 if (expect (p, m, ref_file, digits, (char) ch)) {
2109 plusab_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch));
2110 } else {
2111 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2112 }
2113 } else if (IS (p, FORMAT_ITEM_D)) {
2114 int ch = read_single_char (p, ref_file);
2115 const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS : INT_DIGITS;
2116 if (expect (p, m, ref_file, digits, (char) ch)) {
2117 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2118 } else {
2119 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2120 }
2121 } else if (IS (p, FORMAT_ITEM_S)) {
2122 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2123 } else {
2124 read_integral_mould (SUB (p), m, ref_file);
2125 }
2126 }
2127 }
2128
2129 //! @brief Read mould according current format.
2130
2131 void read_integral_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
2132 {
2133 NODE_T *q = SUB (p);
2134 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2135 int sign = 0;
2136 char *z;
2137 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2138 read_sign_mould (SUB (q), m, ref_file, &sign);
2139 z = get_transput_buffer (INPUT_BUFFER);
2140 z[0] = (char) ((sign == -1) ? '-' : '+');
2141 FORWARD (q);
2142 }
2143 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2144 read_integral_mould (SUB (q), m, ref_file);
2145 }
2146 genie_string_to_value (p, m, item, ref_file);
2147 }
2148
2149 //! @brief Read point, exponent or i-frame.
2150
2151 void read_pie_frame (NODE_T * p, MOID_T * m, A68G_REF ref_file, int att, int item, char ch)
2152 {
2153 // Widen ch to a stringlet.
2154 char sym[3];
2155 sym[0] = ch;
2156 sym[1] = (char) TO_LOWER (ch);
2157 sym[2] = NULL_CHAR;
2158 // Now read the frame.
2159 for (; p != NO_NODE; FORWARD (p)) {
2160 if (IS (p, INSERTION)) {
2161 read_insertion (p, ref_file);
2162 } else if (IS (p, att)) {
2163 read_pie_frame (SUB (p), m, ref_file, att, item, ch);
2164 return;
2165 } else if (IS (p, FORMAT_ITEM_S)) {
2166 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2167 return;
2168 } else if (IS (p, item)) {
2169 int ch0 = read_single_char (p, ref_file);
2170 if (expect (p, m, ref_file, sym, (char) ch0)) {
2171 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2172 } else {
2173 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2174 }
2175 }
2176 }
2177 }
2178
2179 //! @brief Read REAL value using real pattern.
2180
2181 void read_real_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
2182 {
2183 // Dive into pattern.
2184 NODE_T *q = (IS (p, REAL_PATTERN)) ? SUB (p) : p;
2185 // Dissect pattern.
2186 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2187 int sign = 0;
2188 char *z;
2189 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2190 read_sign_mould (SUB (q), m, ref_file, &sign);
2191 z = get_transput_buffer (INPUT_BUFFER);
2192 z[0] = (char) ((sign == -1) ? '-' : '+');
2193 FORWARD (q);
2194 }
2195 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2196 read_integral_mould (SUB (q), m, ref_file);
2197 FORWARD (q);
2198 }
2199 if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
2200 read_pie_frame (SUB (q), m, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, POINT_CHAR);
2201 FORWARD (q);
2202 }
2203 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2204 read_integral_mould (SUB (q), m, ref_file);
2205 FORWARD (q);
2206 }
2207 if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
2208 read_pie_frame (SUB (q), m, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E, EXPONENT_CHAR);
2209 q = NEXT_SUB (q);
2210 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2211 int k, sign = 0;
2212 char *z;
2213 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2214 k = get_transput_buffer_index (INPUT_BUFFER);
2215 read_sign_mould (SUB (q), m, ref_file, &sign);
2216 z = get_transput_buffer (INPUT_BUFFER);
2217 z[k - 1] = (char) ((sign == -1) ? '-' : '+');
2218 FORWARD (q);
2219 }
2220 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2221 read_integral_mould (SUB (q), m, ref_file);
2222 FORWARD (q);
2223 }
2224 }
2225 genie_string_to_value (p, m, item, ref_file);
2226 }
2227
2228 //! @brief Read COMPLEX value using complex pattern.
2229
2230 void read_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * m, BYTE_T * re, BYTE_T * im, A68G_REF ref_file)
2231 {
2232 // Dissect pattern.
2233 NODE_T *reel = SUB (p);
2234 NODE_T *plus_i_times = NEXT (reel);
2235 NODE_T *imag = NEXT (plus_i_times);
2236 // Read pattern.
2237 read_real_pattern (reel, m, re, ref_file);
2238 reset_transput_buffer (INPUT_BUFFER);
2239 read_pie_frame (plus_i_times, comp, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I, 'I');
2240 reset_transput_buffer (INPUT_BUFFER);
2241 read_real_pattern (imag, m, im, ref_file);
2242 }
2243
2244 //! @brief Read BITS value according pattern.
2245
2246 void read_bits_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
2247 {
2248 int radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
2249 if (radix < 2 || radix > 16) {
2250 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
2251 exit_genie (p, A68G_RUNTIME_ERROR);
2252 }
2253 char *z = get_transput_buffer (INPUT_BUFFER);
2254 ASSERT (a68g_bufprt (z, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
2255 set_transput_buffer_index (INPUT_BUFFER, strlen (z));
2256 read_integral_mould (NEXT_SUB (p), m, ref_file);
2257 genie_string_to_value (p, m, item, ref_file);
2258 }
2259
2260 //! @brief Read object with from file and store.
2261
2262 void genie_read_real_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
2263 {
2264 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
2265 genie_read_standard (p, mode, item, ref_file);
2266 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
2267 read_number_generic (p, mode, item, ref_file);
2268 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
2269 read_c_pattern (p, mode, item, ref_file);
2270 } else if (IS (p, REAL_PATTERN)) {
2271 read_real_pattern (p, mode, item, ref_file);
2272 } else {
2273 pattern_error (p, mode, ATTRIBUTE (p));
2274 }
2275 }
2276
2277 //! @brief At end of read purge all insertions.
2278
2279 void purge_format_read (NODE_T * p, A68G_REF ref_file)
2280 {
2281 BOOL_T siga;
2282 do {
2283 NODE_T *pat;
2284 while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
2285 format_error (p, ref_file, ERROR_FORMAT_PICTURES);
2286 }
2287 A68G_FILE *file = FILE_DEREF (&ref_file);
2288 NODE_T *dollar = SUB (BODY (&FORMAT (file)));
2289 A68G_FORMAT *old_fmt = (A68G_FORMAT *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (dollar)));
2290 siga = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
2291 if (siga) {
2292 // Pop embedded format and proceed.
2293 (void) end_of_format (p, ref_file);
2294 }
2295 } while (siga);
2296 }
2297
2298 //! @brief Read object with from file and store.
2299
2300 void genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file, int *formats)
2301 {
2302 errno = 0;
2303 reset_transput_buffer (INPUT_BUFFER);
2304 if (mode == M_FORMAT) {
2305 CHECK_REF (p, ref_file, M_REF_FILE);
2306 A68G_FILE *file = FILE_DEREF (&ref_file);
2307 // Forget about eventual active formats and set up new one.
2308 if (*formats > 0) {
2309 purge_format_read (p, ref_file);
2310 }
2311 (*formats)++;
2312 A68G_FP = FRAME_POINTER (file);
2313 A68G_SP = STACK_POINTER (file);
2314 open_format_frame (p, ref_file, (A68G_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68G_TRUE);
2315 } else if (mode == M_PROC_REF_FILE_VOID) {
2316 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
2317 exit_genie (p, A68G_RUNTIME_ERROR);
2318 } else if (mode == M_REF_SOUND) {
2319 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_REF_SOUND);
2320 exit_genie (p, A68G_RUNTIME_ERROR);
2321 } else if (IS_REF (mode)) {
2322 CHECK_REF (p, *(A68G_REF *) item, mode);
2323 genie_read_standard_format (p, SUB (mode), ADDRESS ((A68G_REF *) item), ref_file, formats);
2324 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2325 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2326 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2327 genie_read_standard (pat, mode, item, ref_file);
2328 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
2329 read_number_generic (pat, mode, item, ref_file);
2330 } else if (IS (pat, INTEGRAL_C_PATTERN)) {
2331 read_c_pattern (pat, mode, item, ref_file);
2332 } else if (IS (pat, INTEGRAL_PATTERN)) {
2333 read_integral_pattern (pat, mode, item, ref_file);
2334 } else if (IS (pat, CHOICE_PATTERN)) {
2335 int k = read_choice_pattern (pat, ref_file);
2336 if (mode == M_INT) {
2337 A68G_INT *z = (A68G_INT *) item;
2338 VALUE (z) = k;
2339 STATUS (z) = (STATUS_MASK_T) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK);
2340 } else {
2341 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_DEPRECATED, mode);
2342 exit_genie (p, A68G_RUNTIME_ERROR);
2343 }
2344 } else {
2345 pattern_error (p, mode, ATTRIBUTE (pat));
2346 }
2347 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2348 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2349 genie_read_real_format (pat, mode, item, ref_file);
2350 } else if (mode == M_COMPLEX) {
2351 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2352 if (IS (pat, COMPLEX_PATTERN)) {
2353 read_complex_pattern (pat, mode, M_REAL, item, &item[SIZE (M_REAL)], ref_file);
2354 } else {
2355 // Try reading as two REAL values.
2356 genie_read_real_format (pat, M_REAL, item, ref_file);
2357 genie_read_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
2358 }
2359 } else if (mode == M_LONG_COMPLEX) {
2360 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2361 if (IS (pat, COMPLEX_PATTERN)) {
2362 read_complex_pattern (pat, mode, M_LONG_REAL, item, &item[SIZE (M_LONG_REAL)], ref_file);
2363 } else {
2364 // Try reading as two LONG REAL values.
2365 genie_read_real_format (pat, M_LONG_REAL, item, ref_file);
2366 genie_read_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
2367 }
2368 } else if (mode == M_LONG_LONG_COMPLEX) {
2369 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2370 if (IS (pat, COMPLEX_PATTERN)) {
2371 read_complex_pattern (pat, mode, M_LONG_LONG_REAL, item, &item[SIZE (M_LONG_LONG_REAL)], ref_file);
2372 } else {
2373 // Try reading as two LONG LONG REAL values.
2374 genie_read_real_format (pat, M_LONG_LONG_REAL, item, ref_file);
2375 genie_read_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
2376 }
2377 } else if (mode == M_BOOL) {
2378 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2379 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2380 genie_read_standard (p, mode, item, ref_file);
2381 } else if (IS (pat, BOOLEAN_PATTERN)) {
2382 if (NEXT_SUB (pat) == NO_NODE) {
2383 genie_read_standard (p, mode, item, ref_file);
2384 } else {
2385 A68G_BOOL *z = (A68G_BOOL *) item;
2386 int k = read_choice_pattern (pat, ref_file);
2387 if (k == 1 || k == 2) {
2388 VALUE (z) = (BOOL_T) ((k == 1) ? A68G_TRUE : A68G_FALSE);
2389 STATUS (z) = INIT_MASK;
2390 } else {
2391 STATUS (z) = NULL_MASK;
2392 }
2393 }
2394 } else {
2395 pattern_error (p, mode, ATTRIBUTE (pat));
2396 }
2397 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
2398 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2399 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2400 genie_read_standard (p, mode, item, ref_file);
2401 } else if (IS (pat, BITS_PATTERN)) {
2402 read_bits_pattern (pat, mode, item, ref_file);
2403 } else if (IS (pat, BITS_C_PATTERN)) {
2404 read_c_pattern (pat, mode, item, ref_file);
2405 } else {
2406 pattern_error (p, mode, ATTRIBUTE (pat));
2407 }
2408 } else if (mode == M_CHAR) {
2409 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2410 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2411 genie_read_standard (p, mode, item, ref_file);
2412 } else if (IS (pat, STRING_PATTERN)) {
2413 read_string_pattern (pat, M_CHAR, ref_file);
2414 genie_string_to_value (p, mode, item, ref_file);
2415 } else if (IS (pat, CHAR_C_PATTERN)) {
2416 read_c_pattern (pat, mode, item, ref_file);
2417 } else {
2418 pattern_error (p, mode, ATTRIBUTE (pat));
2419 }
2420 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
2421 // Handle these separately instead of reading [] CHAR.
2422 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2423 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2424 genie_read_standard (p, mode, item, ref_file);
2425 } else if (IS (pat, STRING_PATTERN)) {
2426 read_string_pattern (pat, mode, ref_file);
2427 genie_string_to_value (p, mode, item, ref_file);
2428 } else if (IS (pat, STRING_C_PATTERN)) {
2429 read_c_pattern (pat, mode, item, ref_file);
2430 } else {
2431 pattern_error (p, mode, ATTRIBUTE (pat));
2432 }
2433 } else if (IS_UNION (mode)) {
2434 A68G_UNION *z = (A68G_UNION *) item;
2435 genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file, formats);
2436 } else if (IS_STRUCT (mode)) {
2437 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
2438 BYTE_T *elem = &item[OFFSET (q)];
2439 genie_read_standard_format (p, MOID (q), elem, ref_file, formats);
2440 }
2441 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
2442 MOID_T *deflexed = DEFLEX (mode);
2443 A68G_ARRAY *arr;
2444 A68G_TUPLE *tup;
2445 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
2446 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
2447 if (get_row_size (tup, DIM (arr)) > 0) {
2448 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
2449 BOOL_T done = A68G_FALSE;
2450 initialise_internal_index (tup, DIM (arr));
2451 while (!done) {
2452 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
2453 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
2454 BYTE_T *elem = &base_addr[elem_addr];
2455 genie_read_standard_format (p, SUB (deflexed), elem, ref_file, formats);
2456 done = increment_internal_index (tup, DIM (arr));
2457 }
2458 }
2459 }
2460 if (errno != 0) {
2461 transput_error (p, ref_file, mode);
2462 }
2463 }
2464
2465 //! @brief PROC ([] SIMPLIN) VOID read f
2466
2467 void genie_read_format (NODE_T * p)
2468 {
2469 A68G_REF row;
2470 POP_REF (p, &row);
2471 genie_stand_in (p);
2472 PUSH_REF (p, row);
2473 genie_read_file_format (p);
2474 }
2475
2476 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get f
2477
2478 void genie_read_file_format (NODE_T * p)
2479 {
2480 A68G_REF row;
2481 POP_REF (p, &row);
2482 CHECK_REF (p, row, M_ROW_SIMPLIN);
2483 A68G_ARRAY *arr; A68G_TUPLE *tup;
2484 GET_DESCRIPTOR (arr, tup, &row);
2485 int elems = ROW_SIZE (tup);
2486 A68G_REF ref_file;
2487 POP_REF (p, &ref_file);
2488 CHECK_REF (p, ref_file, M_REF_FILE);
2489 A68G_FILE *file = FILE_DEREF (&ref_file);
2490 CHECK_INIT (p, INITIALISED (file), M_FILE);
2491 if (!OPENED (file)) {
2492 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
2493 exit_genie (p, A68G_RUNTIME_ERROR);
2494 }
2495 if (DRAW_MOOD (file)) {
2496 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
2497 exit_genie (p, A68G_RUNTIME_ERROR);
2498 }
2499 if (WRITE_MOOD (file)) {
2500 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
2501 exit_genie (p, A68G_RUNTIME_ERROR);
2502 }
2503 if (!GET (&CHANNEL (file))) {
2504 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
2505 exit_genie (p, A68G_RUNTIME_ERROR);
2506 }
2507 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
2508 if (IS_NIL (STRING (file))) {
2509 if ((FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0)) == A68G_NO_FILE) {
2510 open_error (p, ref_file, "getting");
2511 }
2512 } else {
2513 FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0);
2514 }
2515 DRAW_MOOD (file) = A68G_FALSE;
2516 READ_MOOD (file) = A68G_TRUE;
2517 WRITE_MOOD (file) = A68G_FALSE;
2518 CHAR_MOOD (file) = A68G_TRUE;
2519 }
2520 if (!CHAR_MOOD (file)) {
2521 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
2522 exit_genie (p, A68G_RUNTIME_ERROR);
2523 }
2524 // Save stack state since formats have frames.
2525 ADDR_T pop_fp = FRAME_POINTER (file), pop_sp = STACK_POINTER (file);
2526 FRAME_POINTER (file) = A68G_FP;
2527 STACK_POINTER (file) = A68G_SP;
2528 // Process [] SIMPLIN.
2529 if (BODY (&FORMAT (file)) != NO_NODE) {
2530 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68G_FALSE);
2531 }
2532 if (elems <= 0) {
2533 return;
2534 }
2535 int elem_index = 0, formats = 0;
2536 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
2537 for (int k = 0; k < elems; k++) {
2538 A68G_UNION *z = (A68G_UNION *) & (base_address[elem_index]);
2539 MOID_T *mode = (MOID_T *) (VALUE (z));
2540 BYTE_T *item = (BYTE_T *) & (base_address[elem_index + A68G_UNION_SIZE]);
2541 genie_read_standard_format (p, mode, item, ref_file, &formats);
2542 elem_index += SIZE (M_SIMPLIN);
2543 }
2544 // Empty the format to purge insertions.
2545 purge_format_read (p, ref_file);
2546 BODY (&FORMAT (file)) = NO_NODE;
2547 // Forget about active formats.
2548 A68G_FP = FRAME_POINTER (file);
2549 A68G_SP = STACK_POINTER (file);
2550 FRAME_POINTER (file) = pop_fp;
2551 STACK_POINTER (file) = pop_sp;
2552 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
