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-2025 J. Marcel van der Veer [algol68g@xs4all.nl].
8
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! 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 // A68G_REF row -> A68G_ARRAY ----+ ARRAY: Description of row, ref to elements.
36 // A68G_TUPLE 1 | TUPLE: Bounds, one for every dimension.
37 // ... |
38 // A68G_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 (A68G_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 > A68G_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 (A68G_TUPLE * tup, int dim)
61 {
62 for (int k = 0; k < dim; k++) {
63 A68G_TUPLE *ref = &tup[k];
64 K (ref) = LWB (ref);
65 }
66 }
67
68 //! @brief Calculate index.
69
70 ADDR_T calculate_internal_index (A68G_TUPLE * tup, int dim)
71 {
72 ADDR_T idx = 0;
73 for (int k = 0; k < dim; k++) {
74 A68G_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 (A68G_TUPLE * tup, int dim)
86 {
87 BOOL_T carry = A68G_TRUE;
88 for (int k = dim - 1; k >= 0 && carry; k--) {
89 A68G_TUPLE *ref = &tup[k];
90 if (K (ref) < UPB (ref)) {
91 (K (ref))++;
92 carry = A68G_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, A68G_TUPLE * tup, int dim)
103 {
104 for (int k = 0; k < dim; k++) {
105 A68G_TUPLE *ref = &tup[k];
106 BUFFER buf;
107 BUFCLR (buf);
108 ASSERT (a68g_bufprt (buf, SNPRINTF_SIZE, A68G_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 A68G_REF c_string_to_row_char (NODE_T * p, char *str, size_t width)
119 {
120 A68G_REF z, row; A68G_ARRAY arr; A68G_TUPLE tup;
121 NEW_ROW_1D (z, row, arr, tup, M_ROW_CHAR, M_CHAR, width);
122 BYTE_T *base = ADDRESS (&row);
123 size_t len = strlen (str);
124 for (int k = 0; k < width; k++) {
125 A68G_CHAR *ch = (A68G_CHAR *) & (base[k * SIZE_ALIGNED (A68G_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 A68G_REF c_to_a_string (NODE_T * p, char *str, size_t 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, strlen (str));
141 } else {
142 return c_string_to_row_char (p, str, width);
143 }
144 }
145 }
146
147 //! @brief Size of a string.
148
149 int a68g_string_size (NODE_T * p, A68G_REF row)
150 {
151 (void) p;
152 if (INITIALISED (&row)) {
153 A68G_ARRAY *arr; A68G_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, A68G_REF row)
164 {
165 // Assume "str" to be long enough - caller's responsibility!.
166 (void) p;
167 if (INITIALISED (&row)) {
168 A68G_ARRAY *arr; A68G_TUPLE *tup;
169 GET_DESCRIPTOR (arr, tup, &row);
170 size_t 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 A68G_CHAR *ch = (A68G_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 A68G_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 A68G_REF dsc; A68G_ARRAY *arr; A68G_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, A68G_REF_SIZE);
207 *DEREF (A68G_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 A68G_REF empty_string (NODE_T * p)
224 {
225 return empty_row (p, M_STRING);
226 }
227
228 //! @brief Make [,, ..] MODE from [, ..] MODE.
229
230 A68G_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 A68G_ARRAY *new_arr; A68G_TUPLE *new_tup;
236 A68G_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 A68G_ARRAY *tmp = NO_ARRAY;
260 // Arrays in the stack must have equal bounds.
261 A68G_REF row_0 = *(A68G_REF *) STACK_ADDRESS (pop_sp);
262 A68G_TUPLE *tup_0;
263 GET_DESCRIPTOR (tmp, tup_0, &row_0);
264 for (int j = 1; j < len; j++) {
265 A68G_REF row_j = *(A68G_REF *) STACK_ADDRESS (pop_sp + j * A68G_REF_SIZE);
266 A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
271 exit_genie (p, A68G_RUNTIME_ERROR);
272 }
273 }
274 }
275 // Fill descriptor of new row with info from (arbitrary) first one.
276 A68G_ARRAY *old_arr; A68G_TUPLE *old_tup;
277 A68G_REF old_row = *(A68G_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 A68G_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, (A68G_REF *) STACK_ADDRESS (pop_sp + j * A68G_REF_SIZE));
296 if (LWB (old_tup) > UPB (old_tup)) {
297 A68G_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 A68G_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 = A68G_FALSE;
306 while (!done) {
307 A68G_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 A68G_REF clone = genie_clone (p, m_elem, (A68G_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 A68G_REF genie_make_row (NODE_T * p, MOID_T * m_elem, int len, ADDR_T pop_sp)
329 {
330 A68G_REF new_row, new_arr; A68G_ARRAY arr; A68G_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 A68G_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) = (A68G_HANDLE *) & nil_handle;
338 if (HAS_ROWS (m_elem)) {
339 A68G_REF clone = genie_clone (p, m_elem, (A68G_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 A68G_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 A68G_REF array = *(A68G_REF *) STACK_ADDRESS (pop_sp);
355 // ROWING NIL yields NIL.
356 if (IS_NIL (array)) {
357 return nil_ref;
358 } else {
359 A68G_REF new_row = heap_generator (p, SUB (m_dst), DESCRIPTOR_SIZE (1));
360 A68G_REF name = heap_generator (p, m_dst, A68G_REF_SIZE);
361 A68G_ARRAY *arr; A68G_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 (A68G_REF, &name) = new_row;
374 return name;
375 }
376 }
377
378 //! @brief Make REF [1 : 1, ..] MODE from REF [..] MODE.
379
380 A68G_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 A68G_REF name = *(A68G_REF *) STACK_ADDRESS (pop_sp);
385 // ROWING NIL yields NIL.
386 if (IS_NIL (name)) {
387 return nil_ref;
388 }
389 A68G_REF old_row = *DEREF (A68G_REF, &name); A68G_TUPLE *new_tup, *old_tup;
390 A68G_ARRAY *old_arr;
391 GET_DESCRIPTOR (old_arr, old_tup, &old_row);
392 // Make new descriptor.
393 A68G_REF new_row = heap_generator (p, m_dst, DESCRIPTOR_SIZE (DIM (SUB (m_dst))));
394 A68G_ARRAY *new_arr;
395 name = heap_generator (p, m_dst, A68G_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 (A68G_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 = A68G_SP;
421 GENIE_UNIT_NO_GC (SUB (p));
422 STACK_DNS (p, MOID (SUB (p)), A68G_FP);
423 A68G_REF row = genie_make_rowrow (p, MOID (p), 1, pop_sp);
424 A68G_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 = A68G_SP;
434 GENIE_UNIT_NO_GC (SUB (p));
435 STACK_DNS (p, MOID (SUB (p)), A68G_FP);
436 A68G_REF row = genie_make_row (p, SLICE (MOID (p)), 1, pop_sp);
437 A68G_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 = A68G_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)), A68G_FP);
450 A68G_SP = pop_sp;
451 A68G_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 = A68G_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)), A68G_FP);
464 A68G_SP = pop_sp;
465 A68G_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 A68G_REF genie_clone (NODE_T * p, MOID_T * m, A68G_REF * tmp, A68G_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 A68G_REF new_snd = heap_generator (p, m, SIZE (M_SOUND));
511 A68G_SOUND *ns = DEREF (A68G_SOUND, &new_snd);
512 A68G_SOUND *os = DEREF (A68G_SOUND, old);
513 COPY ((BYTE_T *) ns, (BYTE_T *) os, SIZE (M_SOUND));
514 BYTE_T *nd = ADDRESS (&(DATA (ns)));
515 BYTE_T *od = ADDRESS (&(DATA (os)));
516 size_t size = A68G_SOUND_DATA_SIZE (os);
517 DATA (ns) = heap_generator (p, M_SOUND_DATA, size);
518 COPY ((BYTE_T *) nd, (BYTE_T *) od, size);
519 return new_snd;
520 } else if (IS_STRUCT (m)) {
521 // REF STRUCT.
522 A68G_REF new_str = heap_generator (p, m, SIZE (m));
523 for (PACK_T *field = PACK (m); field != NO_PACK; FORWARD (field)) {
524 MOID_T *m_f = MOID (field);
525 A68G_REF old_f = *old, new_f = new_str;
526 OFFSET (&old_f) += OFFSET (field);
527 OFFSET (&new_f) += OFFSET (field);
528 A68G_REF tmp_f = *tmp;
529 if (!IS_NIL (tmp_f)) {
530 OFFSET (&tmp_f) += OFFSET (field);
531 }
532 if (HAS_ROWS (m_f)) {
533 A68G_REF clone = genie_clone (p, m_f, &tmp_f, &old_f);
534 MOVE (ADDRESS (&new_f), ADDRESS (&clone), SIZE (m_f));
535 } else {
536 MOVE (ADDRESS (&new_f), ADDRESS (&old_f), SIZE (m_f));
537 }
538 }
539 return new_str;
540 } else if (IS_UNION (m)) {
541 // REF UNION.
542 A68G_REF new_uni = heap_generator (p, m, SIZE (m));
543 A68G_REF src = *old;
544 A68G_UNION *u = DEREF (A68G_UNION, &src);
545 MOID_T *m_u = (MOID_T *) VALUE (u);
546 OFFSET (&src) += UNION_OFFSET;
547 A68G_REF dst = new_uni;
548 *DEREF (A68G_UNION, &dst) = *u;
549 OFFSET (&dst) += UNION_OFFSET;
550 // A union has formal members, so 'tmp' is irrelevant.
551 A68G_REF tmp_u = nil_ref;
552 if (m_u != NO_MOID && HAS_ROWS (m_u)) {
553 A68G_REF clone = genie_clone (p, m_u, &tmp_u, &src);
554 MOVE (ADDRESS (&dst), ADDRESS (&clone), SIZE (m_u));
555 } else if (m_u != NO_MOID) {
556 MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (m_u));
557 }
558 return new_uni;
559 } else if (IS_FLEXETY_ROW (m)) {
560 // REF [FLEX] [].
561 MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
562 // Make new array.
563 A68G_ARRAY *old_arr; A68G_TUPLE *old_tup;
564 GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68G_REF, old));
565 A68G_ARRAY *new_arr; A68G_TUPLE *new_tup;
566 A68G_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 = A68G_FALSE;
576 A68G_REF ntmp; A68G_ARRAY *tarr; A68G_TUPLE *ttup = NO_TUPLE;
577 if (IS_NIL (*tmp)) {
578 ntmp = nil_ref;
579 } else {
580 A68G_REF *z = DEREF (A68G_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 A68G_TUPLE *op = &old_tup[k], *np = &new_tup[k];
590 if (check_bounds) {
591 A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
595 exit_genie (p, A68G_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_2 (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 A68G_REF old_ref, dst_ref, 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 clone = genie_clone (p, em, &ntmp, &old_ref);
622 MOVE (ADDRESS (&dst_ref), ADDRESS (&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 = A68G_FALSE;
629 while (!done) {
630 A68G_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 A68G_REF clone;
637 clone = genie_clone (p, em, &ntmp, &old_ref);
638 MOVE (ADDRESS (&dst_ref), ADDRESS (&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 A68G_REF heap = heap_generator (p, m, A68G_REF_SIZE);
647 *DEREF (A68G_REF, &heap) = nrow;
648 return heap;
649 }
650 return nil_ref;
651 }
652
653 //! @brief Store into a row, fi. trimmed destinations.
654
655 A68G_REF genie_store (NODE_T * p, MOID_T * m, A68G_REF * dst, A68G_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 (IS_FLEXETY_ROW (m)) {
660 // REF [FLEX] [].
661 A68G_TUPLE *old_tup, *new_tup, *old_p, *new_p;
662 MOID_T *em = SUB (IS_FLEX (m) ? SUB (m) : m);
663 BOOL_T done = A68G_FALSE;
664 A68G_ARRAY *old_arr, *new_arr;
665 GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68G_REF, old));
666 GET_DESCRIPTOR (new_arr, new_tup, DEREF (A68G_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 (A68G_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS);
676 exit_genie (p, A68G_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 for (int k = 0; k < DIM (old_arr); k++) {
689 new_tup[k] = old_tup[k];
690 }
691 ARRAY (new_arr) = heap_generator_2 (p, em, span, ELEM_SIZE (new_arr));
692 }
693 }
694 if (span > 0) {
695 initialise_internal_index (old_tup, DIM (old_arr));
696 initialise_internal_index (new_tup, DIM (new_arr));
697 while (!done) {
698 A68G_REF new_old = ARRAY (old_arr), new_dst = ARRAY (new_arr);
699 ADDR_T old_index = calculate_internal_index (old_tup, DIM (old_arr));
700 ADDR_T new_index = calculate_internal_index (new_tup, DIM (new_arr));
701 OFFSET (&new_old) += ROW_ELEMENT (old_arr, old_index);
702 OFFSET (&new_dst) += ROW_ELEMENT (new_arr, new_index);
703 MOVE (ADDRESS (&new_dst), ADDRESS (&new_old), SIZE (em));
704 done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr));
705 }
706 }
707 return *dst;
708 }
709 return nil_ref;
710 }
711
712 //! @brief Assignment of complex objects in the stack.
713
714 void genie_clone_stack (NODE_T * p, MOID_T * srcm, A68G_REF * dst, A68G_REF * tmp)
715 {
716 // STRUCT, UNION, [FLEX] [] or SOUND.
717 A68G_REF stack;
718 STATUS (&stack) = (STATUS_MASK_T) (INIT_MASK | IN_STACK_MASK);
719 OFFSET (&stack) = A68G_SP;
720 REF_HANDLE (&stack) = (A68G_HANDLE *) & nil_handle;
721 A68G_REF *src = DEREF (A68G_REF, &stack);
722 if (IS_ROW (srcm) && !IS_NIL (*tmp)) {
723 if (STATUS (src) & SKIP_ROW_MASK) {
724 return;
725 }
726 A68G_REF clone = genie_clone (p, srcm, tmp, &stack);
727 (void) genie_store (p, srcm, dst, &clone);
728 } else {
729 A68G_REF clone = genie_clone (p, srcm, tmp, &stack);
730 MOVE (ADDRESS (dst), ADDRESS (&clone), SIZE (srcm));
731 }
732 }
733
734 //! @brief Strcmp for qsort.
735
736 int qstrcmp (const void *a, const void *b)
737 {
738 return strcmp (*(char *const *) a, *(char *const *) b);
739 }
740
741 //! @brief Sort row of string.
742
743 void genie_sort_row_string (NODE_T * p)
744 {
745 A68G_REF z; A68G_ARRAY *arr; A68G_TUPLE *tup;
746 POP_REF (p, &z);
747 ADDR_T pop_sp = A68G_SP;
748 CHECK_REF (p, z, M_ROW_STRING);
749 GET_DESCRIPTOR (arr, tup, &z);
750 size_t size = ROW_SIZE (tup);
751 if (size > 0) {
752 BYTE_T *base = ADDRESS (&ARRAY (arr));
753 char **ptrs = (char **) a68g_alloc ((size_t) (size * (int) sizeof (char *)), __func__, __LINE__);
754 if (ptrs == NO_REF) {
755 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE);
756 exit_genie (p, A68G_RUNTIME_ERROR);
757 }
758 // Copy C-strings into the stack and sort.
759 for (int j = 0, k = LWB (tup); k <= UPB (tup); j++, k++) {
760 int addr = INDEX_1_DIM (arr, tup, k);
761 A68G_REF ref = *(A68G_REF *) & (base[addr]);
762 CHECK_REF (p, ref, M_STRING);
763 int len = A68G_ALIGN (a68g_string_size (p, ref) + 1);
764 if (A68G_SP + len > A68G (expr_stack_limit)) {
765 diagnostic (A68G_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);
766 exit_genie (p, A68G_RUNTIME_ERROR);
767 }
768 ptrs[j] = (char *) STACK_TOP;
769 ASSERT (a_to_c_string (p, (char *) STACK_TOP, ref) != NO_TEXT);
770 INCREMENT_STACK_POINTER (p, len);
771 }
772 qsort (ptrs, (size_t) size, sizeof (char *), qstrcmp);
773 // Construct an array of sorted strings.
774 A68G_REF row; A68G_ARRAY arrn; A68G_TUPLE tupn;
775 NEW_ROW_1D (z, row, arrn, tupn, M_ROW_STRING, M_STRING, size);
776 A68G_REF *base_ref = DEREF (A68G_REF, &row);
777 for (int k = 0; k < size; k++) {
778 base_ref[k] = c_to_a_string (p, ptrs[k], DEFAULT_WIDTH);
779 }
780 a68g_free (ptrs);
781 A68G_SP = pop_sp;
782 PUSH_REF (p, z);
783 } else {
784 // This is how we sort an empty row of strings ...
785 A68G_SP = pop_sp;
786 PUSH_REF (p, empty_row (p, M_ROW_STRING));
787 }
788 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
