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-2026 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, NO_TEXT);
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, def_mult = 3;
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 // Pop user values
512 switch (size) {
513 case 1: {
514 POP_OBJECT (p, &a_after, A68G_INT);
515 VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
516 VALUE (&a_expo) = def_expo;
517 VALUE (&a_mult) = def_mult;
518 break;
519 }
520 case 2: {
521 POP_OBJECT (p, &a_mult, A68G_INT);
522 POP_OBJECT (p, &a_after, A68G_INT);
523 VALUE (&a_width) = VALUE (&a_after) + def_expo + 4;
524 VALUE (&a_expo) = def_expo;
525 break;
526 }
527 case 3: {
528 POP_OBJECT (p, &a_mult, A68G_INT);
529 POP_OBJECT (p, &a_after, A68G_INT);
530 POP_OBJECT (p, &a_width, A68G_INT);
531 VALUE (&a_expo) = def_expo;
532 break;
533 }
534 case 4: {
535 POP_OBJECT (p, &a_mult, A68G_INT);
536 POP_OBJECT (p, &a_expo, A68G_INT);
537 POP_OBJECT (p, &a_after, A68G_INT);
538 POP_OBJECT (p, &a_width, A68G_INT);
539 break;
540 }
541 default: {
542 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, M_INT);
543 exit_genie (p, A68G_RUNTIME_ERROR);
544 break;
545 }
546 }
547 PUSH_VALUE (p, VALUE (&a_width), A68G_INT);
548 PUSH_VALUE (p, VALUE (&a_after), A68G_INT);
549 PUSH_VALUE (p, VALUE (&a_expo), A68G_INT);
550 PUSH_VALUE (p, VALUE (&a_mult), A68G_INT);
551 genie_real (p);
552 }
553 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
554 }
555
556 //! @brief Write %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.
557
558 void write_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
559 {
560 ADDR_T pop_sp = A68G_SP;
561 BOOL_T right_align, sign, invalid;
562 int width = 0, after = 0, letter;
563 char *str = NO_TEXT;
564 char tmp[2]; // In same scope as str!
565 if (IS (p, CHAR_C_PATTERN)) {
566 A68G_CHAR *z = (A68G_CHAR *) item;
567 tmp[0] = (char) VALUE (z);
568 tmp[1] = NULL_CHAR;
569 str = (char *) &tmp;
570 width = (int) strlen (str);
571 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
572 } else if (IS (p, STRING_C_PATTERN)) {
573 str = (char *) item;
574 width = (int) strlen (str);
575 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
576 } else if (IS (p, INTEGRAL_C_PATTERN)) {
577 width = 0;
578 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
579 unite_to_number (p, mode, item);
580 PUSH_VALUE (p, (sign ? width : -width), A68G_INT);
581 str = whole (p);
582 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
583 int att = ATTRIBUTE (p), expval = 0, expo = 0;
584 if (att == FLOAT_C_PATTERN || att == GENERAL_C_PATTERN) {
585 int digits = 0;
586 if (mode == M_REAL || mode == M_INT) {
587 width = A68G_REAL_WIDTH + A68G_EXP_WIDTH + 4;
588 after = A68G_REAL_WIDTH - 1;
589 expo = A68G_EXP_WIDTH + 1;
590 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
591 width = A68G_LONG_REAL_WIDTH + A68G_LONG_EXP_WIDTH + 4;
592 after = A68G_LONG_REAL_WIDTH - 1;
593 expo = A68G_LONG_EXP_WIDTH + 1;
594 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
595 width = A68G_LONG_LONG_REAL_WIDTH + A68G_LONG_LONG_EXP_WIDTH + 4;
596 after = A68G_LONG_LONG_REAL_WIDTH - 1;
597 expo = A68G_LONG_LONG_EXP_WIDTH + 1;
598 }
599 scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
600 if (digits == 0 && after > 0) {
601 width = after + expo + 4;
602 } else if (digits > 0) {
603 width = digits;
604 }
605 unite_to_number (p, mode, item);
606 PUSH_VALUE (p, (sign ? width : -width), A68G_INT);
607 PUSH_VALUE (p, after, A68G_INT);
608 PUSH_VALUE (p, expo, A68G_INT);
609 PUSH_VALUE (p, 1, A68G_INT);
610 str = real (p);
611 A68G_SP = pop_sp;
612 }
613 if (att == GENERAL_C_PATTERN) {
614 char *expch = strchr (str, EXPONENT_CHAR);
615 if (expch != NO_TEXT) {
616 expval = (int) strtol (&(expch[1]), NO_REF, 10);
617 }
618 }
619 if ((att == FIXED_C_PATTERN) || (att == GENERAL_C_PATTERN && (expval > -4 && expval <= after))) {
620 int digits = 0;
621 if (mode == M_REAL || mode == M_INT) {
622 width = A68G_REAL_WIDTH + 2;
623 after = A68G_REAL_WIDTH - 1;
624 } else if (mode == M_LONG_REAL || mode == M_LONG_INT) {
625 width = A68G_LONG_REAL_WIDTH + 2;
626 after = A68G_LONG_REAL_WIDTH - 1;
627 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
628 width = A68G_LONG_LONG_REAL_WIDTH + 2;
629 after = A68G_LONG_LONG_REAL_WIDTH - 1;
630 }
631 scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter);
632 if (digits == 0) {
633 width = 0;
634 } else if (digits > 0) {
635 width = digits + after + 2;
636 }
637 unite_to_number (p, mode, item);
638 PUSH_VALUE (p, (sign ? width : -width), A68G_INT);
639 PUSH_VALUE (p, after, A68G_INT);
640 str = fixed (p);
641 A68G_SP = pop_sp;
642 }
643 } else if (IS (p, BITS_C_PATTERN)) {
644 int radix = 10, nibble = 1;
645 width = 0;
646 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
647 if (letter == FORMAT_ITEM_B) {
648 radix = 2;
649 nibble = 1;
650 } else if (letter == FORMAT_ITEM_O) {
651 radix = 8;
652 nibble = 3;
653 } else if (letter == FORMAT_ITEM_X) {
654 radix = 16;
655 nibble = 4;
656 }
657 if (width == 0) {
658 if (mode == M_BITS) {
659 width = (int) ceil ((REAL_T) A68G_BITS_WIDTH / (REAL_T) nibble);
660 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
661 #if (A68G_LEVEL <= 2)
662 width = (int) ceil ((REAL_T) get_mp_bits_width (mode) / (REAL_T) nibble);
663 #else
664 width = (int) ceil ((REAL_T) A68G_LONG_BITS_WIDTH / (REAL_T) nibble);
665 #endif
666 }
667 }
668 if (mode == M_BITS) {
669 A68G_BITS *z = (A68G_BITS *) item;
670 reset_transput_buffer (EDIT_BUFFER);
671 if (!convert_radix (p, VALUE (z), radix, width)) {
672 errno = EDOM;
673 value_error (p, mode, ref_file);
674 }
675 str = get_transput_buffer (EDIT_BUFFER);
676 } else if (mode == M_LONG_BITS) {
677 #if (A68G_LEVEL >= 3)
678 A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
679 reset_transput_buffer (EDIT_BUFFER);
680 if (!convert_radix_double (p, VALUE (z), radix, width)) {
681 errno = EDOM;
682 value_error (p, mode, ref_file);
683 }
684 str = get_transput_buffer (EDIT_BUFFER);
685 #else
686 int digits = DIGITS (mode);
687 MP_T *u = (MP_T *) item;
688 MP_T *v = nil_mp (p, digits);
689 MP_T *w = nil_mp (p, digits);
690 reset_transput_buffer (EDIT_BUFFER);
691 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
692 errno = EDOM;
693 value_error (p, mode, ref_file);
694 }
695 str = get_transput_buffer (EDIT_BUFFER);
696 #endif
697 } else if (mode == M_LONG_LONG_BITS) {
698 #if (A68G_LEVEL <= 2)
699 int digits = DIGITS (mode);
700 MP_T *u = (MP_T *) item;
701 MP_T *v = nil_mp (p, digits);
702 MP_T *w = nil_mp (p, digits);
703 reset_transput_buffer (EDIT_BUFFER);
704 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
705 errno = EDOM;
706 value_error (p, mode, ref_file);
707 }
708 str = get_transput_buffer (EDIT_BUFFER);
709 #endif
710 }
711 }
712 // Did the conversion succeed?.
713 if (IS (p, CHAR_C_PATTERN) || IS (p, STRING_C_PATTERN)) {
714 invalid = A68G_FALSE;
715 } else {
716 invalid = (strchr (str, ERROR_CHAR) != NO_TEXT);
717 }
718 if (invalid) {
719 value_error (p, mode, ref_file);
720 (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
721 } else {
722 // Align and output.
723 if (width == 0) {
724 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
725 } else {
726 if (right_align == A68G_TRUE) {
727 while (str[0] == BLANK_CHAR) {
728 str++;
729 }
730 int blanks = width - strlen (str);
731 if (blanks >= 0) {
732 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
733 while (blanks--) {
734 plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
735 }
736 } else {
737 value_error (p, mode, ref_file);
738 (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
739 }
740 } else {
741 while (str[0] == BLANK_CHAR) {
742 str++;
743 }
744 int blanks = width - strlen (str);
745 if (blanks >= 0) {
746 while (blanks--) {
747 plusab_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR);
748 }
749 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
750 } else {
751 value_error (p, mode, ref_file);
752 (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width);
753 }
754 }
755 }
756 }
757 }
758
759 //! @brief Read one char from file.
760
761 char read_single_char (NODE_T * p, A68G_REF ref_file)
762 {
763 A68G_FILE *file = FILE_DEREF (&ref_file);
764 int ch = char_scanner (file);
765 if (ch == EOF_CHAR) {
766 end_of_file_error (p, ref_file);
767 }
768 return (char) ch;
769 }
770
771 //! @brief Scan n chars from file to input buffer.
772
773 void scan_n_chars (NODE_T * p, int n, MOID_T * m, A68G_REF ref_file)
774 {
775 (void) m;
776 for (int k = 0; k < n; k++) {
777 int ch = read_single_char (p, ref_file);
778 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
779 }
780 }
781
782 //! @brief Read %[-][+][w][.][d]s/d/i/f/e/b/o/x formats.
783
784 void read_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
785 {
786 ADDR_T pop_sp = A68G_SP;
787 BOOL_T right_align, sign;
788 int width, after, letter;
789 reset_transput_buffer (INPUT_BUFFER);
790 if (IS (p, CHAR_C_PATTERN)) {
791 width = 0;
792 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
793 if (width == 0) {
794 genie_read_standard (p, mode, item, ref_file);
795 } else {
796 scan_n_chars (p, width, mode, ref_file);
797 if (width > 1 && right_align == A68G_FALSE) {
798 for (; width > 1; width--) {
799 (void) pop_char_transput_buffer (INPUT_BUFFER);
800 }
801 }
802 genie_string_to_value (p, mode, item, ref_file);
803 }
804 } else if (IS (p, STRING_C_PATTERN)) {
805 width = 0;
806 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
807 if (width == 0) {
808 genie_read_standard (p, mode, item, ref_file);
809 } else {
810 scan_n_chars (p, width, mode, ref_file);
811 genie_string_to_value (p, mode, item, ref_file);
812 }
813 } else if (IS (p, INTEGRAL_C_PATTERN)) {
814 if (mode != M_INT && mode != M_LONG_INT && mode != M_LONG_LONG_INT) {
815 pattern_error (p, mode, ATTRIBUTE (p));
816 } else {
817 width = 0;
818 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
819 if (width == 0) {
820 genie_read_standard (p, mode, item, ref_file);
821 } else {
822 scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
823 genie_string_to_value (p, mode, item, ref_file);
824 }
825 }
826 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
827 if (mode != M_REAL && mode != M_LONG_REAL && mode != M_LONG_LONG_REAL) {
828 pattern_error (p, mode, ATTRIBUTE (p));
829 } else {
830 width = 0;
831 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
832 if (width == 0) {
833 genie_read_standard (p, mode, item, ref_file);
834 } else {
835 scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file);
836 genie_string_to_value (p, mode, item, ref_file);
837 }
838 }
839 } else if (IS (p, BITS_C_PATTERN)) {
840 if (mode != M_BITS && mode != M_LONG_BITS && mode != M_LONG_LONG_BITS) {
841 pattern_error (p, mode, ATTRIBUTE (p));
842 } else {
843 int radix = 10;
844 char *str;
845 width = 0;
846 scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter);
847 if (letter == FORMAT_ITEM_B) {
848 radix = 2;
849 } else if (letter == FORMAT_ITEM_O) {
850 radix = 8;
851 } else if (letter == FORMAT_ITEM_X) {
852 radix = 16;
853 }
854 str = get_transput_buffer (INPUT_BUFFER);
855 if (width == 0) {
856 A68G_FILE *file = FILE_DEREF (&ref_file);
857 int ch;
858 ASSERT (a68g_bufprt (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
859 set_transput_buffer_index (INPUT_BUFFER, strlen (str));
860 ch = char_scanner (file);
861 while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) {
862 if (IS_NL_FF (ch)) {
863 skip_nl_ff (p, &ch, ref_file);
864 } else {
865 ch = char_scanner (file);
866 }
867 }
868 while (ch != EOF_CHAR && IS_XDIGIT (ch)) {
869 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
870 ch = char_scanner (file);
871 }
872 unchar_scanner (p, file, (char) ch);
873 } else {
874 ASSERT (a68g_bufprt (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
875 set_transput_buffer_index (INPUT_BUFFER, strlen (str));
876 scan_n_chars (p, width, mode, ref_file);
877 }
878 genie_string_to_value (p, mode, item, ref_file);
879 }
880 }
881 A68G_SP = pop_sp;
882 }
883
884 // INTEGRAL, REAL, COMPLEX and BITS patterns.
885
886 //! @brief Count Z and D frames in a mould.
887
888 void count_zd_frames (NODE_T * p, int *z)
889 {
890 for (; p != NO_NODE; FORWARD (p)) {
891 if (IS (p, FORMAT_ITEM_D) || IS (p, FORMAT_ITEM_Z)) {
892 (*z)++;
893 } else if (IS (p, REPLICATOR)) {
894 int k = get_replicator_value (SUB (p), A68G_TRUE);
895 for (int j = 1; j <= k; j++) {
896 count_zd_frames (NEXT (p), z);
897 }
898 return;
899 } else {
900 count_zd_frames (SUB (p), z);
901 }
902 }
903 }
904
905 //! @brief Get sign from sign mould.
906
907 NODE_T *get_sign (NODE_T * p)
908 {
909 for (; p != NO_NODE; FORWARD (p)) {
910 NODE_T *q = get_sign (SUB (p));
911 if (q != NO_NODE) {
912 return q;
913 } else if (IS (p, FORMAT_ITEM_PLUS) || IS (p, FORMAT_ITEM_MINUS)) {
914 return p;
915 }
916 }
917 return NO_NODE;
918 }
919
920 //! @brief Shift sign through Z frames until non-zero digit or D frame.
921
922 void shift_sign (NODE_T * p, char **q)
923 {
924 for (; p != NO_NODE && (*q) != NO_TEXT; FORWARD (p)) {
925 shift_sign (SUB (p), q);
926 if (IS (p, FORMAT_ITEM_Z)) {
927 if (((*q)[0] == '+' || (*q)[0] == '-') && (*q)[1] == '0') {
928 char ch = (*q)[0];
929 (*q)[0] = (*q)[1];
930 (*q)[1] = ch;
931 (*q)++;
932 }
933 } else if (IS (p, FORMAT_ITEM_D)) {
934 (*q) = NO_TEXT;
935 } else if (IS (p, REPLICATOR)) {
936 int k = get_replicator_value (SUB (p), A68G_TRUE);
937 for (int j = 1; j <= k; j++) {
938 shift_sign (NEXT (p), q);
939 }
940 return;
941 }
942 }
943 }
944
945 //! @brief Pad trailing blanks to integral until desired width.
946
947 void put_zeroes_to_integral (NODE_T * p, int n)
948 {
949 for (; n > 0; n--) {
950 plusab_transput_buffer (p, EDIT_BUFFER, '0');
951 }
952 }
953
954 //! @brief Pad a sign to integral representation.
955
956 void put_sign_to_integral (NODE_T * p, int sign)
957 {
958 NODE_T *sign_node = get_sign (SUB (p));
959 if (IS (sign_node, FORMAT_ITEM_PLUS)) {
960 plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? '+' : '-'));
961 } else {
962 plusab_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? BLANK_CHAR : '-'));
963 }
964 }
965
966 //! @brief Write point, exponent or plus-i-times symbol.
967
968 void write_pie_frame (NODE_T * p, A68G_REF ref_file, int att, int sym)
969 {
970 for (; p != NO_NODE; FORWARD (p)) {
971 if (IS (p, INSERTION)) {
972 write_insertion (p, ref_file, INSERTION_NORMAL);
973 } else if (IS (p, att)) {
974 write_pie_frame (SUB (p), ref_file, att, sym);
975 return;
976 } else if (IS (p, sym)) {
977 add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p));
978 } else if (IS (p, FORMAT_ITEM_S)) {
979 return;
980 }
981 }
982 }
983
984 //! @brief Write sign when appropriate.
985
986 void write_mould_put_sign (NODE_T * p, char **q)
987 {
988 if ((*q)[0] == '+' || (*q)[0] == '-' || (*q)[0] == BLANK_CHAR) {
989 plusab_transput_buffer (p, FORMATTED_BUFFER, (*q)[0]);
990 (*q)++;
991 }
992 }
993
994 //! @brief Write character according to a mould.
995
996 void add_char_mould (NODE_T * p, char ch, char **q)
997 {
998 if (ch != NULL_CHAR) {
999 plusab_transput_buffer (p, FORMATTED_BUFFER, ch);
1000 (*q)++;
1001 }
1002 }
1003
1004 //! @brief Write string according to a mould.
1005
1006 void write_mould (NODE_T * p, A68G_REF ref_file, int type, char **q, MOOD_T * mood)
1007 {
1008 for (; p != NO_NODE; FORWARD (p)) {
1009 // Insertions are inserted straight away. Note that we can suppress them using "mood", which is not standard A68.
1010 if (IS (p, INSERTION)) {
1011 write_insertion (SUB (p), ref_file, *mood);
1012 } else {
1013 write_mould (SUB (p), ref_file, type, q, mood);
1014 // Z frames print blanks until first non-zero digits comes.
1015 if (IS (p, FORMAT_ITEM_Z)) {
1016 write_mould_put_sign (p, q);
1017 if ((*q)[0] == '0') {
1018 if (*mood & DIGIT_BLANK) {
1019 add_char_mould (p, BLANK_CHAR, q);
1020 *mood = (*mood & ~INSERTION_NORMAL) | INSERTION_BLANK;
1021 } else if (*mood & DIGIT_NORMAL) {
1022 add_char_mould (p, '0', q);
1023 *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1024 }
1025 } else {
1026 add_char_mould (p, (*q)[0], q);
1027 *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1028 }
1029 }
1030 // D frames print a digit.
1031 else if (IS (p, FORMAT_ITEM_D)) {
1032 write_mould_put_sign (p, q);
1033 add_char_mould (p, (*q)[0], q);
1034 *mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1035 }
1036 // Suppressible frames.
1037 else if (IS (p, FORMAT_ITEM_S)) {
1038 // Suppressible frames are ignored in a sign-mould.
1039 if (type == SIGN_MOULD) {
1040 write_mould (NEXT (p), ref_file, type, q, mood);
1041 } else if (type == INTEGRAL_MOULD) {
1042 if ((*q)[0] != NULL_CHAR) {
1043 (*q)++;
1044 }
1045 }
1046 return;
1047 }
1048 // Replicator.
1049 else if (IS (p, REPLICATOR)) {
1050 int k = get_replicator_value (SUB (p), A68G_TRUE);
1051 for (int j = 1; j <= k; j++) {
1052 write_mould (NEXT (p), ref_file, type, q, mood);
1053 }
1054 return;
1055 }
1056 }
1057 }
1058 }
1059
1060 //! @brief Write INT value using int pattern.
1061
1062 void write_integral_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68G_REF ref_file)
1063 {
1064 errno = 0;
1065 if (!(mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT)) {
1066 pattern_error (p, root, ATTRIBUTE (p));
1067 } else {
1068 ADDR_T pop_sp = A68G_SP;
1069 char *str = "*";
1070 int width = 0, sign = 0;
1071 MOOD_T mood;
1072 // Dive into the pattern if needed.
1073 if (IS (p, INTEGRAL_PATTERN)) {
1074 p = SUB (p);
1075 }
1076 // Find width.
1077 count_zd_frames (p, &width);
1078 // Make string.
1079 reset_transput_buffer (EDIT_BUFFER);
1080 int digits = DIGITS (M_LONG_LONG_INT);
1081 MP_T *z = nil_mp (p, digits);
1082 if (mode == M_INT) {
1083 int_to_mp (p, z, VALUE ((A68G_INT *) item), digits);
1084 } else if (mode == M_LONG_INT) {
1085 #if (A68G_LEVEL >= 3)
1086 DOUBLE_NUM_T w = VALUE ((A68G_LONG_INT *) item);
1087 double_int_to_mp (p, z, w, digits);
1088 #else
1089 (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_INT));
1090 #endif
1091 } else if (mode == M_LONG_LONG_INT) {
1092 (void) move_mp (z, (MP_T *) item, digits);
1093 }
1094 sign = MP_SIGN (z);
1095 MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1));
1096 str = sub_whole_mp (p, z, digits, width);
1097 // Edit string and output.
1098 if (strchr (str, ERROR_CHAR) != NO_TEXT) {
1099 value_error (p, root, ref_file);
1100 }
1101 if (IS (p, SIGN_MOULD)) {
1102 put_sign_to_integral (p, sign);
1103 } else if (sign < 0) {
1104 value_sign_error (p, root, ref_file);
1105 }
1106 put_zeroes_to_integral (p, width - strlen (str));
1107 add_string_transput_buffer (p, EDIT_BUFFER, str);
1108 str = get_transput_buffer (EDIT_BUFFER);
1109 mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1110 if (IS (p, SIGN_MOULD)) {
1111 if (str[0] == '+' || str[0] == '-') {
1112 shift_sign (SUB (p), &str);
1113 }
1114 str = get_transput_buffer (EDIT_BUFFER);
1115 write_mould (SUB (p), ref_file, SIGN_MOULD, &str, &mood);
1116 FORWARD (p);
1117 }
1118 if (IS (p, INTEGRAL_MOULD)) { // This *should* be the case
1119 write_mould (SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
1120 }
1121 A68G_SP = pop_sp;
1122 }
1123 }
1124
1125 //! @brief Write REAL value using real pattern.
1126
1127 void write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68G_REF ref_file)
1128 {
1129 errno = 0;
1130 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)) {
1131 pattern_error (p, root, ATTRIBUTE (p));
1132 } else {
1133 ADDR_T pop_sp = A68G_SP;
1134 int stag_digits = 0, frac_digits = 0, expo_digits = 0;
1135 int mant_length, sign = 0, exp_value;
1136 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;
1137 char *str = NO_TEXT, *stag_str = NO_TEXT, *frac_str = NO_TEXT;
1138 MOOD_T mood;
1139 // Dive into pattern.
1140 q = ((IS (p, REAL_PATTERN)) ? SUB (p) : p);
1141 // Dissect pattern and establish widths.
1142 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
1143 sign_mould = q;
1144 count_zd_frames (SUB (sign_mould), &stag_digits);
1145 FORWARD (q);
1146 }
1147 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
1148 stag_mould = q;
1149 count_zd_frames (SUB (stag_mould), &stag_digits);
1150 FORWARD (q);
1151 }
1152 if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
1153 point_frame = q;
1154 FORWARD (q);
1155 }
1156 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
1157 frac_mould = q;
1158 count_zd_frames (SUB (frac_mould), &frac_digits);
1159 FORWARD (q);
1160 }
1161 if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
1162 e_frame = SUB (q);
1163 expo_mould = NEXT_SUB (q);
1164 q = expo_mould;
1165 if (IS (q, SIGN_MOULD)) {
1166 count_zd_frames (SUB (q), &expo_digits);
1167 FORWARD (q);
1168 }
1169 if (IS (q, INTEGRAL_MOULD)) {
1170 count_zd_frames (SUB (q), &expo_digits);
1171 }
1172 }
1173 // Make string representation.
1174 if (point_frame == NO_NODE) {
1175 mant_length = stag_digits;
1176 } else {
1177 mant_length = 1 + stag_digits + frac_digits;
1178 }
1179 //
1180 ADDR_T pop_sp2 = A68G_SP;
1181 int digits = DIGITS (M_LONG_LONG_REAL);
1182 MP_T *z = nil_mp (p, digits);
1183 if (mode == M_INT) {
1184 INT_T x = VALUE ((A68G_INT *) item);
1185 (void) int_to_mp (p, z, x, digits);
1186 } else if (mode == M_REAL) {
1187 REAL_T x = VALUE ((A68G_REAL *) item);
1188 CHECK_REAL (p, x);
1189 #if (A68G_LEVEL >= 3)
1190 (void) double_to_mp (p, z, (DOUBLE_T) x, A68G_REAL_DIG + 1, A68G_TRUE, digits);
1191 #else
1192 (void) real_to_mp (p, z, x, digits);
1193 #endif
1194 } else if (mode == M_LONG_INT) {
1195 #if (A68G_LEVEL >= 3)
1196 DOUBLE_NUM_T x = VALUE ((A68G_DOUBLE *) item);
1197 (void) double_int_to_mp (p, z, x, digits);
1198 #else
1199 (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_INT));
1200 #endif
1201 } else if (mode == M_LONG_REAL) {
1202 #if (A68G_LEVEL >= 3)
1203 DOUBLE_T x = VALUE ((A68G_DOUBLE *) item).f;
1204 CHECK_DOUBLE_REAL (p, x);
1205 (void) double_to_mp (p, z, x, A68G_DOUBLE_DIG, A68G_TRUE, digits);
1206 #else
1207 (void) lengthen_mp (p, z, digits, (MP_T *) item, DIGITS (M_LONG_REAL));
1208 #endif
1209 } else if (mode == M_LONG_LONG_REAL || mode == M_LONG_LONG_INT) {
1210 (void) move_mp (z, (MP_T *) item, digits);
1211 }
1212 exp_value = 0;
1213 sign = SIGN (z[2]);
1214 if (sign_mould != NO_NODE) {
1215 put_sign_to_integral (sign_mould, sign);
1216 }
1217 z[2] = ABS (z[2]);
1218 if (expo_mould != NO_NODE) {
1219 standardize_mp (p, z, digits, stag_digits, frac_digits, &exp_value);
1220 }
1221 str = sub_fixed_mp (p, z, digits, mant_length, frac_digits);
1222 A68G_SP = pop_sp2;
1223 // Edit and output the string.
1224 if (strchr (str, ERROR_CHAR) != NO_TEXT) {
1225 value_error (p, root, ref_file);
1226 }
1227 reset_transput_buffer (STRING_BUFFER);
1228 add_string_transput_buffer (p, STRING_BUFFER, str);
1229 stag_str = get_transput_buffer (STRING_BUFFER);
1230 if (strchr (stag_str, ERROR_CHAR) != NO_TEXT) {
1231 value_error (p, root, ref_file);
1232 }
1233 str = strchr (stag_str, POINT_CHAR);
1234 if (str != NO_TEXT) {
1235 frac_str = &str[1];
1236 str[0] = NULL_CHAR;
1237 } else {
1238 frac_str = NO_TEXT;
1239 }
1240 // Stagnant part.
1241 reset_transput_buffer (EDIT_BUFFER);
1242 if (sign_mould != NO_NODE) {
1243 put_sign_to_integral (sign_mould, sign);
1244 } else if (sign < 0) {
1245 value_sign_error (sign_mould, root, ref_file);
1246 }
1247 put_zeroes_to_integral (p, stag_digits - strlen (stag_str));
1248 add_string_transput_buffer (p, EDIT_BUFFER, stag_str);
1249 stag_str = get_transput_buffer (EDIT_BUFFER);
1250 mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1251 if (sign_mould != NO_NODE) {
1252 if (stag_str[0] == '+' || stag_str[0] == '-') {
1253 shift_sign (SUB (p), &stag_str);
1254 }
1255 stag_str = get_transput_buffer (EDIT_BUFFER);
1256 write_mould (SUB (sign_mould), ref_file, SIGN_MOULD, &stag_str, &mood);
1257 }
1258 if (stag_mould != NO_NODE) {
1259 write_mould (SUB (stag_mould), ref_file, INTEGRAL_MOULD, &stag_str, &mood);
1260 }
1261 // Point frame.
1262 if (point_frame != NO_NODE) {
1263 write_pie_frame (point_frame, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT);
1264 }
1265 // Fraction.
1266 if (frac_mould != NO_NODE) {
1267 reset_transput_buffer (EDIT_BUFFER);
1268 add_string_transput_buffer (p, EDIT_BUFFER, frac_str);
1269 frac_str = get_transput_buffer (EDIT_BUFFER);
1270 mood = (MOOD_T) (DIGIT_NORMAL | INSERTION_NORMAL);
1271 write_mould (SUB (frac_mould), ref_file, INTEGRAL_MOULD, &frac_str, &mood);
1272 }
1273 // Exponent.
1274 if (expo_mould != NO_NODE) {
1275 A68G_INT k;
1276 STATUS (&k) = INIT_MASK;
1277 VALUE (&k) = exp_value;
1278 if (e_frame != NO_NODE) {
1279 write_pie_frame (e_frame, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E);
1280 }
1281 write_integral_pattern (expo_mould, M_INT, root, (BYTE_T *) & k, ref_file);
1282 }
1283 A68G_SP = pop_sp;
1284 }
1285 }
1286
1287 //! @brief Write COMPLEX value using complex pattern.
1288
1289 void write_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * root, BYTE_T * re, BYTE_T * im, A68G_REF ref_file)
1290 {
1291 errno = 0;
1292 // Dissect pattern.
1293 NODE_T *reel = SUB (p);
1294 NODE_T *plus_i_times = NEXT (reel);
1295 NODE_T *imag = NEXT (plus_i_times);
1296 // Write pattern.
1297 write_real_pattern (reel, comp, root, re, ref_file);
1298 write_pie_frame (plus_i_times, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I);
1299 write_real_pattern (imag, comp, root, im, ref_file);
1300 }
1301
1302 //! @brief Write BITS value using bits pattern.
1303
1304 void write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
1305 {
1306 ADDR_T pop_sp = A68G_SP;
1307 int width = 0, radix;
1308 char *str;
1309 if (mode == M_BITS) {
1310 A68G_BITS *z = (A68G_BITS *) item;
1311 // Establish width and radix.
1312 count_zd_frames (SUB (p), &width);
1313 radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
1314 if (radix < 2 || radix > 16) {
1315 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1316 exit_genie (p, A68G_RUNTIME_ERROR);
1317 }
1318 // Generate string of correct width.
1319 reset_transput_buffer (EDIT_BUFFER);
1320 if (!convert_radix (p, VALUE (z), radix, width)) {
1321 errno = EDOM;
1322 value_error (p, mode, ref_file);
1323 }
1324 } else if (mode == M_LONG_BITS) {
1325 #if (A68G_LEVEL >= 3)
1326 A68G_LONG_BITS *z = (A68G_LONG_BITS *) item;
1327 // Establish width and radix.
1328 count_zd_frames (SUB (p), &width);
1329 radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
1330 if (radix < 2 || radix > 16) {
1331 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1332 exit_genie (p, A68G_RUNTIME_ERROR);
1333 }
1334 // Generate string of correct width.
1335 reset_transput_buffer (EDIT_BUFFER);
1336 if (!convert_radix_double (p, VALUE (z), radix, width)) {
1337 errno = EDOM;
1338 value_error (p, mode, ref_file);
1339 }
1340 #else
1341 int digits = DIGITS (mode);
1342 MP_T *u = (MP_T *) item;
1343 MP_T *v = nil_mp (p, digits);
1344 MP_T *w = nil_mp (p, digits);
1345 // Establish width and radix.
1346 count_zd_frames (SUB (p), &width);
1347 radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
1348 if (radix < 2 || radix > 16) {
1349 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1350 exit_genie (p, A68G_RUNTIME_ERROR);
1351 }
1352 // Generate string of correct width.
1353 reset_transput_buffer (EDIT_BUFFER);
1354 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
1355 errno = EDOM;
1356 value_error (p, mode, ref_file);
1357 }
1358 #endif
1359 } else if (mode == M_LONG_LONG_BITS) {
1360 #if (A68G_LEVEL <= 2)
1361 int digits = DIGITS (mode);
1362 MP_T *u = (MP_T *) item;
1363 MP_T *v = nil_mp (p, digits);
1364 MP_T *w = nil_mp (p, digits);
1365 // Establish width and radix.
1366 count_zd_frames (SUB (p), &width);
1367 radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
1368 if (radix < 2 || radix > 16) {
1369 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
1370 exit_genie (p, A68G_RUNTIME_ERROR);
1371 }
1372 // Generate string of correct width.
1373 reset_transput_buffer (EDIT_BUFFER);
1374 if (!convert_radix_mp (p, u, radix, width, mode, v, w)) {
1375 errno = EDOM;
1376 value_error (p, mode, ref_file);
1377 }
1378 #endif
1379 }
1380 // Output the edited string.
1381 MOOD_T mood = (MOOD_T) (DIGIT_BLANK | INSERTION_NORMAL);
1382 str = get_transput_buffer (EDIT_BUFFER);
1383 write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood);
1384 A68G_SP = pop_sp;
1385 }
1386
1387 //! @brief Write value to file.
1388
1389 void genie_write_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
1390 {
1391 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1392 genie_value_to_string (p, M_REAL, item, ATTRIBUTE (SUB (p)));
1393 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1394 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1395 write_number_generic (p, M_REAL, item, ATTRIBUTE (SUB (p)));
1396 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1397 write_c_pattern (p, M_REAL, item, ref_file);
1398 } else if (IS (p, REAL_PATTERN)) {
1399 write_real_pattern (p, M_REAL, M_REAL, item, ref_file);
1400 } else if (IS (p, COMPLEX_PATTERN)) {
1401 A68G_REAL im;
1402 STATUS (&im) = INIT_MASK;
1403 VALUE (&im) = 0.0;
1404 write_complex_pattern (p, M_REAL, M_COMPLEX, (BYTE_T *) item, (BYTE_T *) & im, ref_file);
1405 } else {
1406 pattern_error (p, M_REAL, ATTRIBUTE (p));
1407 }
1408 }
1409
1410 //! @brief Write value to file.
1411
1412 void genie_write_long_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
1413 {
1414 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1415 genie_value_to_string (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1416 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1417 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1418 write_number_generic (p, M_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1419 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1420 write_c_pattern (p, M_LONG_REAL, item, ref_file);
1421 } else if (IS (p, REAL_PATTERN)) {
1422 write_real_pattern (p, M_LONG_REAL, M_LONG_REAL, item, ref_file);
1423 } else if (IS (p, COMPLEX_PATTERN)) {
1424 #if (A68G_LEVEL >= 3)
1425 ADDR_T pop_sp = A68G_SP;
1426 A68G_LONG_REAL *z = (A68G_LONG_REAL *) STACK_TOP;
1427 DOUBLE_NUM_T im;
1428 im.f = 0.0q;
1429 PUSH_VALUE (p, im, A68G_LONG_REAL);
1430 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1431 A68G_SP = pop_sp;
1432 #else
1433 ADDR_T pop_sp = A68G_SP;
1434 MP_T *z = nil_mp (p, DIGITS (M_LONG_REAL));
1435 z[0] = (MP_T) INIT_MASK;
1436 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1437 A68G_SP = pop_sp;
1438 #endif
1439 } else {
1440 pattern_error (p, M_LONG_REAL, ATTRIBUTE (p));
1441 }
1442 }
1443
1444 //! @brief Write value to file.
1445
1446 void genie_write_long_mp_real_format (NODE_T * p, BYTE_T * item, A68G_REF ref_file)
1447 {
1448 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
1449 genie_value_to_string (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1450 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1451 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1452 write_number_generic (p, M_LONG_LONG_REAL, item, ATTRIBUTE (SUB (p)));
1453 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
1454 write_c_pattern (p, M_LONG_LONG_REAL, item, ref_file);
1455 } else if (IS (p, REAL_PATTERN)) {
1456 write_real_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_REAL, item, ref_file);
1457 } else if (IS (p, COMPLEX_PATTERN)) {
1458 ADDR_T pop_sp = A68G_SP;
1459 MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
1460 z[0] = (MP_T) INIT_MASK;
1461 write_complex_pattern (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1462 A68G_SP = pop_sp;
1463 } else {
1464 pattern_error (p, M_LONG_LONG_REAL, ATTRIBUTE (p));
1465 }
1466 }
1467
1468 //! @brief At end of write purge all insertions.
1469
1470 void purge_format_write (NODE_T * p, A68G_REF ref_file)
1471 {
1472 // Problem here is shutting down embedded formats.
1473 BOOL_T siga;
1474 do {
1475 A68G_FILE *file;
1476 NODE_T *dollar, *pat;
1477 A68G_FORMAT *old_fmt;
1478 while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
1479 format_error (p, ref_file, ERROR_FORMAT_PICTURES);
1480 }
1481 file = FILE_DEREF (&ref_file);
1482 dollar = SUB (BODY (&FORMAT (file)));
1483 old_fmt = (A68G_FORMAT *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (dollar)));
1484 siga = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
1485 if (siga) {
1486 // Pop embedded format and proceed.
1487 (void) end_of_format (p, ref_file);
1488 }
1489 } while (siga);
1490 }
1491
1492 //! @brief Write value to file.
1493
1494 void genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file, int *formats)
1495 {
1496 errno = 0;
1497 ABEND (mode == NO_MOID, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);
1498 if (mode == M_FORMAT) {
1499 A68G_FILE *file;
1500 CHECK_REF (p, ref_file, M_REF_FILE);
1501 file = FILE_DEREF (&ref_file);
1502 // Forget about eventual active formats and set up new one.
1503 if (*formats > 0) {
1504 purge_format_write (p, ref_file);
1505 }
1506 (*formats)++;
1507 A68G_FP = FRAME_POINTER (file);
1508 A68G_SP = STACK_POINTER (file);
1509 open_format_frame (p, ref_file, (A68G_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68G_TRUE);
1510 } else if (mode == M_PROC_REF_FILE_VOID) {
1511 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
1512 exit_genie (p, A68G_RUNTIME_ERROR);
1513 } else if (mode == M_SOUND) {
1514 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_SOUND);
1515 exit_genie (p, A68G_RUNTIME_ERROR);
1516 } else if (mode == M_INT) {
1517 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1518 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1519 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1520 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1521 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1522 write_number_generic (pat, M_INT, item, ATTRIBUTE (SUB (pat)));
1523 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1524 write_c_pattern (pat, M_INT, item, ref_file);
1525 } else if (IS (pat, INTEGRAL_PATTERN)) {
1526 write_integral_pattern (pat, M_INT, M_INT, item, ref_file);
1527 } else if (IS (pat, REAL_PATTERN)) {
1528 write_real_pattern (pat, M_INT, M_INT, item, ref_file);
1529 } else if (IS (pat, COMPLEX_PATTERN)) {
1530 A68G_REAL re, im;
1531 STATUS (&re) = INIT_MASK;
1532 VALUE (&re) = (REAL_T) VALUE ((A68G_INT *) item);
1533 STATUS (&im) = INIT_MASK;
1534 VALUE (&im) = 0.0;
1535 write_complex_pattern (pat, M_REAL, M_COMPLEX, (BYTE_T *) & re, (BYTE_T *) & im, ref_file);
1536 } else if (IS (pat, CHOICE_PATTERN)) {
1537 int k = VALUE ((A68G_INT *) item);
1538 write_choice_pattern (NEXT_SUB (pat), ref_file, &k);
1539 } else {
1540 pattern_error (p, mode, ATTRIBUTE (pat));
1541 }
1542 } else if (mode == M_LONG_INT) {
1543 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1544 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1545 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1546 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1547 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1548 write_number_generic (pat, M_LONG_INT, item, ATTRIBUTE (SUB (pat)));
1549 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1550 write_c_pattern (pat, M_LONG_INT, item, ref_file);
1551 } else if (IS (pat, INTEGRAL_PATTERN)) {
1552 write_integral_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
1553 } else if (IS (pat, REAL_PATTERN)) {
1554 write_real_pattern (pat, M_LONG_INT, M_LONG_INT, item, ref_file);
1555 } else if (IS (pat, COMPLEX_PATTERN)) {
1556 #if (A68G_LEVEL >= 3)
1557 ADDR_T pop_sp = A68G_SP;
1558 A68G_LONG_REAL *z = (A68G_LONG_REAL *) STACK_TOP;
1559 DOUBLE_NUM_T im;
1560 im.f = 0.0q;
1561 PUSH_VALUE (p, im, A68G_LONG_REAL);
1562 write_complex_pattern (p, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1563 A68G_SP = pop_sp;
1564 #else
1565 ADDR_T pop_sp = A68G_SP;
1566 MP_T *z = nil_mp (p, DIGITS (mode));
1567 z[0] = (MP_T) INIT_MASK;
1568 write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1569 A68G_SP = pop_sp;
1570 #endif
1571 } else if (IS (pat, CHOICE_PATTERN)) {
1572 INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
1573 int sk;
1574 CHECK_INT_SHORTEN (p, k);
1575 sk = (int) k;
1576 write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
1577 } else {
1578 pattern_error (p, mode, ATTRIBUTE (pat));
1579 }
1580 } else if (mode == M_LONG_LONG_INT) {
1581 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1582 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1583 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat)));
1584 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1585 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
1586 write_number_generic (pat, M_LONG_LONG_INT, item, ATTRIBUTE (SUB (pat)));
1587 } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) {
1588 write_c_pattern (pat, M_LONG_LONG_INT, item, ref_file);
1589 } else if (IS (pat, INTEGRAL_PATTERN)) {
1590 write_integral_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
1591 } else if (IS (pat, REAL_PATTERN)) {
1592 write_real_pattern (pat, M_INT, M_INT, item, ref_file);
1593 } else if (IS (pat, REAL_PATTERN)) {
1594 write_real_pattern (pat, M_LONG_LONG_INT, M_LONG_LONG_INT, item, ref_file);
1595 } else if (IS (pat, COMPLEX_PATTERN)) {
1596 ADDR_T pop_sp = A68G_SP;
1597 MP_T *z = nil_mp (p, DIGITS (M_LONG_LONG_REAL));
1598 z[0] = (MP_T) INIT_MASK;
1599 write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, item, (BYTE_T *) z, ref_file);
1600 A68G_SP = pop_sp;
1601 } else if (IS (pat, CHOICE_PATTERN)) {
1602 INT_T k = mp_to_int (p, (MP_T *) item, DIGITS (mode));
1603 int sk;
1604 CHECK_INT_SHORTEN (p, k);
1605 sk = (int) k;
1606 write_choice_pattern (NEXT_SUB (pat), ref_file, &sk);
1607 } else {
1608 pattern_error (p, mode, ATTRIBUTE (pat));
1609 }
1610 } else if (mode == M_REAL) {
1611 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1612 genie_write_real_format (pat, item, ref_file);
1613 } else if (mode == M_LONG_REAL) {
1614 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1615 genie_write_long_real_format (pat, item, ref_file);
1616 } else if (mode == M_LONG_LONG_REAL) {
1617 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1618 genie_write_long_mp_real_format (pat, item, ref_file);
1619 } else if (mode == M_COMPLEX) {
1620 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1621 if (IS (pat, COMPLEX_PATTERN)) {
1622 write_complex_pattern (pat, M_REAL, M_COMPLEX, &item[0], &item[SIZE (M_REAL)], ref_file);
1623 } else {
1624 // Try writing as two REAL values.
1625 genie_write_real_format (pat, item, ref_file);
1626 genie_write_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
1627 }
1628 } else if (mode == M_LONG_COMPLEX) {
1629 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1630 if (IS (pat, COMPLEX_PATTERN)) {
1631 write_complex_pattern (pat, M_LONG_REAL, M_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_REAL)], ref_file);
1632 } else {
1633 // Try writing as two LONG REAL values.
1634 genie_write_long_real_format (pat, item, ref_file);
1635 genie_write_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
1636 }
1637 } else if (mode == M_LONG_LONG_COMPLEX) {
1638 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1639 if (IS (pat, COMPLEX_PATTERN)) {
1640 write_complex_pattern (pat, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, &item[0], &item[SIZE (M_LONG_LONG_REAL)], ref_file);
1641 } else {
1642 // Try writing as two LONG LONG REAL values.
1643 genie_write_long_mp_real_format (pat, item, ref_file);
1644 genie_write_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
1645 }
1646 } else if (mode == M_BOOL) {
1647 A68G_BOOL *z = (A68G_BOOL *) item;
1648 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1649 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1650 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68G_TRUE ? FLIP_CHAR : FLOP_CHAR));
1651 } else if (IS (pat, BOOLEAN_PATTERN)) {
1652 if (NEXT_SUB (pat) == NO_NODE) {
1653 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68G_TRUE ? FLIP_CHAR : FLOP_CHAR));
1654 } else {
1655 write_boolean_pattern (pat, ref_file, (BOOL_T) (VALUE (z) == A68G_TRUE));
1656 }
1657 } else {
1658 pattern_error (p, mode, ATTRIBUTE (pat));
1659 }
1660 } else if (mode == M_BITS) {
1661 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1662 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1663 char *str = (char *) STACK_TOP;
1664 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
1665 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
1666 } else if (IS (pat, BITS_PATTERN)) {
1667 write_bits_pattern (pat, M_BITS, item, ref_file);
1668 } else if (IS (pat, BITS_C_PATTERN)) {
1669 write_c_pattern (pat, M_BITS, item, ref_file);
1670 } else {
1671 pattern_error (p, mode, ATTRIBUTE (pat));
1672 }
1673 } else if (mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
1674 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1675 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1676 char *str = (char *) STACK_TOP;
1677 genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p)));
1678 add_string_transput_buffer (p, FORMATTED_BUFFER, str);
1679 } else if (IS (pat, BITS_PATTERN)) {
1680 write_bits_pattern (pat, mode, item, ref_file);
1681 } else if (IS (pat, BITS_C_PATTERN)) {
1682 write_c_pattern (pat, mode, item, ref_file);
1683 } else {
1684 pattern_error (p, mode, ATTRIBUTE (pat));
1685 }
1686 } else if (mode == M_CHAR) {
1687 A68G_CHAR *z = (A68G_CHAR *) item;
1688 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1689 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1690 plusab_transput_buffer (p, FORMATTED_BUFFER, (char) VALUE (z));
1691 } else if (IS (pat, STRING_PATTERN)) {
1692 char *q = get_transput_buffer (EDIT_BUFFER);
1693 reset_transput_buffer (EDIT_BUFFER);
1694 plusab_transput_buffer (p, EDIT_BUFFER, (char) VALUE (z));
1695 write_string_pattern (pat, mode, ref_file, &q);
1696 if (q[0] != NULL_CHAR) {
1697 value_error (p, mode, ref_file);
1698 }
1699 } else if (IS (pat, STRING_C_PATTERN)) {
1700 char zz[2];
1701 zz[0] = VALUE (z);
1702 zz[1] = '\0';
1703 (void) c_to_a_string (pat, zz, 1);
1704 write_c_pattern (pat, mode, (BYTE_T *) zz, ref_file);
1705 } else {
1706 pattern_error (p, mode, ATTRIBUTE (pat));
1707 }
1708 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
1709 // Handle these separately instead of printing [] CHAR.
1710 A68G_REF row = *(A68G_REF *) item;
1711 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
1712 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
1713 PUSH_REF (p, row);
1714 add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER);
1715 } else if (IS (pat, STRING_PATTERN)) {
1716 char *q;
1717 PUSH_REF (p, row);
1718 reset_transput_buffer (EDIT_BUFFER);
1719 add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
1720 q = get_transput_buffer (EDIT_BUFFER);
1721 write_string_pattern (pat, mode, ref_file, &q);
1722 if (q[0] != NULL_CHAR) {
1723 value_error (p, mode, ref_file);
1724 }
1725 } else if (IS (pat, STRING_C_PATTERN)) {
1726 char *q;
1727 PUSH_REF (p, row);
1728 reset_transput_buffer (EDIT_BUFFER);
1729 add_string_from_stack_transput_buffer (p, EDIT_BUFFER);
1730 q = get_transput_buffer (EDIT_BUFFER);
1731 write_c_pattern (pat, mode, (BYTE_T *) q, ref_file);
1732 } else {
1733 pattern_error (p, mode, ATTRIBUTE (pat));
1734 }
1735 } else if (IS_UNION (mode)) {
1736 A68G_UNION *z = (A68G_UNION *) item;
1737 MOID_T *um = (MOID_T *) (VALUE (z));
1738 BYTE_T *ui = &item[A68G_UNION_SIZE];
1739 if (um == NO_MOID) {
1740 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode);
1741 exit_genie (p, A68G_RUNTIME_ERROR);
1742 }
1743 genie_write_standard_format (p, um, ui, ref_file, formats);
1744 } else if (IS_STRUCT (mode)) {
1745 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
1746 BYTE_T *elem = &item[OFFSET (q)];
1747 genie_check_initialisation (p, elem, MOID (q));
1748 genie_write_standard_format (p, MOID (q), elem, ref_file, formats);
1749 }
1750 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
1751 MOID_T *deflexed = DEFLEX (mode);
1752 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
1753 A68G_ARRAY *arr; A68G_TUPLE *tup;
1754 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
1755 if (get_row_size (tup, DIM (arr)) > 0) {
1756 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
1757 BOOL_T done = A68G_FALSE;
1758 initialise_internal_index (tup, DIM (arr));
1759 while (!done) {
1760 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
1761 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
1762 BYTE_T *elem = &base_addr[elem_addr];
1763 genie_check_initialisation (p, elem, SUB (deflexed));
1764 genie_write_standard_format (p, SUB (deflexed), elem, ref_file, formats);
1765 done = increment_internal_index (tup, DIM (arr));
1766 }
1767 }
1768 }
1769 if (errno != 0) {
1770 transput_error (p, ref_file, mode);
1771 }
1772 }
1773
1774 //! @brief PROC ([] SIMPLOUT) VOID print f, write f
1775
1776 void genie_write_format (NODE_T * p)
1777 {
1778 A68G_REF row;
1779 POP_REF (p, &row);
1780 genie_stand_out (p);
1781 PUSH_REF (p, row);
1782 genie_write_file_format (p);
1783 }
1784
1785 //! @brief PROC (REF FILE, [] SIMPLOUT) VOID put f
1786
1787 void genie_write_file_format (NODE_T * p)
1788 {
1789 A68G_REF row;
1790 POP_REF (p, &row);
1791 CHECK_REF (p, row, M_ROW_SIMPLOUT);
1792 A68G_ARRAY *arr; A68G_TUPLE *tup;
1793 GET_DESCRIPTOR (arr, tup, &row);
1794 int elems = ROW_SIZE (tup);
1795 A68G_REF ref_file;
1796 POP_REF (p, &ref_file);
1797 CHECK_REF (p, ref_file, M_REF_FILE);
1798 A68G_FILE *file = FILE_DEREF (&ref_file);
1799 CHECK_INIT (p, INITIALISED (file), M_FILE);
1800 if (!OPENED (file)) {
1801 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
1802 exit_genie (p, A68G_RUNTIME_ERROR);
1803 }
1804 if (DRAW_MOOD (file)) {
1805 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
1806 exit_genie (p, A68G_RUNTIME_ERROR);
1807 }
1808 if (READ_MOOD (file)) {
1809 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read");
1810 exit_genie (p, A68G_RUNTIME_ERROR);
1811 }
1812 if (!PUT (&CHANNEL (file))) {
1813 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting");
1814 exit_genie (p, A68G_RUNTIME_ERROR);
1815 }
1816 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
1817 if (IS_NIL (STRING (file))) {
1818 if ((FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, A68G_PROTECTION)) == A68G_NO_FILE) {
1819 open_error (p, ref_file, "putting");
1820 }
1821 } else {
1822 FD (file) = open_physical_file (p, ref_file, A68G_WRITE_ACCESS, 0);
1823 }
1824 DRAW_MOOD (file) = A68G_FALSE;
1825 READ_MOOD (file) = A68G_FALSE;
1826 WRITE_MOOD (file) = A68G_TRUE;
1827 CHAR_MOOD (file) = A68G_TRUE;
1828 }
1829 if (!CHAR_MOOD (file)) {
1830 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
1831 exit_genie (p, A68G_RUNTIME_ERROR);
1832 }
1833 // Save stack state since formats have frames.
1834 ADDR_T pop_fp = FRAME_POINTER (file), pop_sp = STACK_POINTER (file);
1835 FRAME_POINTER (file) = A68G_FP;
1836 STACK_POINTER (file) = A68G_SP;
1837 // Process [] SIMPLOUT.
1838 if (BODY (&FORMAT (file)) != NO_NODE) {
1839 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68G_FALSE);
1840 }
1841 if (elems <= 0) {
1842 return;
1843 }
1844 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
1845 int elem_index = 0, formats = 0;
1846 for (int k = 0; k < elems; k++) {
1847 A68G_UNION *z = (A68G_UNION *) & (base_address[elem_index]);
1848 MOID_T *mode = (MOID_T *) (VALUE (z));
1849 BYTE_T *item = &(base_address[elem_index + A68G_UNION_SIZE]);
1850 genie_write_standard_format (p, mode, item, ref_file, &formats);
1851 elem_index += SIZE (M_SIMPLOUT);
1852 }
1853 // Empty the format to purge insertions.
1854 purge_format_write (p, ref_file);
1855 BODY (&FORMAT (file)) = NO_NODE;
1856 // Dump the buffer.
1857 write_purge_buffer (p, ref_file, FORMATTED_BUFFER);
1858 // Forget about active formats.
1859 A68G_FP = FRAME_POINTER (file);
1860 A68G_SP = STACK_POINTER (file);
1861 FRAME_POINTER (file) = pop_fp;
1862 STACK_POINTER (file) = pop_sp;
1863 }
1864
1865 //! @brief Give a value error in case a character is not among expected ones.
1866
1867 BOOL_T expect (NODE_T * p, MOID_T * m, A68G_REF ref_file, const char *items, char ch)
1868 {
1869 if (strchr ((char *) items, ch) == NO_TEXT) {
1870 value_error (p, m, ref_file);
1871 return A68G_FALSE;
1872 } else {
1873 return A68G_TRUE;
1874 }
1875 }
1876
1877 //! @brief Read a group of insertions.
1878
1879 void read_insertion (NODE_T * p, A68G_REF ref_file)
1880 {
1881
1882 // Algol68G does not check whether the insertions are textually there. It just
1883 // skips them. This because we blank literals in sign moulds before the sign is
1884 // put, which is non-standard Algol68, but convenient.
1885
1886 A68G_FILE *file = FILE_DEREF (&ref_file);
1887 for (; p != NO_NODE; FORWARD (p)) {
1888 read_insertion (SUB (p), ref_file);
1889 if (IS (p, FORMAT_ITEM_L)) {
1890 BOOL_T siga = (BOOL_T) ! END_OF_FILE (file);
1891 while (siga) {
1892 int ch = read_single_char (p, ref_file);
1893 siga = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1894 }
1895 } else if (IS (p, FORMAT_ITEM_P)) {
1896 BOOL_T siga = (BOOL_T) ! END_OF_FILE (file);
1897 while (siga) {
1898 int ch = read_single_char (p, ref_file);
1899 siga = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file));
1900 }
1901 } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) {
1902 if (!END_OF_FILE (file)) {
1903 (void) read_single_char (p, ref_file);
1904 }
1905 } else if (IS (p, FORMAT_ITEM_Y)) {
1906 PUSH_REF (p, ref_file);
1907 PUSH_VALUE (p, -1, A68G_INT);
1908 genie_set (p);
1909 } else if (IS (p, LITERAL)) {
1910 // Skip characters, but don't check the literal.
1911 size_t len = strlen (NSYMBOL (p));
1912 while (len-- && !END_OF_FILE (file)) {
1913 (void) read_single_char (p, ref_file);
1914 }
1915 } else if (IS (p, REPLICATOR)) {
1916 int k = get_replicator_value (SUB (p), A68G_TRUE);
1917 if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) {
1918 for (int j = 1; j <= k; j++) {
1919 read_insertion (NEXT (p), ref_file);
1920 }
1921 } else {
1922 int pos = get_transput_buffer_index (INPUT_BUFFER);
1923 for (int j = 1; j < (k - pos); j++) {
1924 if (!END_OF_FILE (file)) {
1925 (void) read_single_char (p, ref_file);
1926 }
1927 }
1928 }
1929 return; // From REPLICATOR, don't delete this!
1930 }
1931 }
1932 }
1933
1934 //! @brief Read string from file according current format.
1935
1936 void read_string_pattern (NODE_T * p, MOID_T * m, A68G_REF ref_file)
1937 {
1938 for (; p != NO_NODE; FORWARD (p)) {
1939 if (IS (p, INSERTION)) {
1940 read_insertion (SUB (p), ref_file);
1941 } else if (IS (p, FORMAT_ITEM_A)) {
1942 scan_n_chars (p, 1, m, ref_file);
1943 } else if (IS (p, FORMAT_ITEM_S)) {
1944 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
1945 return;
1946 } else if (IS (p, REPLICATOR)) {
1947 int k = get_replicator_value (SUB (p), A68G_TRUE);
1948 for (int j = 1; j <= k; j++) {
1949 read_string_pattern (NEXT (p), m, ref_file);
1950 }
1951 return;
1952 } else {
1953 read_string_pattern (SUB (p), m, ref_file);
1954 }
1955 }
1956 }
1957
1958 //! @brief Traverse choice pattern.
1959
1960 void traverse_choice_pattern (NODE_T * p, char *str, int len, int *count, int *matches, int *first_match, BOOL_T * full_match)
1961 {
1962 for (; p != NO_NODE; FORWARD (p)) {
1963 traverse_choice_pattern (SUB (p), str, len, count, matches, first_match, full_match);
1964 if (IS (p, LITERAL)) {
1965 (*count)++;
1966 if (strncmp (NSYMBOL (p), str, (size_t) len) == 0) {
1967 (*matches)++;
1968 (*full_match) = (BOOL_T) ((*full_match) | (strcmp (NSYMBOL (p), str) == 0));
1969 if (*first_match == 0 && *full_match) {
1970 *first_match = *count;
1971 }
1972 }
1973 }
1974 }
1975 }
1976
1977 //! @brief Read appropriate insertion from a choice pattern.
1978
1979 int read_choice_pattern (NODE_T * p, A68G_REF ref_file)
1980 {
1981
1982 // This implementation does not have the RR peculiarity that longest
1983 // matching literal must be first, in case of non-unique first chars.
1984
1985 A68G_FILE *file = FILE_DEREF (&ref_file);
1986 BOOL_T cont = A68G_TRUE;
1987 int longest_match = 0, longest_match_len = 0;
1988 while (cont) {
1989 int ch = char_scanner (file);
1990 if (!END_OF_FILE (file)) {
1991 int len, count = 0, matches = 0, first_match = 0;
1992 BOOL_T full_match = A68G_FALSE;
1993 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
1994 len = get_transput_buffer_index (INPUT_BUFFER);
1995 traverse_choice_pattern (p, get_transput_buffer (INPUT_BUFFER), len, &count, &matches, &first_match, &full_match);
1996 if (full_match && matches == 1 && first_match > 0) {
1997 return first_match;
1998 } else if (full_match && matches > 1 && first_match > 0) {
1999 longest_match = first_match;
2000 longest_match_len = len;
2001 } else if (matches == 0) {
2002 cont = A68G_FALSE;
2003 }
2004 } else {
2005 cont = A68G_FALSE;
2006 }
2007 }
2008 if (longest_match > 0) {
2009 // Push back look-ahead chars.
2010 if (get_transput_buffer_index (INPUT_BUFFER) > 0) {
2011 char *z = get_transput_buffer (INPUT_BUFFER);
2012 END_OF_FILE (file) = A68G_FALSE;
2013 add_string_transput_buffer (p, TRANSPUT_BUFFER (file), &z[longest_match_len]);
2014 }
2015 return longest_match;
2016 } else {
2017 value_error (p, M_INT, ref_file);
2018 return 0;
2019 }
2020 }
2021
2022 //! @brief Read value according to a general-pattern.
2023
2024 void read_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
2025 {
2026 GENIE_UNIT (NEXT_SUB (p));
2027 // RR says to ignore parameters just calculated, so we will.
2028 A68G_REF row;
2029 POP_REF (p, &row);
2030 genie_read_standard (p, mode, item, ref_file);
2031 }
2032
2033 // INTEGRAL, REAL, COMPLEX and BITS patterns.
2034
2035 //! @brief Read sign-mould according current format.
2036
2037 void read_sign_mould (NODE_T * p, MOID_T * m, A68G_REF ref_file, int *sign)
2038 {
2039 for (; p != NO_NODE; FORWARD (p)) {
2040 if (IS (p, INSERTION)) {
2041 read_insertion (SUB (p), ref_file);
2042 } else if (IS (p, REPLICATOR)) {
2043 int k = get_replicator_value (SUB (p), A68G_TRUE);
2044 for (int j = 1; j <= k; j++) {
2045 read_sign_mould (NEXT (p), m, ref_file, sign);
2046 }
2047 return; // Leave this!
2048 } else {
2049 switch (ATTRIBUTE (p)) {
2050 case FORMAT_ITEM_Z:
2051 case FORMAT_ITEM_D:
2052 case FORMAT_ITEM_S:
2053 case FORMAT_ITEM_PLUS:
2054 case FORMAT_ITEM_MINUS: {
2055 int ch = read_single_char (p, ref_file);
2056 // When a sign has been read, digits are expected.
2057 if (*sign != 0) {
2058 if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
2059 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2060 } else {
2061 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2062 }
2063 // When a sign has not been read, a sign is expected. If there is a digit
2064 // in stead of a sign, the digit is accepted and '+' is assumed; RR demands a
2065 // space to preceed the digit, Algol68G does not.
2066 } else {
2067 if (strchr (SIGN_DIGITS, ch) != NO_TEXT) {
2068 if (ch == '+') {
2069 *sign = 1;
2070 } else if (ch == '-') {
2071 *sign = -1;
2072 } else if (ch == BLANK_CHAR) {
2073 ;
2074 }
2075 } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) {
2076 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2077 *sign = 1;
2078 }
2079 }
2080 break;
2081 }
2082 default: {
2083 read_sign_mould (SUB (p), m, ref_file, sign);
2084 break;
2085 }
2086 }
2087 }
2088 }
2089 }
2090
2091 //! @brief Read mould according current format.
2092
2093 void read_integral_mould (NODE_T * p, MOID_T * m, A68G_REF ref_file)
2094 {
2095 for (; p != NO_NODE; FORWARD (p)) {
2096 if (IS (p, INSERTION)) {
2097 read_insertion (SUB (p), ref_file);
2098 } else if (IS (p, REPLICATOR)) {
2099 int k = get_replicator_value (SUB (p), A68G_TRUE);
2100 for (int j = 1; j <= k; j++) {
2101 read_integral_mould (NEXT (p), m, ref_file);
2102 }
2103 return; // Leave this!
2104 } else if (IS (p, FORMAT_ITEM_Z)) {
2105 int ch = read_single_char (p, ref_file);
2106 const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK;
2107 if (expect (p, m, ref_file, digits, (char) ch)) {
2108 plusab_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch));
2109 } else {
2110 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2111 }
2112 } else if (IS (p, FORMAT_ITEM_D)) {
2113 int ch = read_single_char (p, ref_file);
2114 const char *digits = (m == M_BITS || m == M_LONG_BITS || m == M_LONG_LONG_BITS) ? BITS_DIGITS : INT_DIGITS;
2115 if (expect (p, m, ref_file, digits, (char) ch)) {
2116 plusab_transput_buffer (p, INPUT_BUFFER, (char) ch);
2117 } else {
2118 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2119 }
2120 } else if (IS (p, FORMAT_ITEM_S)) {
2121 plusab_transput_buffer (p, INPUT_BUFFER, '0');
2122 } else {
2123 read_integral_mould (SUB (p), m, ref_file);
2124 }
2125 }
2126 }
2127
2128 //! @brief Read mould according current format.
2129
2130 void read_integral_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
2131 {
2132 NODE_T *q = SUB (p);
2133 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2134 int sign = 0;
2135 char *z;
2136 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2137 read_sign_mould (SUB (q), m, ref_file, &sign);
2138 z = get_transput_buffer (INPUT_BUFFER);
2139 z[0] = (char) ((sign == -1) ? '-' : '+');
2140 FORWARD (q);
2141 }
2142 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2143 read_integral_mould (SUB (q), m, ref_file);
2144 }
2145 genie_string_to_value (p, m, item, ref_file);
2146 }
2147
2148 //! @brief Read point, exponent or i-frame.
2149
2150 void read_pie_frame (NODE_T * p, MOID_T * m, A68G_REF ref_file, int att, int item, char ch)
2151 {
2152 // Widen ch to a stringlet.
2153 char sym[3];
2154 sym[0] = ch;
2155 sym[1] = (char) TO_LOWER (ch);
2156 sym[2] = NULL_CHAR;
2157 // Now read the frame.
2158 for (; p != NO_NODE; FORWARD (p)) {
2159 if (IS (p, INSERTION)) {
2160 read_insertion (p, ref_file);
2161 } else if (IS (p, att)) {
2162 read_pie_frame (SUB (p), m, ref_file, att, item, ch);
2163 return;
2164 } else if (IS (p, FORMAT_ITEM_S)) {
2165 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2166 return;
2167 } else if (IS (p, item)) {
2168 int ch0 = read_single_char (p, ref_file);
2169 if (expect (p, m, ref_file, sym, (char) ch0)) {
2170 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2171 } else {
2172 plusab_transput_buffer (p, INPUT_BUFFER, sym[0]);
2173 }
2174 }
2175 }
2176 }
2177
2178 //! @brief Read REAL value using real pattern.
2179
2180 void read_real_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
2181 {
2182 // Dive into pattern.
2183 NODE_T *q = (IS (p, REAL_PATTERN)) ? SUB (p) : p;
2184 // Dissect pattern.
2185 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2186 int sign = 0;
2187 char *z;
2188 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2189 read_sign_mould (SUB (q), m, ref_file, &sign);
2190 z = get_transput_buffer (INPUT_BUFFER);
2191 z[0] = (char) ((sign == -1) ? '-' : '+');
2192 FORWARD (q);
2193 }
2194 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2195 read_integral_mould (SUB (q), m, ref_file);
2196 FORWARD (q);
2197 }
2198 if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) {
2199 read_pie_frame (SUB (q), m, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, POINT_CHAR);
2200 FORWARD (q);
2201 }
2202 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2203 read_integral_mould (SUB (q), m, ref_file);
2204 FORWARD (q);
2205 }
2206 if (q != NO_NODE && IS (q, EXPONENT_FRAME)) {
2207 read_pie_frame (SUB (q), m, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E, EXPONENT_CHAR);
2208 q = NEXT_SUB (q);
2209 if (q != NO_NODE && IS (q, SIGN_MOULD)) {
2210 int k, sign = 0;
2211 char *z;
2212 plusab_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR);
2213 k = get_transput_buffer_index (INPUT_BUFFER);
2214 read_sign_mould (SUB (q), m, ref_file, &sign);
2215 z = get_transput_buffer (INPUT_BUFFER);
2216 z[k - 1] = (char) ((sign == -1) ? '-' : '+');
2217 FORWARD (q);
2218 }
2219 if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) {
2220 read_integral_mould (SUB (q), m, ref_file);
2221 FORWARD (q);
2222 }
2223 }
2224 genie_string_to_value (p, m, item, ref_file);
2225 }
2226
2227 //! @brief Read COMPLEX value using complex pattern.
2228
2229 void read_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * m, BYTE_T * re, BYTE_T * im, A68G_REF ref_file)
2230 {
2231 // Dissect pattern.
2232 NODE_T *reel = SUB (p);
2233 NODE_T *plus_i_times = NEXT (reel);
2234 NODE_T *imag = NEXT (plus_i_times);
2235 // Read pattern.
2236 read_real_pattern (reel, m, re, ref_file);
2237 reset_transput_buffer (INPUT_BUFFER);
2238 read_pie_frame (plus_i_times, comp, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I, 'I');
2239 reset_transput_buffer (INPUT_BUFFER);
2240 read_real_pattern (imag, m, im, ref_file);
2241 }
2242
2243 //! @brief Read BITS value according pattern.
2244
2245 void read_bits_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68G_REF ref_file)
2246 {
2247 int radix = get_replicator_value (SUB_SUB (p), A68G_TRUE);
2248 if (radix < 2 || radix > 16) {
2249 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix);
2250 exit_genie (p, A68G_RUNTIME_ERROR);
2251 }
2252 char *z = get_transput_buffer (INPUT_BUFFER);
2253 ASSERT (a68g_bufprt (z, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0);
2254 set_transput_buffer_index (INPUT_BUFFER, strlen (z));
2255 read_integral_mould (NEXT_SUB (p), m, ref_file);
2256 genie_string_to_value (p, m, item, ref_file);
2257 }
2258
2259 //! @brief Read object with from file and store.
2260
2261 void genie_read_real_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file)
2262 {
2263 if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) {
2264 genie_read_standard (p, mode, item, ref_file);
2265 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
2266 read_number_generic (p, mode, item, ref_file);
2267 } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) {
2268 read_c_pattern (p, mode, item, ref_file);
2269 } else if (IS (p, REAL_PATTERN)) {
2270 read_real_pattern (p, mode, item, ref_file);
2271 } else {
2272 pattern_error (p, mode, ATTRIBUTE (p));
2273 }
2274 }
2275
2276 //! @brief At end of read purge all insertions.
2277
2278 void purge_format_read (NODE_T * p, A68G_REF ref_file)
2279 {
2280 BOOL_T siga;
2281 do {
2282 NODE_T *pat;
2283 while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) {
2284 format_error (p, ref_file, ERROR_FORMAT_PICTURES);
2285 }
2286 A68G_FILE *file = FILE_DEREF (&ref_file);
2287 NODE_T *dollar = SUB (BODY (&FORMAT (file)));
2288 A68G_FORMAT *old_fmt = (A68G_FORMAT *) FRAME_LOCAL (A68G_FP, OFFSET (TAX (dollar)));
2289 siga = (BOOL_T) ! IS_NIL_FORMAT (old_fmt);
2290 if (siga) {
2291 // Pop embedded format and proceed.
2292 (void) end_of_format (p, ref_file);
2293 }
2294 } while (siga);
2295 }
2296
2297 //! @brief Read object with from file and store.
2298
2299 void genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68G_REF ref_file, int *formats)
2300 {
2301 errno = 0;
2302 reset_transput_buffer (INPUT_BUFFER);
2303 if (mode == M_FORMAT) {
2304 CHECK_REF (p, ref_file, M_REF_FILE);
2305 A68G_FILE *file = FILE_DEREF (&ref_file);
2306 // Forget about eventual active formats and set up new one.
2307 if (*formats > 0) {
2308 purge_format_read (p, ref_file);
2309 }
2310 (*formats)++;
2311 A68G_FP = FRAME_POINTER (file);
2312 A68G_SP = STACK_POINTER (file);
2313 open_format_frame (p, ref_file, (A68G_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68G_TRUE);
2314 } else if (mode == M_PROC_REF_FILE_VOID) {
2315 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_PROC_REF_FILE_VOID);
2316 exit_genie (p, A68G_RUNTIME_ERROR);
2317 } else if (mode == M_REF_SOUND) {
2318 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, M_REF_SOUND);
2319 exit_genie (p, A68G_RUNTIME_ERROR);
2320 } else if (IS_REF (mode)) {
2321 CHECK_REF (p, *(A68G_REF *) item, mode);
2322 genie_read_standard_format (p, SUB (mode), ADDRESS ((A68G_REF *) item), ref_file, formats);
2323 } else if (mode == M_INT || mode == M_LONG_INT || mode == M_LONG_LONG_INT) {
2324 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2325 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2326 genie_read_standard (pat, mode, item, ref_file);
2327 } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) {
2328 read_number_generic (pat, mode, item, ref_file);
2329 } else if (IS (pat, INTEGRAL_C_PATTERN)) {
2330 read_c_pattern (pat, mode, item, ref_file);
2331 } else if (IS (pat, INTEGRAL_PATTERN)) {
2332 read_integral_pattern (pat, mode, item, ref_file);
2333 } else if (IS (pat, CHOICE_PATTERN)) {
2334 int k = read_choice_pattern (pat, ref_file);
2335 if (mode == M_INT) {
2336 A68G_INT *z = (A68G_INT *) item;
2337 VALUE (z) = k;
2338 STATUS (z) = (STATUS_MASK_T) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK);
2339 } else {
2340 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_DEPRECATED, mode);
2341 exit_genie (p, A68G_RUNTIME_ERROR);
2342 }
2343 } else {
2344 pattern_error (p, mode, ATTRIBUTE (pat));
2345 }
2346 } else if (mode == M_REAL || mode == M_LONG_REAL || mode == M_LONG_LONG_REAL) {
2347 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2348 genie_read_real_format (pat, mode, item, ref_file);
2349 } else if (mode == M_COMPLEX) {
2350 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2351 if (IS (pat, COMPLEX_PATTERN)) {
2352 read_complex_pattern (pat, mode, M_REAL, item, &item[SIZE (M_REAL)], ref_file);
2353 } else {
2354 // Try reading as two REAL values.
2355 genie_read_real_format (pat, M_REAL, item, ref_file);
2356 genie_read_standard_format (p, M_REAL, &item[SIZE (M_REAL)], ref_file, formats);
2357 }
2358 } else if (mode == M_LONG_COMPLEX) {
2359 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2360 if (IS (pat, COMPLEX_PATTERN)) {
2361 read_complex_pattern (pat, mode, M_LONG_REAL, item, &item[SIZE (M_LONG_REAL)], ref_file);
2362 } else {
2363 // Try reading as two LONG REAL values.
2364 genie_read_real_format (pat, M_LONG_REAL, item, ref_file);
2365 genie_read_standard_format (p, M_LONG_REAL, &item[SIZE (M_LONG_REAL)], ref_file, formats);
2366 }
2367 } else if (mode == M_LONG_LONG_COMPLEX) {
2368 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2369 if (IS (pat, COMPLEX_PATTERN)) {
2370 read_complex_pattern (pat, mode, M_LONG_LONG_REAL, item, &item[SIZE (M_LONG_LONG_REAL)], ref_file);
2371 } else {
2372 // Try reading as two LONG LONG REAL values.
2373 genie_read_real_format (pat, M_LONG_LONG_REAL, item, ref_file);
2374 genie_read_standard_format (p, M_LONG_LONG_REAL, &item[SIZE (M_LONG_LONG_REAL)], ref_file, formats);
2375 }
2376 } else if (mode == M_BOOL) {
2377 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2378 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2379 genie_read_standard (p, mode, item, ref_file);
2380 } else if (IS (pat, BOOLEAN_PATTERN)) {
2381 if (NEXT_SUB (pat) == NO_NODE) {
2382 genie_read_standard (p, mode, item, ref_file);
2383 } else {
2384 A68G_BOOL *z = (A68G_BOOL *) item;
2385 int k = read_choice_pattern (pat, ref_file);
2386 if (k == 1 || k == 2) {
2387 VALUE (z) = (BOOL_T) ((k == 1) ? A68G_TRUE : A68G_FALSE);
2388 STATUS (z) = INIT_MASK;
2389 } else {
2390 STATUS (z) = NULL_MASK;
2391 }
2392 }
2393 } else {
2394 pattern_error (p, mode, ATTRIBUTE (pat));
2395 }
2396 } else if (mode == M_BITS || mode == M_LONG_BITS || mode == M_LONG_LONG_BITS) {
2397 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2398 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2399 genie_read_standard (p, mode, item, ref_file);
2400 } else if (IS (pat, BITS_PATTERN)) {
2401 read_bits_pattern (pat, mode, item, ref_file);
2402 } else if (IS (pat, BITS_C_PATTERN)) {
2403 read_c_pattern (pat, mode, item, ref_file);
2404 } else {
2405 pattern_error (p, mode, ATTRIBUTE (pat));
2406 }
2407 } else if (mode == M_CHAR) {
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, STRING_PATTERN)) {
2412 read_string_pattern (pat, M_CHAR, ref_file);
2413 genie_string_to_value (p, mode, item, ref_file);
2414 } else if (IS (pat, CHAR_C_PATTERN)) {
2415 read_c_pattern (pat, mode, item, ref_file);
2416 } else {
2417 pattern_error (p, mode, ATTRIBUTE (pat));
2418 }
2419 } else if (mode == M_ROW_CHAR || mode == M_STRING) {
2420 // Handle these separately instead of reading [] CHAR.
2421 NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN);
2422 if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) {
2423 genie_read_standard (p, mode, item, ref_file);
2424 } else if (IS (pat, STRING_PATTERN)) {
2425 read_string_pattern (pat, mode, ref_file);
2426 genie_string_to_value (p, mode, item, ref_file);
2427 } else if (IS (pat, STRING_C_PATTERN)) {
2428 read_c_pattern (pat, mode, item, ref_file);
2429 } else {
2430 pattern_error (p, mode, ATTRIBUTE (pat));
2431 }
2432 } else if (IS_UNION (mode)) {
2433 A68G_UNION *z = (A68G_UNION *) item;
2434 genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68G_UNION_SIZE], ref_file, formats);
2435 } else if (IS_STRUCT (mode)) {
2436 for (PACK_T *q = PACK (mode); q != NO_PACK; FORWARD (q)) {
2437 BYTE_T *elem = &item[OFFSET (q)];
2438 genie_read_standard_format (p, MOID (q), elem, ref_file, formats);
2439 }
2440 } else if (IS_ROW (mode) || IS_FLEX (mode)) {
2441 MOID_T *deflexed = DEFLEX (mode);
2442 A68G_ARRAY *arr;
2443 A68G_TUPLE *tup;
2444 CHECK_INIT (p, INITIALISED ((A68G_REF *) item), M_ROWS);
2445 GET_DESCRIPTOR (arr, tup, (A68G_REF *) item);
2446 if (get_row_size (tup, DIM (arr)) > 0) {
2447 BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr));
2448 BOOL_T done = A68G_FALSE;
2449 initialise_internal_index (tup, DIM (arr));
2450 while (!done) {
2451 ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr));
2452 ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index);
2453 BYTE_T *elem = &base_addr[elem_addr];
2454 genie_read_standard_format (p, SUB (deflexed), elem, ref_file, formats);
2455 done = increment_internal_index (tup, DIM (arr));
2456 }
2457 }
2458 }
2459 if (errno != 0) {
2460 transput_error (p, ref_file, mode);
2461 }
2462 }
2463
2464 //! @brief PROC ([] SIMPLIN) VOID read f
2465
2466 void genie_read_format (NODE_T * p)
2467 {
2468 A68G_REF row;
2469 POP_REF (p, &row);
2470 genie_stand_in (p);
2471 PUSH_REF (p, row);
2472 genie_read_file_format (p);
2473 }
2474
2475 //! @brief PROC (REF FILE, [] SIMPLIN) VOID get f
2476
2477 void genie_read_file_format (NODE_T * p)
2478 {
2479 A68G_REF row;
2480 POP_REF (p, &row);
2481 CHECK_REF (p, row, M_ROW_SIMPLIN);
2482 A68G_ARRAY *arr; A68G_TUPLE *tup;
2483 GET_DESCRIPTOR (arr, tup, &row);
2484 int elems = ROW_SIZE (tup);
2485 A68G_REF ref_file;
2486 POP_REF (p, &ref_file);
2487 CHECK_REF (p, ref_file, M_REF_FILE);
2488 A68G_FILE *file = FILE_DEREF (&ref_file);
2489 CHECK_INIT (p, INITIALISED (file), M_FILE);
2490 if (!OPENED (file)) {
2491 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN);
2492 exit_genie (p, A68G_RUNTIME_ERROR);
2493 }
2494 if (DRAW_MOOD (file)) {
2495 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw");
2496 exit_genie (p, A68G_RUNTIME_ERROR);
2497 }
2498 if (WRITE_MOOD (file)) {
2499 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write");
2500 exit_genie (p, A68G_RUNTIME_ERROR);
2501 }
2502 if (!GET (&CHANNEL (file))) {
2503 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting");
2504 exit_genie (p, A68G_RUNTIME_ERROR);
2505 }
2506 if (!READ_MOOD (file) && !WRITE_MOOD (file)) {
2507 if (IS_NIL (STRING (file))) {
2508 if ((FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0)) == A68G_NO_FILE) {
2509 open_error (p, ref_file, "getting");
2510 }
2511 } else {
2512 FD (file) = open_physical_file (p, ref_file, A68G_READ_ACCESS, 0);
2513 }
2514 DRAW_MOOD (file) = A68G_FALSE;
2515 READ_MOOD (file) = A68G_TRUE;
2516 WRITE_MOOD (file) = A68G_FALSE;
2517 CHAR_MOOD (file) = A68G_TRUE;
2518 }
2519 if (!CHAR_MOOD (file)) {
2520 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary");
2521 exit_genie (p, A68G_RUNTIME_ERROR);
2522 }
2523 // Save stack state since formats have frames.
2524 ADDR_T pop_fp = FRAME_POINTER (file), pop_sp = STACK_POINTER (file);
2525 FRAME_POINTER (file) = A68G_FP;
2526 STACK_POINTER (file) = A68G_SP;
2527 // Process [] SIMPLIN.
2528 if (BODY (&FORMAT (file)) != NO_NODE) {
2529 open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68G_FALSE);
2530 }
2531 if (elems <= 0) {
2532 return;
2533 }
2534 int elem_index = 0, formats = 0;
2535 BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr));
2536 for (int k = 0; k < elems; k++) {
2537 A68G_UNION *z = (A68G_UNION *) & (base_address[elem_index]);
2538 MOID_T *mode = (MOID_T *) (VALUE (z));
2539 BYTE_T *item = (BYTE_T *) & (base_address[elem_index + A68G_UNION_SIZE]);
2540 genie_read_standard_format (p, mode, item, ref_file, &formats);
2541 elem_index += SIZE (M_SIMPLIN);
2542 }
2543 // Empty the format to purge insertions.
2544 purge_format_read (p, ref_file);
2545 BODY (&FORMAT (file)) = NO_NODE;
2546 // Forget about active formats.
2547 A68G_FP = FRAME_POINTER (file);
2548 A68G_SP = STACK_POINTER (file);
2549 FRAME_POINTER (file) = pop_fp;
2550 STACK_POINTER (file) = pop_sp;
2551 }
|
© 2002-2026 J.M. van der Veer (jmvdveer@xs4all.nl)
|
