rts-stowed.c
1 //! @file rts-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-2024 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-prelude.h"
29
30 // Routines for handling stowed objects.
31 //
32 // An A68G row is a reference to a descriptor in the heap:
33 //
34 // ...
35 // A68_REF row -> A68_ARRAY ----+ ARRAY: Description of row, ref to elements.
36 // A68_TUPLE 1 | TUPLE: Bounds, one for every dimension.
37 // ... |
38 // A68_TUPLE dim |
39 // ... |
40 // ... |
41 // Element 1 <---+ Sequential row elements in the heap.
42 // ...
43 // Element n
44
45 //! @brief Size of a row.
46
47 int get_row_size (A68_TUPLE * tup, int dim)
48 {
49 int span = 1;
50 for (int k = 0; k < dim; k++) {
51 int stride = ROW_SIZE (&tup[k]);
52 ABEND ((stride > 0 && span > A68_MAX_INT / stride), ERROR_INVALID_SIZE, __func__);
53 span *= stride;
54 }
55 return span;
56 }
57
58 //! @brief Initialise index for FORALL constructs.
59
60 void initialise_internal_index (A68_TUPLE * tup, int dim)
61 {
62 for (int k = 0; k < dim; k++) {
63 A68_TUPLE *ref = &tup[k];
64 K (ref) = LWB (ref);
65 }
66 }
67
68 //! @brief Calculate index.
69
70 ADDR_T calculate_internal_index (A68_TUPLE * tup, int dim)
71 {
72 ADDR_T idx = 0;
73 for (int k = 0; k < dim; k++) {
74 A68_TUPLE *ref = &tup[k];
75 // Only consider non-empty rows.
76 if (ROW_SIZE (ref) > 0) {
77 idx += (SPAN (ref) * K (ref) - SHIFT (ref));
78 }
79 }
80 return idx;
81 }
82
83 //! @brief Increment index for FORALL constructs.
84
85 BOOL_T increment_internal_index (A68_TUPLE * tup, int dim)
86 {
87 BOOL_T carry = A68_TRUE;
88 for (int k = dim - 1; k >= 0 && carry; k--) {
89 A68_TUPLE *ref = &tup[k];
90 if (K (ref) < UPB (ref)) {
91 (K (ref))++;
92 carry = A68_FALSE;
93 } else {
94 K (ref) = LWB (ref);
95 }
96 }
97 return carry;
98 }
99
100 //! @brief Print index.
101
102 void print_internal_index (FILE_T f, A68_TUPLE * tup, int dim)
103 {
104 for (int k = 0; k < dim; k++) {
105 A68_TUPLE *ref = &tup[k];
106 BUFFER buf;
107 BUFCLR (buf);
108 ASSERT (a68_bufprt (buf, SNPRINTF_SIZE, A68_LD, K (ref)) >= 0);
109 WRITE (f, buf);
110 if (k < dim - 1) {
111 WRITE (f, ", ");
112 }
113 }
114 }
115
116 //! @brief Convert C string to A68 [] CHAR.
117
118 A68_REF c_string_to_row_char (NODE_T * p, char *str, int width)
119 {
120 A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup;
121 NEW_ROW_1D (z, row, arr, tup, M_ROW_CHAR, M_CHAR, width);
122 BYTE_T *base = ADDRESS (&row);
123 int len = strlen (str);
124 for (int k = 0; k < width; k++) {
125 A68_CHAR *ch = (A68_CHAR *) & (base[k * SIZE_ALIGNED (A68_CHAR)]);
126 STATUS (ch) = INIT_MASK;
127 VALUE (ch) = (k < len ? TO_UCHAR (str[k]) : NULL_CHAR);
128 }
129 return z;
130 }
131
132 //! @brief Convert C string to A68 string.
133
134 A68_REF c_to_a_string (NODE_T * p, char *str, int width)
135 {
136 if (str == NO_TEXT) {
137 return empty_string (p);
138 } else {
139 if (width == DEFAULT_WIDTH) {
140 return c_string_to_row_char (p, str, (int) strlen (str));
141 } else {
142 return c_string_to_row_char (p, str, (int) width);
143 }
144 }
145 }
146
147 //! @brief Size of a string.
148
149 int a68_string_size (NODE_T * p, A68_REF row)
150 {
151 (void) p;
152 if (INITIALISED (&row)) {
153 A68_ARRAY *arr; A68_TUPLE *tup;
154 GET_DESCRIPTOR (arr, tup, &row);
155 return ROW_SIZE (tup);
156 } else {
157 return 0;
158 }
159 }
160
161 //! @brief Convert A68 string to C string.
162
163 char *a_to_c_string (NODE_T * p, char *str, A68_REF row)
164 {
165 // Assume "str" to be long enough - caller's responsibility!.
166 (void) p;
167 if (INITIALISED (&row)) {
168 A68_ARRAY *arr; A68_TUPLE *tup;
169 GET_DESCRIPTOR (arr, tup, &row);
170 int size = ROW_SIZE (tup), n = 0;
171 if (size > 0) {
172 BYTE_T *base_address = ADDRESS (&ARRAY (arr));
173 for (int k = LWB (tup); k <= UPB (tup); k++) {
174 int addr = INDEX_1_DIM (arr, tup, k);
175 A68_CHAR *ch = (A68_CHAR *) & (base_address[addr]);
176 CHECK_INIT (p, INITIALISED (ch), M_CHAR);
177 str[n++] = (char) VALUE (ch);
178 }
179 }
180 str[n] = NULL_CHAR;
181 return str;
182 } else {
183 return NO_TEXT;
184 }
185 }
186
187 //! @brief Return an empty row.
188
189 A68_REF empty_row (NODE_T * p, MOID_T * m_row)
190 {
191 if (IS_FLEX (m_row)) {
192 m_row = SUB (m_row);
193 }
194 MOID_T *m_elem = SUB (m_row);
195 int dim = DIM (m_row);
196 A68_REF dsc; A68_ARRAY *arr; A68_TUPLE *tup;
197 dsc = heap_generator (p, m_row, DESCRIPTOR_SIZE (dim));
198 GET_DESCRIPTOR (arr, tup, &dsc);
199 DIM (arr) = dim;
200 MOID (arr) = SLICE (m_row);
201 ELEM_SIZE (arr) = moid_size (SLICE (m_row));
202 SLICE_OFFSET (arr) = 0;
203 FIELD_OFFSET (arr) = 0;
204 if (IS_ROW (m_elem) || IS_FLEX (m_elem)) {
205 // [] AMODE or FLEX [] AMODE
206 ARRAY (arr) = heap_generator (p, m_elem, A68_REF_SIZE);
207 *DEREF (A68_REF, &ARRAY (arr)) = empty_row (p, m_elem);
208 } else {
209 ARRAY (arr) = nil_ref;
210 }
211 STATUS (&ARRAY (arr)) = (STATUS_MASK_T) (INIT_MASK | IN_HEAP_MASK);
212 for (int k = 0; k < dim; k++) {
213 LWB (&tup[k]) = 1;
214 UPB (&tup[k]) = 0;
215 SPAN (&tup[k]) = 1;
216 SHIFT (&tup[k]) = LWB (tup);
217 }
218 return dsc;
219 }
220
221 //! @brief An empty string, FLEX [1 : 0] CHAR.
222
223 A68_REF empty_string (NODE_T * p)
224 {
225 return empty_row (p, M_STRING);
226 }
227
228 //! @brief Make [,, ..] MODE from [, ..] MODE.
229
230 A68_REF genie_make_rowrow (NODE_T *p, MOID_T * m_row, int len, ADDR_T pop_sp)
231 {
232 MOID_T *m_deflex = IS_FLEX (m_row) ? SUB (m_row) : m_row;
233 int old_dim = DIM (m_deflex) - 1;
234 // Make the new descriptor.
235 A68_ARRAY *new_arr; A68_TUPLE *new_tup;
236 A68_REF new_row = heap_generator (p, m_row, DESCRIPTOR_SIZE (DIM (m_deflex)));
237 GET_DESCRIPTOR (new_arr, new_tup, &new_row);
238 DIM (new_arr) = DIM (m_deflex);
239 MOID_T *m_elem = SUB (m_deflex);
240 MOID (new_arr) = m_elem;
241 ELEM_SIZE (new_arr) = SIZE (m_elem);
242 SLICE_OFFSET (new_arr) = 0;
243 FIELD_OFFSET (new_arr) = 0;
244 if (len == 0) {
245 // There is a vacuum on the stack.
246 for (int k = 0; k < old_dim; k++) {
247 LWB (&new_tup[k + 1]) = 1;
248 UPB (&new_tup[k + 1]) = 0;
249 SPAN (&new_tup[k + 1]) = 1;
250 SHIFT (&new_tup[k + 1]) = LWB (&new_tup[k + 1]);
251 }
252 LWB (new_tup) = 1;
253 UPB (new_tup) = 0;
254 SPAN (new_tup) = 0;
255 SHIFT (new_tup) = 0;
256 ARRAY (new_arr) = nil_ref;
257 return new_row;
258 } else if (len > 0) {
259 A68_ARRAY *tmp = NO_ARRAY;
260 // Arrays in the stack must have equal bounds.
261 A68_REF row_0 = *(A68_REF *) STACK_ADDRESS (pop_sp);
262 A68_TUPLE *tup_0;
263 GET_DESCRIPTOR (tmp, tup_0, &row_0);
264 for (int j = 1; j < len; j++) {
265 A68_REF row_j = *(A68_REF *) STACK_ADDRESS (pop_sp + j * A68_REF_SIZE);
266 A68_TUPLE *tup_j;
267 GET_DESCRIPTOR (tmp, tup_j, &row_j);
268 for (int k = 0; k < old_dim; k++) {
269 if ((UPB (&tup_0[k]) != UPB (&tup_j[k])) || (LWB (&tup_0[k]) != LWB (&tup_j[k]))) {
270 diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
271 exit_genie (p, A68_RUNTIME_ERROR);
272 }
273 }
274 }
275 // Fill descriptor of new row with info from (arbitrary) first one.
276 A68_ARRAY *old_arr; A68_TUPLE *old_tup;
277 A68_REF old_row = *(A68_REF *) STACK_ADDRESS (pop_sp);
278 GET_DESCRIPTOR (tmp, old_tup, &old_row);
279 int span = 1;
280 for (int k = 0; k < old_dim; k++) {
281 A68_TUPLE *tup = &new_tup[k + 1];
282 LWB (tup) = LWB (&old_tup[k]);
283 UPB (tup) = UPB (&old_tup[k]);
284 SPAN (tup) = span;
285 SHIFT (tup) = LWB (tup) * SPAN (tup);
286 span *= ROW_SIZE (tup);
287 }
288 LWB (new_tup) = 1;
289 UPB (new_tup) = len;
290 SPAN (new_tup) = span;
291 SHIFT (new_tup) = LWB (new_tup) * SPAN (new_tup);
292 ARRAY (new_arr) = heap_generator_2 (p, m_row, len, span * ELEM_SIZE (new_arr));
293 for (int j = 0; j < len; j++) {
294 // Copy new[j,, ] := old[, ].
295 GET_DESCRIPTOR (old_arr, old_tup, (A68_REF *) STACK_ADDRESS (pop_sp + j * A68_REF_SIZE));
296 if (LWB (old_tup) > UPB (old_tup)) {
297 A68_REF dst = ARRAY (new_arr);
298 ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], old_dim);
299 OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k);
300 A68_REF clone = empty_row (p, SLICE (m_row));
301 MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_elem));
302 } else {
303 initialise_internal_index (old_tup, old_dim);
304 initialise_internal_index (&new_tup[1], old_dim);
305 BOOL_T done = A68_FALSE;
306 while (!done) {
307 A68_REF src = ARRAY (old_arr), dst = ARRAY (new_arr);
308 ADDR_T old_k = calculate_internal_index (old_tup, old_dim);
309 ADDR_T new_k = j * SPAN (new_tup) + calculate_internal_index (&new_tup[1], old_dim);
310 OFFSET (&src) += ROW_ELEMENT (old_arr, old_k);
311 OFFSET (&dst) += ROW_ELEMENT (new_arr, new_k);
312 if (HAS_ROWS (m_elem)) {
313 A68_REF clone = genie_clone (p, m_elem, (A68_REF *) & nil_ref, &src);
314 MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_elem));
315 } else {
316 MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (m_elem));
317 }
318 done = increment_internal_index (old_tup, old_dim) | increment_internal_index (&new_tup[1], old_dim);
319 }
320 }
321 }
322 }
323 return new_row;
324 }
325
326 //! @brief Make a row of 'len' objects that are in the stack.
327
328 A68_REF genie_make_row (NODE_T * p, MOID_T * m_elem, int len, ADDR_T pop_sp)
329 {
330 A68_REF new_row, new_arr; A68_ARRAY arr; A68_TUPLE tup;
331 NEW_ROW_1D (new_row, new_arr, arr, tup, MOID (p), m_elem, len);
332 for (int k = 0; k < len * ELEM_SIZE (&arr); k += ELEM_SIZE (&arr)) {
333 A68_REF dst = new_arr, src;
334 OFFSET (&dst) += k;
335 STATUS (&src) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
336 OFFSET (&src) = pop_sp + k;
337 REF_HANDLE (&src) = (A68_HANDLE *) & nil_handle;
338 if (HAS_ROWS (m_elem)) {
339 A68_REF clone = genie_clone (p, m_elem, (A68_REF *) & nil_ref, &src);
340 MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_elem));
341 } else {
342 MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (m_elem));
343 }
344 }
345 return new_row;
346 }
347
348 //! @brief Make REF [1 : 1] [] MODE from REF [] MODE.
349
350 A68_REF genie_make_ref_row_of_row (NODE_T * p, MOID_T * m_dst, MOID_T * m_src, ADDR_T pop_sp)
351 {
352 m_dst = DEFLEX (m_dst);
353 m_src = DEFLEX (m_src);
354 A68_REF array = *(A68_REF *) STACK_ADDRESS (pop_sp);
355 // ROWING NIL yields NIL.
356 if (IS_NIL (array)) {
357 return nil_ref;
358 } else {
359 A68_REF new_row = heap_generator (p, SUB (m_dst), DESCRIPTOR_SIZE (1));
360 A68_REF name = heap_generator (p, m_dst, A68_REF_SIZE);
361 A68_ARRAY *arr; A68_TUPLE *tup;
362 GET_DESCRIPTOR (arr, tup, &new_row);
363 DIM (arr) = 1;
364 MOID (arr) = m_src;
365 ELEM_SIZE (arr) = SIZE (m_src);
366 SLICE_OFFSET (arr) = 0;
367 FIELD_OFFSET (arr) = 0;
368 ARRAY (arr) = array;
369 LWB (tup) = 1;
370 UPB (tup) = 1;
371 SPAN (tup) = 1;
372 SHIFT (tup) = LWB (tup);
373 *DEREF (A68_REF, &name) = new_row;
374 return name;
375 }
376 }
377
378 //! @brief Make REF [1 : 1, ..] MODE from REF [..] MODE.
379
380 A68_REF genie_make_ref_row_row (NODE_T * p, MOID_T * m_dst, MOID_T * m_src, ADDR_T pop_sp)
381 {
382 m_dst = DEFLEX (m_dst);
383 m_src = DEFLEX (m_src);
384 A68_REF name = *(A68_REF *) STACK_ADDRESS (pop_sp);
385 // ROWING NIL yields NIL.
386 if (IS_NIL (name)) {
387 return nil_ref;
388 }
389 A68_REF old_row = *DEREF (A68_REF, &name); A68_TUPLE *new_tup, *old_tup;
390 A68_ARRAY *old_arr;
391 GET_DESCRIPTOR (old_arr, old_tup, &old_row);
392 // Make new descriptor.
393 A68_REF new_row = heap_generator (p, m_dst, DESCRIPTOR_SIZE (DIM (SUB (m_dst))));
394 A68_ARRAY *new_arr;
395 name = heap_generator (p, m_dst, A68_REF_SIZE);
396 GET_DESCRIPTOR (new_arr, new_tup, &new_row);
397 DIM (new_arr) = DIM (SUB (m_dst));
398 MOID (new_arr) = MOID (old_arr);
399 ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr);
400 SLICE_OFFSET (new_arr) = 0;
401 FIELD_OFFSET (new_arr) = 0;
402 ARRAY (new_arr) = ARRAY (old_arr);
403 // Fill out the descriptor.
404 LWB (&(new_tup[0])) = 1;
405 UPB (&(new_tup[0])) = 1;
406 SPAN (&(new_tup[0])) = 1;
407 SHIFT (&(new_tup[0])) = LWB (&(new_tup[0]));
408 for (int k = 0; k < DIM (SUB (m_src)); k++) {
409 new_tup[k + 1] = old_tup[k];
410 }
411 // Yield the new name.
412 *DEREF (A68_REF, &name) = new_row;
413 return name;
414 }
415
416 //! @brief Coercion to [1 : 1, ] MODE.
417
418 PROP_T genie_rowing_row_row (NODE_T * p)
419 {
420 ADDR_T pop_sp = A68_SP;
421 GENIE_UNIT_NO_GC (SUB (p));
422 STACK_DNS (p, MOID (SUB (p)), A68_FP);
423 A68_REF row = genie_make_rowrow (p, MOID (p), 1, pop_sp);
424 A68_SP = pop_sp;
425 PUSH_REF (p, row);
426 return GPROP (p);
427 }
428
429 //! @brief Coercion to [1 : 1] [] MODE.
430
431 PROP_T genie_rowing_row_of_row (NODE_T * p)
432 {
433 ADDR_T pop_sp = A68_SP;
434 GENIE_UNIT_NO_GC (SUB (p));
435 STACK_DNS (p, MOID (SUB (p)), A68_FP);
436 A68_REF row = genie_make_row (p, SLICE (MOID (p)), 1, pop_sp);
437 A68_SP = pop_sp;
438 PUSH_REF (p, row);
439 return GPROP (p);
440 }
441
442 //! @brief Coercion to REF [1 : 1, ..] MODE.
443
444 PROP_T genie_rowing_ref_row_row (NODE_T * p)
445 {
446 ADDR_T pop_sp = A68_SP;
447 MOID_T *dst = MOID (p), *src = MOID (SUB (p));
448 GENIE_UNIT_NO_GC (SUB (p));
449 STACK_DNS (p, MOID (SUB (p)), A68_FP);
450 A68_SP = pop_sp;
451 A68_REF name = genie_make_ref_row_row (p, dst, src, pop_sp);
452 PUSH_REF (p, name);
453 return GPROP (p);
454 }
455
456 //! @brief REF [1 : 1] [] MODE from [] MODE
457
458 PROP_T genie_rowing_ref_row_of_row (NODE_T * p)
459 {
460 ADDR_T pop_sp = A68_SP;
461 MOID_T *m_dst = MOID (p), *src = MOID (SUB (p));
462 GENIE_UNIT_NO_GC (SUB (p));
463 STACK_DNS (p, MOID (SUB (p)), A68_FP);
464 A68_SP = pop_sp;
465 A68_REF name = genie_make_ref_row_of_row (p, m_dst, src, pop_sp);
466 PUSH_REF (p, name);
467 return GPROP (p);
468 }
469
470 //! @brief Rowing coercion.
471
472 PROP_T genie_rowing (NODE_T * p)
473 {
474 PROP_T self;
475 if (IS_REF (MOID (p))) {
476 // REF ROW, decide whether we want A->[] A or [] A->[,] A.
477 MOID_T *mode = SUB_MOID (p);
478 if (DIM (DEFLEX (mode)) >= 2) {
479 (void) genie_rowing_ref_row_row (p);
480 UNIT (&self) = genie_rowing_ref_row_row;
481 SOURCE (&self) = p;
482 } else {
483 (void) genie_rowing_ref_row_of_row (p);
484 UNIT (&self) = genie_rowing_ref_row_of_row;
485 SOURCE (&self) = p;
486 }
487 } else {
488 // ROW, decide whether we want A->[] A or [] A->[,] A.
489 if (DIM (DEFLEX (MOID (p))) >= 2) {
490 (void) genie_rowing_row_row (p);
491 UNIT (&self) = genie_rowing_row_row;
492 SOURCE (&self) = p;
493 } else {
494 (void) genie_rowing_row_of_row (p);
495 UNIT (&self) = genie_rowing_row_of_row;
496 SOURCE (&self) = p;
497 }
498 }
499 return self;
500 }
501
502 //! @brief Clone a compounded value referred to by 'old'.
503
504 A68_REF genie_clone (NODE_T * p, MOID_T * m, A68_REF * tmp, A68_REF * old)
505 {
506 // This complex routine is needed as arrays are not always contiguous.
507 // The routine takes a REF to the value and returns a REF to the clone.
508 if (m == M_SOUND) {
509 // REF SOUND.
510 A68_REF new_snd = heap_generator (p, m, SIZE (m));
511 A68_SOUND *w = DEREF (A68_SOUND, &new_snd);
512 int size = A68_SOUND_DATA_SIZE (w);
513 COPY ((BYTE_T *) w, ADDRESS (old), SIZE (M_SOUND));
514 BYTE_T *owd = ADDRESS (&(DATA (w)));
515 DATA (w) = heap_generator (p, M_SOUND_DATA, size);
516 COPY (ADDRESS (&(DATA (w))), owd, size);
517 return new_snd;
518 } else if (IS_STRUCT (m)) {
519 // REF STRUCT.
520 A68_REF new_str = heap_generator (p, m, SIZE (m));
521 for (PACK_T *field = PACK (m); field != NO_PACK; FORWARD (field)) {
522 MOID_T *m_f = MOID (field);
523 A68_REF old_f = *old, new_f = new_str;
524 OFFSET (&old_f) += OFFSET (field);
525 OFFSET (&new_f) += OFFSET (field);
526 A68_REF tmp_f = *tmp;
527 if (!IS_NIL (tmp_f)) {
528 OFFSET (&tmp_f) += OFFSET (field);
529 }
530 if (HAS_ROWS (m_f)) {
531 A68_REF clone = genie_clone (p, m_f, &tmp_f, &old_f);
532 MOVE (ADDRESS (&new_f), ADDRESS (&clone), SIZE (m_f));
533 } else {
534 MOVE (ADDRESS (&new_f), ADDRESS (&old_f), SIZE (m_f));
535 }
536 }
537 return new_str;
538 } else if (IS_UNION (m)) {
539 // REF UNION.
540 A68_REF new_uni = heap_generator (p, m, SIZE (m));
541 A68_REF src = *old;
542 A68_UNION *u = DEREF (A68_UNION, &src);
543 MOID_T *m_u = (MOID_T *) VALUE (u);
544 OFFSET (&src) += UNION_OFFSET;
545 A68_REF dst = new_uni;
546 *DEREF (A68_UNION, &dst) = *u;
547 OFFSET (&dst) += UNION_OFFSET;
548 // A union has formal members, so 'tmp' is irrelevant.
549 A68_REF tmp_u = nil_ref;
550 if (m_u != NO_MOID && HAS_ROWS (m_u)) {
551 A68_REF clone = genie_clone (p, m_u, &tmp_u, &src);
552 MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_u));
553 } else if (m_u != NO_MOID) {
554 MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (m_u));
555 }
556 return new_uni;
557 } else if (IS_FLEXETY_ROW (m)) {
558 // REF [FLEX] [].
559 MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
560 // Make new array.
561 A68_ARRAY *old_arr; A68_TUPLE *old_tup;
562 GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old));
563 A68_ARRAY *new_arr; A68_TUPLE *new_tup;
564 A68_REF nrow = heap_generator (p, m, DESCRIPTOR_SIZE (DIM (old_arr)));
565 GET_DESCRIPTOR (new_arr, new_tup, &nrow);
566 DIM (new_arr) = DIM (old_arr);
567 MOID (new_arr) = MOID (old_arr);
568 ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr);
569 SLICE_OFFSET (new_arr) = 0;
570 FIELD_OFFSET (new_arr) = 0;
571 // Get size and copy bounds; check in case of a row.
572 // This is just song and dance to comply with the RR.
573 BOOL_T check_bounds = A68_FALSE;
574 A68_REF ntmp; A68_ARRAY *tarr; A68_TUPLE *ttup = NO_TUPLE;
575 if (IS_NIL (*tmp)) {
576 ntmp = nil_ref;
577 } else {
578 A68_REF *z = DEREF (A68_REF, tmp);
579 if (!IS_NIL (*z)) {
580 GET_DESCRIPTOR (tarr, ttup, z);
581 ntmp = ARRAY (tarr);
582 check_bounds = IS_ROW (m);
583 }
584 }
585 int span = 1;
586 for (int k = 0; k < DIM (old_arr); k++) {
587 A68_TUPLE *op = &old_tup[k], *np = &new_tup[k];
588 if (check_bounds) {
589 A68_TUPLE *tp = &ttup[k];
590 if (UPB (tp) >= LWB (tp) && UPB (op) >= LWB (op)) {
591 if (UPB (tp) != UPB (op) || LWB (tp) != LWB (op)) {
592 diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
593 exit_genie (p, A68_RUNTIME_ERROR);
594 }
595 }
596 }
597 LWB (np) = LWB (op);
598 UPB (np) = UPB (op);
599 SPAN (np) = span;
600 SHIFT (np) = LWB (np) * SPAN (np);
601 span *= ROW_SIZE (np);
602 }
603 // Make a new array with at least a ghost element.
604 if (span == 0) {
605 ARRAY (new_arr) = heap_generator (p, em, ELEM_SIZE (new_arr));
606 } else {
607 ARRAY (new_arr) = heap_generator_2 (p, em, span, ELEM_SIZE (new_arr));
608 }
609 // Copy the ghost element if there are no elements.
610 if (span == 0) {
611 if (IS_UNION (em)) {
612 // UNION has formal members.
613 } else if (HAS_ROWS (em)) {
614 A68_REF old_ref, dst_ref, clone;
615 old_ref = ARRAY (old_arr);
616 OFFSET (&old_ref) += ROW_ELEMENT (old_arr, 0);
617 dst_ref = ARRAY (new_arr);
618 OFFSET (&dst_ref) += ROW_ELEMENT (new_arr, 0);
619 clone = genie_clone (p, em, &ntmp, &old_ref);
620 MOVE (ADDRESS (&dst_ref), ADDRESS (&clone), SIZE (em));
621 }
622 } else if (span > 0) {
623 // The n-dimensional copier.
624 initialise_internal_index (old_tup, DIM (old_arr));
625 initialise_internal_index (new_tup, DIM (new_arr));
626 BOOL_T done = A68_FALSE;
627 while (!done) {
628 A68_REF old_ref = ARRAY (old_arr), dst_ref = ARRAY (new_arr);
629 ADDR_T old_k = calculate_internal_index (old_tup, DIM (old_arr));
630 ADDR_T new_k = calculate_internal_index (new_tup, DIM (new_arr));
631 OFFSET (&old_ref) += ROW_ELEMENT (old_arr, old_k);
632 OFFSET (&dst_ref) += ROW_ELEMENT (new_arr, new_k);
633 if (HAS_ROWS (em)) {
634 A68_REF clone;
635 clone = genie_clone (p, em, &ntmp, &old_ref);
636 MOVE (ADDRESS (&dst_ref), ADDRESS (&clone), SIZE (em));
637 } else {
638 MOVE (ADDRESS (&dst_ref), ADDRESS (&old_ref), SIZE (em));
639 }
640 // Increase pointers.
641 done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr));
642 }
643 }
644 A68_REF heap = heap_generator (p, m, A68_REF_SIZE);
645 *DEREF (A68_REF, &heap) = nrow;
646 return heap;
647 }
648 return nil_ref;
649 }
650
651 //! @brief Store into a row, fi. trimmed destinations.
652
653 A68_REF genie_store (NODE_T * p, MOID_T * m, A68_REF * dst, A68_REF * old)
654 {
655 // This complex routine is needed as arrays are not always contiguous.
656 // The routine takes a REF to the value and returns a REF to the clone.
657 if (IS_FLEXETY_ROW (m)) {
658 // REF [FLEX] [].
659 A68_TUPLE *old_tup, *new_tup, *old_p, *new_p;
660 MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
661 BOOL_T done = A68_FALSE;
662 A68_ARRAY *old_arr, *new_arr;
663 GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old));
664 GET_DESCRIPTOR (new_arr, new_tup, DEREF (A68_REF, dst));
665 // Get size and check bounds.
666 // This is just song and dance to comply with the RR.
667 int span = 1;
668 for (int k = 0; k < DIM (old_arr); k++) {
669 old_p = &old_tup[k];
670 new_p = &new_tup[k];
671 if ((UPB (new_p) >= LWB (new_p) && UPB (old_p) >= LWB (old_p))) {
672 if ((UPB (new_p) != UPB (old_p) || LWB (new_p) != LWB (old_p))) {
673 diagnostic (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
674 exit_genie (p, A68_RUNTIME_ERROR);
675 }
676 }
677 span *= ROW_SIZE (new_p);
678 }
679 // Destination is an empty row, inspect if the source has elements.
680 if (span == 0) {
681 span = 1;
682 for (int k = 0; k < DIM (old_arr); k++) {
683 span *= ROW_SIZE (old_p);
684 }
685 if (span > 0) {
686 for (int k = 0; k < DIM (old_arr); k++) {
687 new_tup[k] = old_tup[k];
688 }
689 ARRAY (new_arr) = heap_generator_2 (p, em, span, ELEM_SIZE (new_arr));
690 }
691 }
692 if (span > 0) {
693 initialise_internal_index (old_tup, DIM (old_arr));
694 initialise_internal_index (new_tup, DIM (new_arr));
695 while (!done) {
696 A68_REF new_old = ARRAY (old_arr), new_dst = ARRAY (new_arr);
697 ADDR_T old_index = calculate_internal_index (old_tup, DIM (old_arr));
698 ADDR_T new_index = calculate_internal_index (new_tup, DIM (new_arr));
699 OFFSET (&new_old) += ROW_ELEMENT (old_arr, old_index);
700 OFFSET (&new_dst) += ROW_ELEMENT (new_arr, new_index);
701 MOVE (ADDRESS (&new_dst), ADDRESS (&new_old), SIZE (em));
702 done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr));
703 }
704 }
705 return *dst;
706 }
707 return nil_ref;
708 }
709
710 //! @brief Assignment of complex objects in the stack.
711
712 void genie_clone_stack (NODE_T * p, MOID_T * srcm, A68_REF * dst, A68_REF * tmp)
713 {
714 // STRUCT, UNION, [FLEX] [] or SOUND.
715 A68_REF stack;
716 STATUS (&stack) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
717 OFFSET (&stack) = A68_SP;
718 REF_HANDLE (&stack) = (A68_HANDLE *) & nil_handle;
719 A68_REF *src = DEREF (A68_REF, &stack);
720 if (IS_ROW (srcm) && !IS_NIL (*tmp)) {
721 if (STATUS (src) & SKIP_ROW_MASK) {
722 return;
723 }
724 A68_REF clone = genie_clone (p, srcm, tmp, &stack);
725 (void) genie_store (p, srcm, dst, &clone);
726 } else {
727 A68_REF clone = genie_clone (p, srcm, tmp, &stack);
728 MOVE (ADDRESS (dst), ADDRESS (&clone), SIZE (srcm));
729 }
730 }
731
732 //! @brief Strcmp for qsort.
733
734 int qstrcmp (const void *a, const void *b)
735 {
736 return strcmp (*(char *const *) a, *(char *const *) b);
737 }
738
739 //! @brief Sort row of string.
740
741 void genie_sort_row_string (NODE_T * p)
742 {
743 A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup;
744 POP_REF (p, &z);
745 ADDR_T pop_sp = A68_SP;
746 CHECK_REF (p, z, M_ROW_STRING);
747 GET_DESCRIPTOR (arr, tup, &z);
748 int size = ROW_SIZE (tup);
749 if (size > 0) {
750 BYTE_T *base = ADDRESS (&ARRAY (arr));
751 char **ptrs = (char **) a68_alloc ((size_t) (size * (int) sizeof (char *)), __func__, __LINE__);
752 if (ptrs == NO_VAR) {
753 diagnostic (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
754 exit_genie (p, A68_RUNTIME_ERROR);
755 }
756 // Copy C-strings into the stack and sort.
757 for (int j = 0, k = LWB (tup); k <= UPB (tup); j++, k++) {
758 int addr = INDEX_1_DIM (arr, tup, k);
759 A68_REF ref = *(A68_REF *) & (base[addr]);
760 CHECK_REF (p, ref, M_STRING);
761 int len = A68_ALIGN (a68_string_size (p, ref) + 1);
762 if (A68_SP + len > A68 (expr_stack_limit)) {
763 diagnostic (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);
764 exit_genie (p, A68_RUNTIME_ERROR);
765 }
766 ptrs[j] = (char *) STACK_TOP;
767 ASSERT (a_to_c_string (p, (char *) STACK_TOP, ref) != NO_TEXT);
768 INCREMENT_STACK_POINTER (p, len);
769 }
770 qsort (ptrs, (size_t) size, sizeof (char *), qstrcmp);
771 // Construct an array of sorted strings.
772 A68_REF row; A68_ARRAY arrn; A68_TUPLE tupn;
773 NEW_ROW_1D (z, row, arrn, tupn, M_ROW_STRING, M_STRING, size);
774 A68_REF *base_ref = DEREF (A68_REF, &row);
775 for (int k = 0; k < size; k++) {
776 base_ref[k] = c_to_a_string (p, ptrs[k], DEFAULT_WIDTH);
777 }
778 a68_free (ptrs);
779 A68_SP = pop_sp;
780 PUSH_REF (p, z);
781 } else {
782 // This is how we sort an empty row of strings ...
783 A68_SP = pop_sp;
784 PUSH_REF (p, empty_row (p, M_ROW_STRING));
785 }
786 }
