genie-stowed.c
1 //! @file genie-stowed.c
2 //! @author J. Marcel van der Veer
3 //!
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
8 //!
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! Interpreter routines for STOWED values.
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-parser.h"
33 #include "a68g-transput.h"
34
35 // Routines for handling stowed objects.
36 //
37 // An A68G row is a reference to a descriptor in the heap:
38 //
39 // ...
40 // A68_REF row -> A68_ARRAY ----+ ARRAY: Description of row, ref to elements
41 // A68_TUPLE 1 | TUPLE: Bounds, one for every dimension
42 // ... |
43 // A68_TUPLE dim |
44 // ... |
45 // ... |
46 // Element 1 <---+ Element: Sequential row elements, in the heap
47 // ... Not always contiguous - trims!
48 // Element n
49
50 //! @brief Size of a row.
51
52 int get_row_size (A68_TUPLE * tup, int dim)
53 {
54 int span = 1;
55 for (int k = 0; k < dim; k++) {
56 int stride = ROW_SIZE (&tup[k]);
57 ABEND ((stride > 0 && span > A68_MAX_INT / stride), ERROR_INVALID_SIZE, __func__);
58 span *= stride;
59 }
60 return span;
61 }
62
63 //! @brief Initialise index for FORALL constructs.
64
65 void initialise_internal_index (A68_TUPLE * tup, int dim)
66 {
67 for (int k = 0; k < dim; k++) {
68 A68_TUPLE *ref = &tup[k];
69 K (ref) = LWB (ref);
70 }
71 }
72
73 //! @brief Calculate index.
74
75 ADDR_T calculate_internal_index (A68_TUPLE * tup, int dim)
76 {
77 ADDR_T idx = 0;
78 for (int k = 0; k < dim; k++) {
79 A68_TUPLE *ref = &tup[k];
80 // Only consider non-empty rows.
81 if (ROW_SIZE (ref) > 0) {
82 idx += (SPAN (ref) * K (ref) - SHIFT (ref));
83 }
84 }
85 return idx;
86 }
87
88 //! @brief Increment index for FORALL constructs.
89
90 BOOL_T increment_internal_index (A68_TUPLE * tup, int dim)
91 {
92 BOOL_T carry = A68_TRUE;
93 for (int k = dim - 1; k >= 0 && carry; k--) {
94 A68_TUPLE *ref = &tup[k];
95 if (K (ref) < UPB (ref)) {
96 (K (ref))++;
97 carry = A68_FALSE;
98 } else {
99 K (ref) = LWB (ref);
100 }
101 }
102 return carry;
103 }
104
105 //! @brief Print index.
106
107 void print_internal_index (FILE_T f, A68_TUPLE * tup, int dim)
108 {
109 for (int k = 0; k < dim; k++) {
110 A68_TUPLE *ref = &tup[k];
111 BUFFER buf;
112 ASSERT (snprintf (buf, SNPRINTF_SIZE, A68_LD, K (ref)) >= 0);
113 WRITE (f, buf);
114 if (k < dim - 1) {
115 WRITE (f, ", ");
116 }
117 }
118 }
119
120 //! @brief Convert C string to A68 [] CHAR.
121
122 A68_REF c_string_to_row_char (NODE_T * p, char *str, int width)
123 {
124 A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup;
125 NEW_ROW_1D (z, row, arr, tup, M_ROW_CHAR, M_CHAR, width);
126 BYTE_T *base = ADDRESS (&row);
127 int len = strlen (str);
128 for (int k = 0; k < width; k++) {
129 A68_CHAR *ch = (A68_CHAR *) & (base[k * SIZE_ALIGNED (A68_CHAR)]);
130 STATUS (ch) = INIT_MASK;
131 VALUE (ch) = (k < len ? TO_UCHAR (str[k]) : NULL_CHAR);
132 }
133 return z;
134 }
135
136 //! @brief Convert C string to A68 string.
137
138 A68_REF c_to_a_string (NODE_T * p, char *str, int width)
139 {
140 if (str == NO_TEXT) {
141 return empty_string (p);
142 } else {
143 if (width == DEFAULT_WIDTH) {
144 return c_string_to_row_char (p, str, (int) strlen (str));
145 } else {
146 return c_string_to_row_char (p, str, (int) width);
147 }
148 }
149 }
150
151 //! @brief Size of a string.
152
153 int a68_string_size (NODE_T * p, A68_REF row)
154 {
155 (void) p;
156 if (INITIALISED (&row)) {
157 A68_ARRAY *arr; A68_TUPLE *tup;
158 GET_DESCRIPTOR (arr, tup, &row);
159 return ROW_SIZE (tup);
160 } else {
161 return 0;
162 }
163 }
164
165 //! @brief Convert A68 string to C string.
166
167 char *a_to_c_string (NODE_T * p, char *str, A68_REF row)
168 {
169 // Assume "str" to be long enough - caller's responsibility!.
170 (void) p;
171 if (INITIALISED (&row)) {
172 A68_ARRAY *arr; A68_TUPLE *tup;
173 GET_DESCRIPTOR (arr, tup, &row);
174 int size = ROW_SIZE (tup), n = 0;
175 if (size > 0) {
176 BYTE_T *base_address = ADDRESS (&ARRAY (arr));
177 for (int k = LWB (tup); k <= UPB (tup); k++) {
178 int addr = INDEX_1_DIM (arr, tup, k);
179 A68_CHAR *ch = (A68_CHAR *) & (base_address[addr]);
180 CHECK_INIT (p, INITIALISED (ch), M_CHAR);
181 str[n++] = (char) VALUE (ch);
182 }
183 }
184 str[n] = NULL_CHAR;
185 return str;
186 } else {
187 return NO_TEXT;
188 }
189 }
190
191 //! @brief Return an empty row.
192
193 A68_REF empty_row (NODE_T * p, MOID_T * u)
194 {
195 if (IS_FLEX (u)) {
196 u = SUB (u);
197 }
198 MOID_T *v = SUB (u);
199 int dim = DIM (u);
200 A68_REF dsc; A68_ARRAY *arr; A68_TUPLE *tup;
201 dsc = heap_generator (p, u, DESCRIPTOR_SIZE (dim));
202 GET_DESCRIPTOR (arr, tup, &dsc);
203 DIM (arr) = dim;
204 MOID (arr) = SLICE (u);
205 ELEM_SIZE (arr) = moid_size (SLICE (u));
206 SLICE_OFFSET (arr) = 0;
207 FIELD_OFFSET (arr) = 0;
208 if (IS_ROW (v) || IS_FLEX (v)) {
209 // [] AMODE or FLEX [] AMODE
210 ARRAY (arr) = heap_generator (p, v, A68_REF_SIZE);
211 *DEREF (A68_REF, &ARRAY (arr)) = empty_row (p, v);
212 } else {
213 ARRAY (arr) = nil_ref;
214 }
215 STATUS (&ARRAY (arr)) = (STATUS_MASK_T) (INIT_MASK | IN_HEAP_MASK);
216 for (int k = 0; k < dim; k++) {
217 LWB (&tup[k]) = 1;
218 UPB (&tup[k]) = 0;
219 SPAN (&tup[k]) = 1;
220 SHIFT (&tup[k]) = LWB (tup);
221 }
222 return dsc;
223 }
224
225 //! @brief An empty string, FLEX [1 : 0] CHAR.
226
227 A68_REF empty_string (NODE_T * p)
228 {
229 return empty_row (p, M_STRING);
230 }
231
232 //! @brief Make [,, ..] MODE from [, ..] MODE.
233
234 A68_REF genie_make_rowrow (NODE_T * p, MOID_T * rmod, int len, ADDR_T sp)
235 {
236 MOID_T *nmod = IS_FLEX (rmod) ? SUB (rmod) : rmod;
237 MOID_T *emod = SUB (nmod);
238 int odim = DIM (nmod) - 1;
239 // Make the new descriptor.
240 A68_REF nrow; A68_ARRAY *new_arr; A68_TUPLE *new_tup;
241 nrow = heap_generator (p, rmod, DESCRIPTOR_SIZE (DIM (nmod)));
242 GET_DESCRIPTOR (new_arr, new_tup, &nrow);
243 DIM (new_arr) = DIM (nmod);
244 MOID (new_arr) = emod;
245 ELEM_SIZE (new_arr) = SIZE (emod);
246 SLICE_OFFSET (new_arr) = 0;
247 FIELD_OFFSET (new_arr) = 0;
248 if (len == 0) {
249 // There is a vacuum on the stack.
250 for (int k = 0; k < odim; k++) {
251 LWB (&new_tup[k + 1]) = 1;
252 UPB (&new_tup[k + 1]) = 0;
253 SPAN (&new_tup[k + 1]) = 1;
254 SHIFT (&new_tup[k + 1]) = LWB (&new_tup[k + 1]);
255 }
256 LWB (new_tup) = 1;
257 UPB (new_tup) = 0;
258 SPAN (new_tup) = 0;
259 SHIFT (new_tup) = 0;
260 ARRAY (new_arr) = nil_ref;
261 return nrow;
262 } else if (len > 0) {
263 A68_ARRAY *x = NO_ARRAY;
264 // Arrays in the stack must have equal bounds.
265 for (int j = 1; j < len; j++) {
266 A68_REF rrow = *(A68_REF *) STACK_ADDRESS (sp);
267 A68_REF vrow = *(A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE);
268 A68_TUPLE *vtup, *rtup;
269 GET_DESCRIPTOR (x, rtup, &rrow);
270 GET_DESCRIPTOR (x, vtup, &vrow);
271 for (int k = 0; k < odim; k++, rtup++, vtup++) {
272 if ((UPB (rtup) != UPB (vtup)) || (LWB (rtup) != LWB (vtup))) {
273 diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
274 exit_genie (p, A68_RUNTIME_ERROR);
275 }
276 }
277 }
278 // Fill descriptor of new row with info from (arbitrary) first one.
279 A68_REF orow; A68_ARRAY *old_arr; A68_TUPLE *old_tup;
280 orow = *(A68_REF *) STACK_ADDRESS (sp);
281 GET_DESCRIPTOR (x, old_tup, &orow);
282 int span = 1;
283 for (int k = 0; k < odim; k++) {
284 A68_TUPLE *nt = &new_tup[k + 1], *ot = &old_tup[k];
285 LWB (nt) = LWB (ot);
286 UPB (nt) = UPB (ot);
287 SPAN (nt) = span;
288 SHIFT (nt) = LWB (nt) * SPAN (nt);
289 span *= ROW_SIZE (nt);
290 }
291 LWB (new_tup) = 1;
292 UPB (new_tup) = len;
293 SPAN (new_tup) = span;
294 SHIFT (new_tup) = LWB (new_tup) * SPAN (new_tup);
295 ARRAY (new_arr) = heap_generator (p, rmod, len * span * ELEM_SIZE (new_arr));
296 for (int j = 0; j < len; j++) {
297 // new[j,, ] := old[, ].
298 GET_DESCRIPTOR (old_arr, old_tup, (A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE));
299 if (LWB (old_tup) > UPB (old_tup)) {
300 A68_REF dst = ARRAY (new_arr);
301 ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], odim);
302 OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k);
303 A68_REF none = empty_row (p, SLICE (rmod));
304 MOVE (ADDRESS (&dst), ADDRESS (&none), SIZE (emod));
305 } else {
306 initialise_internal_index (old_tup, odim);
307 initialise_internal_index (&new_tup[1], odim);
308 BOOL_T done = A68_FALSE;
309 while (!done) {
310 A68_REF src = ARRAY (old_arr), dst = ARRAY (new_arr);
311 ADDR_T old_k = calculate_internal_index (old_tup, odim);
312 ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], odim);
313 OFFSET (&src) += ROW_ELEMENT (old_arr, old_k);
314 OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k);
315 if (HAS_ROWS (emod)) {
316 A68_REF none = genie_clone (p, emod, (A68_REF *) & nil_ref, &src);
317 MOVE (ADDRESS (&dst), ADDRESS (&none), SIZE (emod));
318 } else {
319 MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (emod));
320 }
321 done = increment_internal_index (old_tup, odim) | increment_internal_index (&new_tup[1], odim);
322 }
323 }
324 }
325 }
326 return nrow;
327 }
328
329 //! @brief Make a row of 'len' objects that are in the stack.
330
331 A68_REF genie_make_row (NODE_T * p, MOID_T * elem_mode, int len, ADDR_T sp)
332 {
333 A68_REF new_row, new_arr; A68_ARRAY arr; A68_TUPLE tup;
334 NEW_ROW_1D (new_row, new_arr, arr, tup, MOID (p), elem_mode, len);
335 for (int k = 0; k < len * ELEM_SIZE (&arr); k += ELEM_SIZE (&arr)) {
336 A68_REF dst = new_arr, src;
337 OFFSET (&dst) += k;
338 STATUS (&src) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
339 OFFSET (&src) = sp + k;
340 REF_HANDLE (&src) = (A68_HANDLE *) & nil_handle;
341 if (HAS_ROWS (elem_mode)) {
342 A68_REF new_one = genie_clone (p, elem_mode, (A68_REF *) & nil_ref, &src);
343 MOVE (ADDRESS (&dst), ADDRESS (&new_one), SIZE (elem_mode));
344 } else {
345 MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (elem_mode));
346 }
347 }
348 return new_row;
349 }
350
351 //! @brief Make REF [1 : 1] [] MODE from REF [] MODE.
352
353 A68_REF genie_make_ref_row_of_row (NODE_T * p, MOID_T * dst_mode, MOID_T * src_mode, ADDR_T sp)
354 {
355 dst_mode = DEFLEX (dst_mode);
356 src_mode = DEFLEX (src_mode);
357 A68_REF array = *(A68_REF *) STACK_ADDRESS (sp);
358 // ROWING NIL yields NIL.
359 if (IS_NIL (array)) {
360 return nil_ref;
361 } else {
362 A68_REF new_row = heap_generator (p, SUB (dst_mode), DESCRIPTOR_SIZE (1));
363 A68_REF name = heap_generator (p, dst_mode, A68_REF_SIZE);
364 A68_ARRAY *arr; A68_TUPLE *tup;
365 GET_DESCRIPTOR (arr, tup, &new_row);
366 DIM (arr) = 1;
367 MOID (arr) = src_mode;
368 ELEM_SIZE (arr) = SIZE (src_mode);
369 SLICE_OFFSET (arr) = 0;
370 FIELD_OFFSET (arr) = 0;
371 ARRAY (arr) = array;
372 LWB (tup) = 1;
373 UPB (tup) = 1;
374 SPAN (tup) = 1;
375 SHIFT (tup) = LWB (tup);
376 *DEREF (A68_REF, &name) = new_row;
377 return name;
378 }
379 }
380
381 //! @brief Make REF [1 : 1, ..] MODE from REF [..] MODE.
382
383 A68_REF genie_make_ref_row_row (NODE_T * p, MOID_T * dst_mode, MOID_T * src_mode, ADDR_T sp)
384 {
385 dst_mode = DEFLEX (dst_mode);
386 src_mode = DEFLEX (src_mode);
387 A68_REF name = *(A68_REF *) STACK_ADDRESS (sp);
388 // ROWING NIL yields NIL.
389 if (IS_NIL (name)) {
390 return nil_ref;
391 }
392 A68_REF old_row = *DEREF (A68_REF, &name); A68_TUPLE *new_tup, *old_tup;
393 A68_ARRAY *old_arr;
394 GET_DESCRIPTOR (old_arr, old_tup, &old_row);
395 // Make new descriptor.
396 A68_REF new_row = heap_generator (p, dst_mode, DESCRIPTOR_SIZE (DIM (SUB (dst_mode))));
397 A68_ARRAY *new_arr;
398 name = heap_generator (p, dst_mode, A68_REF_SIZE);
399 GET_DESCRIPTOR (new_arr, new_tup, &new_row);
400 DIM (new_arr) = DIM (SUB (dst_mode));
401 MOID (new_arr) = MOID (old_arr);
402 ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr);
403 SLICE_OFFSET (new_arr) = 0;
404 FIELD_OFFSET (new_arr) = 0;
405 ARRAY (new_arr) = ARRAY (old_arr);
406 // Fill out the descriptor.
407 LWB (&(new_tup[0])) = 1;
408 UPB (&(new_tup[0])) = 1;
409 SPAN (&(new_tup[0])) = 1;
410 SHIFT (&(new_tup[0])) = LWB (&(new_tup[0]));
411 for (int k = 0; k < DIM (SUB (src_mode)); k++) {
412 new_tup[k + 1] = old_tup[k];
413 }
414 // Yield the new name.
415 *DEREF (A68_REF, &name) = new_row;
416 return name;
417 }
418
419 //! @brief Coercion to [1 : 1, ] MODE.
420
421 PROP_T genie_rowing_row_row (NODE_T * p)
422 {
423 ADDR_T sp = A68_SP;
424 EXECUTE_UNIT (SUB (p));
425 STACK_DNS (p, MOID (SUB (p)), A68_FP);
426 A68_REF row = genie_make_rowrow (p, MOID (p), 1, sp);
427 A68_SP = sp;
428 PUSH_REF (p, row);
429 return GPROP (p);
430 }
431
432 //! @brief Coercion to [1 : 1] [] MODE.
433
434 PROP_T genie_rowing_row_of_row (NODE_T * p)
435 {
436 ADDR_T sp = A68_SP;
437 EXECUTE_UNIT (SUB (p));
438 STACK_DNS (p, MOID (SUB (p)), A68_FP);
439 A68_REF row = genie_make_row (p, SLICE (MOID (p)), 1, sp);
440 A68_SP = sp;
441 PUSH_REF (p, row);
442 return GPROP (p);
443 }
444
445 //! @brief Coercion to REF [1 : 1, ..] MODE.
446
447 PROP_T genie_rowing_ref_row_row (NODE_T * p)
448 {
449 ADDR_T sp = A68_SP;
450 MOID_T *dst = MOID (p), *src = MOID (SUB (p));
451 EXECUTE_UNIT (SUB (p));
452 STACK_DNS (p, MOID (SUB (p)), A68_FP);
453 A68_SP = sp;
454 A68_REF name = genie_make_ref_row_row (p, dst, src, sp);
455 PUSH_REF (p, name);
456 return GPROP (p);
457 }
458
459 //! @brief REF [1 : 1] [] MODE from [] MODE
460
461 PROP_T genie_rowing_ref_row_of_row (NODE_T * p)
462 {
463 ADDR_T sp = A68_SP;
464 MOID_T *dst = MOID (p), *src = MOID (SUB (p));
465 EXECUTE_UNIT (SUB (p));
466 STACK_DNS (p, MOID (SUB (p)), A68_FP);
467 A68_SP = sp;
468 A68_REF name = genie_make_ref_row_of_row (p, dst, src, sp);
469 PUSH_REF (p, name);
470 return GPROP (p);
471 }
472
473 //! @brief Rowing coercion.
474
475 PROP_T genie_rowing (NODE_T * p)
476 {
477 PROP_T self;
478 if (IS_REF (MOID (p))) {
479 // REF ROW, decide whether we want A->[] A or [] A->[,] A.
480 MOID_T *mode = SUB_MOID (p);
481 if (DIM (DEFLEX (mode)) >= 2) {
482 (void) genie_rowing_ref_row_row (p);
483 UNIT (&self) = genie_rowing_ref_row_row;
484 SOURCE (&self) = p;
485 } else {
486 (void) genie_rowing_ref_row_of_row (p);
487 UNIT (&self) = genie_rowing_ref_row_of_row;
488 SOURCE (&self) = p;
489 }
490 } else {
491 // ROW, decide whether we want A->[] A or [] A->[,] A.
492 if (DIM (DEFLEX (MOID (p))) >= 2) {
493 (void) genie_rowing_row_row (p);
494 UNIT (&self) = genie_rowing_row_row;
495 SOURCE (&self) = p;
496 } else {
497 (void) genie_rowing_row_of_row (p);
498 UNIT (&self) = genie_rowing_row_of_row;
499 SOURCE (&self) = p;
500 }
501 }
502 return self;
503 }
504
505 //! @brief Clone a compounded value referred to by 'old'.
506
507 A68_REF genie_clone (NODE_T * p, MOID_T * m, A68_REF * tmp, A68_REF * old)
508 {
509 // This complex routine is needed as arrays are not always contiguous.
510 // The routine takes a REF to the value and returns a REF to the clone.
511 if (m == M_SOUND) {
512 // REF SOUND.
513 A68_REF nsound = heap_generator (p, m, SIZE (m));
514 A68_SOUND *w = DEREF (A68_SOUND, &nsound);
515 int size = A68_SOUND_DATA_SIZE (w);
516 COPY ((BYTE_T *) w, ADDRESS (old), SIZE (M_SOUND));
517 BYTE_T *owd = ADDRESS (&(DATA (w)));
518 DATA (w) = heap_generator (p, M_SOUND_DATA, size);
519 COPY (ADDRESS (&(DATA (w))), owd, size);
520 return nsound;
521 } else if (IS_STRUCT (m)) {
522 // REF STRUCT.
523 A68_REF nstruct = heap_generator (p, m, SIZE (m));
524 for (PACK_T *fds = PACK (m); fds != NO_PACK; FORWARD (fds)) {
525 MOID_T *fm = MOID (fds);
526 A68_REF of = *old, nf = nstruct, tf = *tmp;
527 OFFSET (&of) += OFFSET (fds);
528 OFFSET (&nf) += OFFSET (fds);
529 if (!IS_NIL (tf)) {
530 OFFSET (&tf) += OFFSET (fds);
531 }
532 if (HAS_ROWS (fm)) {
533 A68_REF a68_clone = genie_clone (p, fm, &tf, &of);
534 MOVE (ADDRESS (&nf), ADDRESS (&a68_clone), SIZE (fm));
535 } else {
536 MOVE (ADDRESS (&nf), ADDRESS (&of), SIZE (fm));
537 }
538 }
539 return nstruct;
540 } else if (IS_UNION (m)) {
541 // REF UNION.
542 A68_REF nunion = heap_generator (p, m, SIZE (m));
543 A68_REF src = *old;
544 A68_UNION *u = DEREF (A68_UNION, &src);
545 MOID_T *um = (MOID_T *) VALUE (u);
546 OFFSET (&src) += UNION_OFFSET;
547 A68_REF dst = nunion;
548 *DEREF (A68_UNION, &dst) = *u;
549 OFFSET (&dst) += UNION_OFFSET;
550 // A union has formal members, so tmp is irrelevant.
551 A68_REF tmpu = nil_ref;
552 if (um != NO_MOID && HAS_ROWS (um)) {
553 A68_REF a68_clone = genie_clone (p, um, &tmpu, &src);
554 MOVE (ADDRESS (&dst), ADDRESS (&a68_clone), SIZE (um));
555 } else if (um != NO_MOID) {
556 MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (um));
557 }
558 return nunion;
559 } else if (IF_ROW (m)) {
560 // REF [FLEX] [].
561 MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
562 // Make new array.
563 A68_ARRAY *old_arr; A68_TUPLE *old_tup;
564 GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old));
565 A68_ARRAY *new_arr; A68_TUPLE *new_tup;
566 A68_REF nrow = heap_generator (p, m, DESCRIPTOR_SIZE (DIM (old_arr)));
567 GET_DESCRIPTOR (new_arr, new_tup, &nrow);
568 DIM (new_arr) = DIM (old_arr);
569 MOID (new_arr) = MOID (old_arr);
570 ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr);
571 SLICE_OFFSET (new_arr) = 0;
572 FIELD_OFFSET (new_arr) = 0;
573 // Get size and copy bounds; check in case of a row.
574 // This is just song and dance to comply with the RR.
575 BOOL_T check_bounds = A68_FALSE;
576 A68_REF ntmp; A68_ARRAY *tarr; A68_TUPLE *ttup = NO_TUPLE;
577 if (IS_NIL (*tmp)) {
578 ntmp = nil_ref;
579 } else {
580 A68_REF *z = DEREF (A68_REF, tmp);
581 if (!IS_NIL (*z)) {
582 GET_DESCRIPTOR (tarr, ttup, z);
583 ntmp = ARRAY (tarr);
584 check_bounds = IS_ROW (m);
585 }
586 }
587 int span = 1;
588 for (int k = 0; k < DIM (old_arr); k++) {
589 A68_TUPLE *op = &old_tup[k], *np = &new_tup[k];
590 if (check_bounds) {
591 A68_TUPLE *tp = &ttup[k];
592 if (UPB (tp) >= LWB (tp) && UPB (op) >= LWB (op)) {
593 if (UPB (tp) != UPB (op) || LWB (tp) != LWB (op)) {
594 diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
595 exit_genie (p, A68_RUNTIME_ERROR);
596 }
597 }
598 }
599 LWB (np) = LWB (op);
600 UPB (np) = UPB (op);
601 SPAN (np) = span;
602 SHIFT (np) = LWB (np) * SPAN (np);
603 span *= ROW_SIZE (np);
604 }
605 // Make a new array with at least a ghost element.
606 if (span == 0) {
607 ARRAY (new_arr) = heap_generator (p, em, ELEM_SIZE (new_arr));
608 } else {
609 ARRAY (new_arr) = heap_generator (p, em, span * ELEM_SIZE (new_arr));
610 }
611 // Copy the ghost element if there are no elements.
612 if (span == 0) {
613 if (IS_UNION (em)) {
614 // UNION has formal members.
615 } else if (HAS_ROWS (em)) {
616 A68_REF old_ref, dst_ref, a68_clone;
617 old_ref = ARRAY (old_arr);
618 OFFSET (&old_ref) += ROW_ELEMENT (old_arr, 0);
619 dst_ref = ARRAY (new_arr);
620 OFFSET (&dst_ref) += ROW_ELEMENT (new_arr, 0);
621 a68_clone = genie_clone (p, em, &ntmp, &old_ref);
622 MOVE (ADDRESS (&dst_ref), ADDRESS (&a68_clone), SIZE (em));
623 }
624 } else if (span > 0) {
625 // The n-dimensional copier.
626 initialise_internal_index (old_tup, DIM (old_arr));
627 initialise_internal_index (new_tup, DIM (new_arr));
628 BOOL_T done = A68_FALSE;
629 while (!done) {
630 A68_REF old_ref = ARRAY (old_arr), dst_ref = ARRAY (new_arr);
631 ADDR_T old_k = calculate_internal_index (old_tup, DIM (old_arr));
632 ADDR_T new_k = calculate_internal_index (new_tup, DIM (new_arr));
633 OFFSET (&old_ref) += ROW_ELEMENT (old_arr, old_k);
634 OFFSET (&dst_ref) += ROW_ELEMENT (new_arr, new_k);
635 if (HAS_ROWS (em)) {
636 A68_REF a68_clone;
637 a68_clone = genie_clone (p, em, &ntmp, &old_ref);
638 MOVE (ADDRESS (&dst_ref), ADDRESS (&a68_clone), SIZE (em));
639 } else {
640 MOVE (ADDRESS (&dst_ref), ADDRESS (&old_ref), SIZE (em));
641 }
642 // Increase pointers.
643 done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr));
644 }
645 }
646 A68_REF heap = heap_generator (p, m, A68_REF_SIZE);
647 *DEREF (A68_REF, &heap) = nrow;
648 return heap;
649 }
650 return nil_ref;
651 }
652
653 //! @brief Store into a row, fi. trimmed destinations.
654
655 A68_REF genie_store (NODE_T * p, MOID_T * m, A68_REF * dst, A68_REF * old)
656 {
657 // This complex routine is needed as arrays are not always contiguous.
658 // The routine takes a REF to the value and returns a REF to the clone.
659 if (IF_ROW (m)) {
660 // REF [FLEX] [].
661 A68_TUPLE *old_tup, *new_tup, *old_p, *new_p;
662 MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
663 BOOL_T done = A68_FALSE;
664 A68_ARRAY *old_arr, *new_arr;
665 GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old));
666 GET_DESCRIPTOR (new_arr, new_tup, DEREF (A68_REF, dst));
667 // Get size and check bounds.
668 // This is just song and dance to comply with the RR.
669 int span = 1;
670 for (int k = 0; k < DIM (old_arr); k++) {
671 old_p = &old_tup[k];
672 new_p = &new_tup[k];
673 if ((UPB (new_p) >= LWB (new_p) && UPB (old_p) >= LWB (old_p))) {
674 if ((UPB (new_p) != UPB (old_p) || LWB (new_p) != LWB (old_p))) {
675 diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
676 exit_genie (p, A68_RUNTIME_ERROR);
677 }
678 }
679 span *= ROW_SIZE (new_p);
680 }
681 // Destination is an empty row, inspect if the source has elements.
682 if (span == 0) {
683 span = 1;
684 for (int k = 0; k < DIM (old_arr); k++) {
685 span *= ROW_SIZE (old_p);
686 }
687 if (span > 0) {
688 span = 1;
689 for (int k = 0; k < DIM (old_arr); k++) {
690 new_tup[k] = old_tup[k];
691 }
692 ARRAY (new_arr) = heap_generator (p, em, span * ELEM_SIZE (new_arr));
693 }
694 }
695 if (span > 0) {
696 initialise_internal_index (old_tup, DIM (old_arr));
697 initialise_internal_index (new_tup, DIM (new_arr));
698 while (!done) {
699 A68_REF new_old = ARRAY (old_arr), new_dst = ARRAY (new_arr);
700 ADDR_T old_index = calculate_internal_index (old_tup, DIM (old_arr));
701 ADDR_T new_index = calculate_internal_index (new_tup, DIM (new_arr));
702 OFFSET (&new_old) += ROW_ELEMENT (old_arr, old_index);
703 OFFSET (&new_dst) += ROW_ELEMENT (new_arr, new_index);
704 MOVE (ADDRESS (&new_dst), ADDRESS (&new_old), SIZE (em));
705 done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr));
706 }
707 }
708 return *dst;
709 }
710 return nil_ref;
711 }
712
713 //! @brief Assignment of complex objects in the stack.
714
715 void genie_clone_stack (NODE_T * p, MOID_T * srcm, A68_REF * dst, A68_REF * tmp)
716 {
717 // STRUCT, UNION, [FLEX] [] or SOUND.
718 A68_REF stack;
719 STATUS (&stack) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
720 OFFSET (&stack) = A68_SP;
721 REF_HANDLE (&stack) = (A68_HANDLE *) & nil_handle;
722 A68_REF *src = DEREF (A68_REF, &stack);
723 if (IS_ROW (srcm) && !IS_NIL (*tmp)) {
724 if (STATUS (src) & SKIP_ROW_MASK) {
725 return;
726 }
727 A68_REF a68_clone = genie_clone (p, srcm, tmp, &stack);
728 (void) genie_store (p, srcm, dst, &a68_clone);
729 } else {
730 A68_REF a68_clone = genie_clone (p, srcm, tmp, &stack);
731 MOVE (ADDRESS (dst), ADDRESS (&a68_clone), SIZE (srcm));
732 }
733 }
734
735 //! @brief Strcmp for qsort.
736
737 int qstrcmp (const void *a, const void *b)
738 {
739 return strcmp (*(char *const *) a, *(char *const *) b);
740 }
741
742 //! @brief Sort row of string.
743
744 void genie_sort_row_string (NODE_T * p)
745 {
746 A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup;
747 POP_REF (p, &z);
748 ADDR_T pop_sp = A68_SP;
749 CHECK_REF (p, z, M_ROW_STRING);
750 GET_DESCRIPTOR (arr, tup, &z);
751 int size = ROW_SIZE (tup);
752 if (size > 0) {
753 BYTE_T *base = ADDRESS (&ARRAY (arr));
754 char **ptrs = (char **) a68_alloc ((size_t) (size * (int) sizeof (char *)), __func__, __LINE__);
755 if (ptrs == NO_VAR) {
756 diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
757 exit_genie (p, A68_RUNTIME_ERROR);
758 }
759 // Copy C-strings into the stack and sort.
760 for (int j = 0, k = LWB (tup); k <= UPB (tup); j++, k++) {
761 int addr = INDEX_1_DIM (arr, tup, k);
762 A68_REF ref = *(A68_REF *) & (base[addr]);
763 CHECK_REF (p, ref, M_STRING);
764 int len = A68_ALIGN (a68_string_size (p, ref) + 1);
765 if (A68_SP + len > A68 (expr_stack_limit)) {
766 diagnostic (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);
767 exit_genie (p, A68_RUNTIME_ERROR);
768 }
769 ptrs[j] = (char *) STACK_TOP;
770 ASSERT (a_to_c_string (p, (char *) STACK_TOP, ref) != NO_TEXT);
771 INCREMENT_STACK_POINTER (p, len);
772 }
773 qsort (ptrs, (size_t) size, sizeof (char *), qstrcmp);
774 // Construct an array of sorted strings.
775 A68_REF row; A68_ARRAY arrn; A68_TUPLE tupn;
776 NEW_ROW_1D (z, row, arrn, tupn, M_ROW_STRING, M_STRING, size);
777 A68_REF *base_ref = DEREF (A68_REF, &row);
778 for (int k = 0; k < size; k++) {
779 base_ref[k] = c_to_a_string (p, ptrs[k], DEFAULT_WIDTH);
780 }
781 a68_free (ptrs);
782 A68_SP = pop_sp;
783 PUSH_REF (p, z);
784 } else {
785 // This is how we sort an empty row of strings ...
786 A68_SP = pop_sp;
787 PUSH_REF (p, empty_row (p, M_ROW_STRING));
788 }
789 }
790
791 //! @brief Construct a descriptor "ref_new" for a trim of "ref_old".
792
793 void genie_trimmer (NODE_T * p, BYTE_T * *ref_new, BYTE_T * *ref_old, INT_T * offset)
794 {
795 if (p != NO_NODE) {
796 if (IS (p, UNIT)) {
797 EXECUTE_UNIT (p);
798 A68_INT k;
799 POP_OBJECT (p, &k, A68_INT);
800 A68_TUPLE *t = (A68_TUPLE *) * ref_old;
801 CHECK_INDEX (p, &k, t);
802 (*offset) += SPAN (t) * VALUE (&k) - SHIFT (t);
803 (*ref_old) += sizeof (A68_TUPLE);
804 } else if (IS (p, TRIMMER)) {
805 A68_TUPLE *old_tup = (A68_TUPLE *) * ref_old;
806 A68_TUPLE *new_tup = (A68_TUPLE *) * ref_new;
807 // TRIMMER is (l:u@r) with all units optional or (empty).
808 INT_T L, U, D;
809 NODE_T *q = SUB (p);
810 if (q == NO_NODE) {
811 L = LWB (old_tup);
812 U = UPB (old_tup);
813 D = 0;
814 } else {
815 BOOL_T absent = A68_TRUE;
816 // Lower index.
817 if (q != NO_NODE && IS (q, UNIT)) {
818 EXECUTE_UNIT (q);
819 A68_INT k;
820 POP_OBJECT (p, &k, A68_INT);
821 if (VALUE (&k) < LWB (old_tup)) {
822 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
823 exit_genie (p, A68_RUNTIME_ERROR);
824 }
825 L = VALUE (&k);
826 FORWARD (q);
827 absent = A68_FALSE;
828 } else {
829 L = LWB (old_tup);
830 }
831 if (q != NO_NODE && (IS (q, COLON_SYMBOL)
832 || IS (q, DOTDOT_SYMBOL))) {
833 FORWARD (q);
834 absent = A68_FALSE;
835 }
836 // Upper index.
837 if (q != NO_NODE && IS (q, UNIT)) {
838 EXECUTE_UNIT (q);
839 A68_INT k;
840 POP_OBJECT (p, &k, A68_INT);
841 if (VALUE (&k) > UPB (old_tup)) {
842 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
843 exit_genie (p, A68_RUNTIME_ERROR);
844 }
845 U = VALUE (&k);
846 FORWARD (q);
847 absent = A68_FALSE;
848 } else {
849 U = UPB (old_tup);
850 }
851 if (q != NO_NODE && IS (q, AT_SYMBOL)) {
852 FORWARD (q);
853 }
854 // Revised lower bound.
855 if (q != NO_NODE && IS (q, UNIT)) {
856 EXECUTE_UNIT (q);
857 A68_INT k;
858 POP_OBJECT (p, &k, A68_INT);
859 D = L - VALUE (&k);
860 FORWARD (q);
861 } else {
862 D = (absent ? 0 : L - 1);
863 }
864 }
865 LWB (new_tup) = L - D;
866 UPB (new_tup) = U - D; // (L - D) + (U - L)
867 SPAN (new_tup) = SPAN (old_tup);
868 SHIFT (new_tup) = SHIFT (old_tup) - D * SPAN (new_tup);
869 (*ref_old) += sizeof (A68_TUPLE);
870 (*ref_new) += sizeof (A68_TUPLE);
871 } else {
872 genie_trimmer (SUB (p), ref_new, ref_old, offset);
873 genie_trimmer (NEXT (p), ref_new, ref_old, offset);
874 }
875 }
876 }
877
878 //! @brief Calculation of subscript.
879
880 void genie_subscript (NODE_T * p, A68_TUPLE ** tup, INT_T * sum, NODE_T ** seq)
881 {
882 for (; p != NO_NODE; FORWARD (p)) {
883 switch (ATTRIBUTE (p)) {
884 case UNIT:
885 {
886 EXECUTE_UNIT (p);
887 A68_INT *k;
888 POP_ADDRESS (p, k, A68_INT);
889 A68_TUPLE *t = *tup;
890 CHECK_INDEX (p, k, t);
891 (*tup)++;
892 (*sum) += (SPAN (t) * VALUE (k) - SHIFT (t));
893 SEQUENCE (*seq) = p;
894 (*seq) = p;
895 return;
896 }
897 case GENERIC_ARGUMENT:
898 case GENERIC_ARGUMENT_LIST:
899 {
900 genie_subscript (SUB (p), tup, sum, seq);
901 }
902 }
903 }
904 }
905
906 //! @brief Slice REF [] A to REF A.
907
908 PROP_T genie_slice_name_quick (NODE_T * p)
909 {
910 NODE_T *q, *pr = SUB (p);
911 A68_REF *z = (A68_REF *) STACK_TOP;
912 A68_ARRAY *a; A68_TUPLE *t;
913 // Get row and save row from garbage collector.
914 EXECUTE_UNIT (pr);
915 CHECK_REF (p, *z, MOID (SUB (p)));
916 GET_DESCRIPTOR (a, t, DEREF (A68_ROW, z));
917 ADDR_T pop_sp = A68_SP;
918 INT_T sindex = 0;
919 for (q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) {
920 A68_INT *j = (A68_INT *) STACK_TOP;
921 INT_T k;
922 EXECUTE_UNIT (q);
923 k = VALUE (j);
924 if (k < LWB (t) || k > UPB (t)) {
925 diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
926 exit_genie (q, A68_RUNTIME_ERROR);
927 }
928 sindex += (SPAN (t) * k - SHIFT (t));
929 A68_SP = pop_sp;
930 }
931 // Leave reference to element on the stack, preserving scope.
932 ADDR_T scope = REF_SCOPE (z);
933 *z = ARRAY (a);
934 OFFSET (z) += ROW_ELEMENT (a, sindex);
935 REF_SCOPE (z) = scope;
936 return GPROP (p);
937 }
938
939 //! @brief Push slice of a rowed object.
940
941 PROP_T genie_slice (NODE_T * p)
942 {
943 ADDR_T pop_sp, scope = PRIMAL_SCOPE;
944 BOOL_T slice_of_name = (BOOL_T) (IS_REF (MOID (SUB (p))));
945 MOID_T *result_mode = slice_of_name ? SUB_MOID (p) : MOID (p);
946 NODE_T *indexer = NEXT_SUB (p);
947 PROP_T self;
948 UNIT (&self) = genie_slice;
949 SOURCE (&self) = p;
950 pop_sp = A68_SP;
951 // Get row.
952 PROP_T primary;
953 EXECUTE_UNIT_2 (SUB (p), primary);
954 // In case of slicing a REF [], we need the [] internally, so dereference.
955 if (slice_of_name) {
956 A68_REF z;
957 POP_REF (p, &z);
958 CHECK_REF (p, z, MOID (SUB (p)));
959 scope = REF_SCOPE (&z);
960 PUSH_REF (p, *DEREF (A68_REF, &z));
961 }
962 if (ANNOTATION (indexer) == SLICE) {
963 // SLICING subscripts one element from an array.
964 A68_REF z; A68_ARRAY *a; A68_TUPLE *t;
965 POP_REF (p, &z);
966 CHECK_REF (p, z, MOID (SUB (p)));
967 GET_DESCRIPTOR (a, t, &z);
968 INT_T sindex;
969 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
970 NODE_T top_seq;
971 NODE_T *seq = &top_seq;
972 GINFO_T g;
973 GINFO (&top_seq) = &g;
974 sindex = 0;
975 genie_subscript (indexer, &t, &sindex, &seq);
976 SEQUENCE (p) = SEQUENCE (&top_seq);
977 STATUS_SET (p, SEQUENCE_MASK);
978 } else {
979 NODE_T *q;
980 for (sindex = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) {
981 A68_INT *j = (A68_INT *) STACK_TOP;
982 INT_T k;
983 EXECUTE_UNIT (q);
984 k = VALUE (j);
985 if (k < LWB (t) || k > UPB (t)) {
986 diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
987 exit_genie (q, A68_RUNTIME_ERROR);
988 }
989 sindex += (SPAN (t) * k - SHIFT (t));
990 }
991 }
992 // Slice of a name yields a name.
993 A68_SP = pop_sp;
994 if (slice_of_name) {
995 A68_REF name = ARRAY (a);
996 OFFSET (&name) += ROW_ELEMENT (a, sindex);
997 REF_SCOPE (&name) = scope;
998 PUSH_REF (p, name);
999 if (STATUS_TEST (p, SEQUENCE_MASK)) {
1000 UNIT (&self) = genie_slice_name_quick;
1001 SOURCE (&self) = p;
1002 }
1003 } else {
1004 BYTE_T *stack_top = STACK_TOP;
1005 PUSH (p, &((ADDRESS (&(ARRAY (a))))[ROW_ELEMENT (a, sindex)]), SIZE (result_mode));
1006 genie_check_initialisation (p, stack_top, result_mode);
1007 }
1008 return self;
1009 } else if (ANNOTATION (indexer) == TRIMMER) {
1010 // Trimming selects a subarray from an array.
1011 int dim = DIM (DEFLEX (result_mode));
1012 A68_REF ref_desc_copy = heap_generator (p, MOID (p), DESCRIPTOR_SIZE (dim));
1013 // Get descriptor.
1014 A68_REF z;
1015 POP_REF (p, &z);
1016 // Get indexer.
1017 CHECK_REF (p, z, MOID (SUB (p)));
1018 A68_ARRAY *old_des = DEREF (A68_ARRAY, &z), *new_des = DEREF (A68_ARRAY, &ref_desc_copy);
1019 BYTE_T *ref_old = ADDRESS (&z) + SIZE_ALIGNED (A68_ARRAY);
1020 BYTE_T *ref_new = ADDRESS (&ref_desc_copy) + SIZE_ALIGNED (A68_ARRAY);
1021 DIM (new_des) = dim;
1022 MOID (new_des) = MOID (old_des);
1023 ELEM_SIZE (new_des) = ELEM_SIZE (old_des);
1024 INT_T offset = SLICE_OFFSET (old_des);
1025 genie_trimmer (indexer, &ref_new, &ref_old, &offset);
1026 SLICE_OFFSET (new_des) = offset;
1027 FIELD_OFFSET (new_des) = FIELD_OFFSET (old_des);
1028 ARRAY (new_des) = ARRAY (old_des);
1029 // Trim of a name is a name.
1030 if (slice_of_name) {
1031 A68_REF ref_new2 = heap_generator (p, MOID (p), A68_REF_SIZE);
1032 *DEREF (A68_REF, &ref_new2) = ref_desc_copy;
1033 REF_SCOPE (&ref_new2) = scope;
1034 PUSH_REF (p, ref_new2);
1035 } else {
1036 PUSH_REF (p, ref_desc_copy);
1037 }
1038 return self;
1039 } else {
1040 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1041 return self;
1042 }
1043 (void) primary;
1044 }
1045
1046 //! @brief SELECTION from a value
1047
1048 PROP_T genie_selection_value_quick (NODE_T * p)
1049 {
1050 NODE_T *selector = SUB (p);
1051 MOID_T *result_mode = MOID (selector);
1052 ADDR_T pop_sp = A68_SP;
1053 int size = SIZE (result_mode);
1054 INT_T offset = OFFSET (NODE_PACK (SUB (selector)));
1055 EXECUTE_UNIT (NEXT (selector));
1056 A68_SP = pop_sp;
1057 if (offset > 0) {
1058 MOVE (STACK_TOP, STACK_OFFSET (offset), (unt) size);
1059 genie_check_initialisation (p, STACK_TOP, result_mode);
1060 }
1061 INCREMENT_STACK_POINTER (selector, size);
1062 return GPROP (p);
1063 }
1064
1065 //! @brief SELECTION from a name
1066
1067 PROP_T genie_selection_name_quick (NODE_T * p)
1068 {
1069 NODE_T *selector = SUB (p);
1070 MOID_T *struct_mode = MOID (NEXT (selector));
1071 A68_REF *z = (A68_REF *) STACK_TOP;
1072 EXECUTE_UNIT (NEXT (selector));
1073 CHECK_REF (selector, *z, struct_mode);
1074 OFFSET (z) += OFFSET (NODE_PACK (SUB (selector)));
1075 return GPROP (p);
1076 }
1077
1078 //! @brief Push selection from secondary.
1079
1080 PROP_T genie_selection (NODE_T * p)
1081 {
1082 NODE_T *selector = SUB (p);
1083 MOID_T *struct_mode = MOID (NEXT (selector)), *result_mode = MOID (selector);
1084 BOOL_T selection_of_name = (BOOL_T) (IS_REF (struct_mode));
1085 PROP_T self;
1086 SOURCE (&self) = p;
1087 UNIT (&self) = genie_selection;
1088 EXECUTE_UNIT (NEXT (selector));
1089 // Multiple selections.
1090 if (selection_of_name && (IS_FLEX (SUB (struct_mode)) || IS_ROW (SUB (struct_mode)))) {
1091 A68_REF *row1;
1092 POP_ADDRESS (selector, row1, A68_REF);
1093 CHECK_REF (p, *row1, struct_mode);
1094 row1 = DEREF (A68_REF, row1);
1095 int dims = DIM (DEFLEX (SUB (struct_mode)));
1096 int desc_size = DESCRIPTOR_SIZE (dims);
1097 A68_REF row2 = heap_generator (selector, result_mode, desc_size);
1098 MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unt) desc_size);
1099 MOID ((DEREF (A68_ARRAY, &row2))) = SUB_SUB (result_mode);
1100 FIELD_OFFSET (DEREF (A68_ARRAY, &row2)) += OFFSET (NODE_PACK (SUB (selector)));
1101 A68_REF row3 = heap_generator (selector, result_mode, A68_REF_SIZE);
1102 *DEREF (A68_REF, &row3) = row2;
1103 PUSH_REF (selector, row3);
1104 UNIT (&self) = genie_selection;
1105 } else if (struct_mode != NO_MOID && (IS_FLEX (struct_mode) || IS_ROW (struct_mode))) {
1106 A68_REF *row1;
1107 POP_ADDRESS (selector, row1, A68_REF);
1108 int dims = DIM (DEFLEX (struct_mode));
1109 int desc_size = DESCRIPTOR_SIZE (dims);
1110 A68_REF row2 = heap_generator (selector, result_mode, desc_size);
1111 MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unt) desc_size);
1112 MOID ((DEREF (A68_ARRAY, &row2))) = SUB (result_mode);
1113 FIELD_OFFSET (DEREF (A68_ARRAY, &row2)) += OFFSET (NODE_PACK (SUB (selector)));
1114 PUSH_REF (selector, row2);
1115 UNIT (&self) = genie_selection;
1116 }
1117 // Normal selections.
1118 else if (selection_of_name && IS_STRUCT (SUB (struct_mode))) {
1119 A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE));
1120 CHECK_REF (selector, *z, struct_mode);
1121 OFFSET (z) += OFFSET (NODE_PACK (SUB (selector)));
1122 UNIT (&self) = genie_selection_name_quick;
1123 } else if (IS_STRUCT (struct_mode)) {
1124 DECREMENT_STACK_POINTER (selector, SIZE (struct_mode));
1125 MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (SUB (selector)))), (unt) SIZE (result_mode));
1126 genie_check_initialisation (p, STACK_TOP, result_mode);
1127 INCREMENT_STACK_POINTER (selector, SIZE (result_mode));
1128 UNIT (&self) = genie_selection_value_quick;
1129 }
1130 return self;
1131 }
1132
1133 //! @brief Push selection from primary.
1134
1135 PROP_T genie_field_selection (NODE_T * p)
1136 {
1137 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
1138 NODE_T *entry = p;
1139 A68_REF *z = (A68_REF *) STACK_TOP;
1140 A68_PROCEDURE *w = (A68_PROCEDURE *) STACK_TOP;
1141 PROP_T self;
1142 SOURCE (&self) = entry;
1143 UNIT (&self) = genie_field_selection;
1144 EXECUTE_UNIT (SUB (p));
1145 for (p = SEQUENCE (SUB (p)); p != NO_NODE; p = SEQUENCE (p)) {
1146 MOID_T *m = MOID (p);
1147 MOID_T *result_mode = MOID (NODE_PACK (p));
1148 BOOL_T coerce = A68_TRUE;
1149 while (coerce) {
1150 if (IS_REF (m) && ISNT (SUB (m), STRUCT_SYMBOL)) {
1151 int size = SIZE (SUB (m));
1152 A68_SP = pop_sp;
1153 CHECK_REF (p, *z, m);
1154 PUSH (p, ADDRESS (z), size);
1155 genie_check_initialisation (p, STACK_OFFSET (-size), MOID (p));
1156 m = SUB (m);
1157 } else if (IS (m, PROC_SYMBOL)) {
1158 genie_check_initialisation (p, (BYTE_T *) w, m);
1159 genie_call_procedure (p, m, m, M_VOID, w, pop_sp, pop_fp);
1160 STACK_DNS (p, MOID (p), A68_FP);
1161 m = SUB (m);
1162 } else {
1163 coerce = A68_FALSE;
1164 }
1165 }
1166 if (IS_REF (m) && IS (SUB (m), STRUCT_SYMBOL)) {
1167 CHECK_REF (p, *z, m);
1168 OFFSET (z) += OFFSET (NODE_PACK (p));
1169 } else if (IS_STRUCT (m)) {
1170 A68_SP = pop_sp;
1171 MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (p))), (unt) SIZE (result_mode));
1172 INCREMENT_STACK_POINTER (p, SIZE (result_mode));
1173 }
1174 }
1175 return self;
1176 }
1177
