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-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 // An A68G row is a reference to a descriptor in the heap:
27 // A68_REF row -> A68_ARRAY ----+ ARRAY: Description of row, ref to elements.
28 // A68_TUPLE 1 | TUPLE: Bounds, one for every dimension.
29 // ... |
30 // A68_TUPLE dim |
31 // ... |
32 // ... |
33 // Element 1 <---+ Sequential row elements in the heap.
34 // ...
35 // Element n
36
37 #include "a68g.h"
38 #include "a68g-genie.h"
39 #include "a68g-prelude.h"
40
41 //! @brief Construct a descriptor "ref_new" for a trim of "ref_old".
42
43 void genie_trimmer (NODE_T * p, BYTE_T * *ref_new, BYTE_T * *ref_old, INT_T * offset)
44 {
45 if (p != NO_NODE) {
46 if (IS (p, UNIT)) {
47 GENIE_UNIT_NO_GC (p);
48 A68_INT k;
49 POP_OBJECT (p, &k, A68_INT);
50 A68_TUPLE *tup = (A68_TUPLE *) * ref_old;
51 CHECK_INDEX (p, &k, tup);
52 (*offset) += SPAN (tup) * VALUE (&k) - SHIFT (tup);
53 (*ref_old) += sizeof (A68_TUPLE);
54 } else if (IS (p, TRIMMER)) {
55 A68_TUPLE *old_tup = (A68_TUPLE *) * ref_old;
56 A68_TUPLE *new_tup = (A68_TUPLE *) * ref_new;
57 // TRIMMER is (l:u@r) with all units optional or (empty).
58 INT_T L, U, D;
59 NODE_T *q = SUB (p);
60 if (q == NO_NODE) {
61 L = LWB (old_tup);
62 U = UPB (old_tup);
63 D = 0;
64 } else {
65 BOOL_T absent = A68_TRUE;
66 // Lower index.
67 if (q != NO_NODE && IS (q, UNIT)) {
68 GENIE_UNIT_NO_GC (q);
69 A68_INT k;
70 POP_OBJECT (p, &k, A68_INT);
71 if (VALUE (&k) < LWB (old_tup)) {
72 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
73 exit_genie (p, A68_RUNTIME_ERROR);
74 }
75 L = VALUE (&k);
76 FORWARD (q);
77 absent = A68_FALSE;
78 } else {
79 L = LWB (old_tup);
80 }
81 if (q != NO_NODE && (IS (q, COLON_SYMBOL) || IS (q, DOTDOT_SYMBOL))) {
82 FORWARD (q);
83 absent = A68_FALSE;
84 }
85 // Upper index.
86 if (q != NO_NODE && IS (q, UNIT)) {
87 GENIE_UNIT_NO_GC (q);
88 A68_INT k;
89 POP_OBJECT (p, &k, A68_INT);
90 if (VALUE (&k) > UPB (old_tup)) {
91 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);
92 exit_genie (p, A68_RUNTIME_ERROR);
93 }
94 U = VALUE (&k);
95 FORWARD (q);
96 absent = A68_FALSE;
97 } else {
98 U = UPB (old_tup);
99 }
100 if (q != NO_NODE && IS (q, AT_SYMBOL)) {
101 FORWARD (q);
102 }
103 // Revised lower bound.
104 if (q != NO_NODE && IS (q, UNIT)) {
105 GENIE_UNIT_NO_GC (q);
106 A68_INT k;
107 POP_OBJECT (p, &k, A68_INT);
108 D = L - VALUE (&k);
109 FORWARD (q);
110 } else {
111 D = (absent ? 0 : L - 1);
112 }
113 }
114 LWB (new_tup) = L - D;
115 UPB (new_tup) = U - D; // (L - D) + (U - L)
116 SPAN (new_tup) = SPAN (old_tup);
117 SHIFT (new_tup) = SHIFT (old_tup) - D * SPAN (new_tup);
118 (*ref_old) += sizeof (A68_TUPLE);
119 (*ref_new) += sizeof (A68_TUPLE);
120 } else {
121 genie_trimmer (SUB (p), ref_new, ref_old, offset);
122 genie_trimmer (NEXT (p), ref_new, ref_old, offset);
123 }
124 }
125 }
126
127 //! @brief Calculation of subscript.
128
129 void genie_subscript (NODE_T * p, A68_TUPLE ** tup, INT_T * sum, NODE_T ** seq)
130 {
131 for (; p != NO_NODE; FORWARD (p)) {
132 switch (ATTRIBUTE (p)) {
133 case UNIT: {
134 GENIE_UNIT_NO_GC (p);
135 A68_INT *k;
136 POP_ADDRESS (p, k, A68_INT);
137 CHECK_INDEX (p, k, *tup);
138 (*sum) += (SPAN (*tup) * VALUE (k) - SHIFT (*tup));
139 (*tup)++;
140 SEQUENCE (*seq) = p;
141 (*seq) = p;
142 return;
143 }
144 case GENERIC_ARGUMENT:
145 case GENERIC_ARGUMENT_LIST: {
146 genie_subscript (SUB (p), tup, sum, seq);
147 }
148 }
149 }
150 }
151
152 //! @brief Slice REF [] A to REF A.
153
154 PROP_T genie_slice_name_quick (NODE_T * p)
155 {
156 A68_REF *z = (A68_REF *) STACK_TOP;
157 GENIE_UNIT_NO_GC (SUB (p));
158 CHECK_REF (p, *z, MOID (SUB (p)));
159 A68_ARRAY *arr; A68_TUPLE *tup;
160 GET_DESCRIPTOR (arr, tup, DEREF (A68_ROW, z));
161 ADDR_T pop_sp = A68_SP;
162 INT_T index = 0;
163 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
164 A68_INT *j = (A68_INT *) STACK_TOP;
165 GENIE_UNIT_NO_GC (q);
166 INT_T k = VALUE (j);
167 if (k < LWB (tup) || k > UPB (tup)) {
168 diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
169 exit_genie (q, A68_RUNTIME_ERROR);
170 }
171 index += (SPAN (tup) * k - SHIFT (tup));
172 tup++;
173 A68_SP = pop_sp;
174 }
175 // Leave reference to element on the stack, preserving scope.
176 ADDR_T scope = REF_SCOPE (z);
177 *z = ARRAY (arr);
178 OFFSET (z) += ROW_ELEMENT (arr, index);
179 REF_SCOPE (z) = scope;
180 return GPROP (p);
181 }
182
183 //! @brief Push slice of a rowed object.
184
185 PROP_T genie_slice (NODE_T * p)
186 {
187 BOOL_T slice_name = (BOOL_T) (IS_REF (MOID (SUB (p))));
188 MOID_T *m_slice = slice_name ? SUB_MOID (p) : MOID (p);
189 PROP_T self;
190 UNIT (&self) = genie_slice;
191 SOURCE (&self) = p;
192 ADDR_T pop_sp = A68_SP;
193 // Get row.
194 PROP_T primary;
195 GENIE_UNIT_NO_GC_2 (SUB (p), primary);
196 (void) primary;
197 // In case of slicing a REF [], we need the [] internally, so dereference.
198 ADDR_T scope = PRIMAL_SCOPE;
199 if (slice_name) {
200 A68_REF z;
201 POP_REF (p, &z);
202 CHECK_REF (p, z, MOID (SUB (p)));
203 scope = REF_SCOPE (&z);
204 PUSH_REF (p, *DEREF (A68_REF, &z));
205 }
206 NODE_T *indexer = NEXT_SUB (p);
207 if (ANNOTATION (indexer) == SLICE) {
208 // SLICING subscripts one element from an array.
209 A68_REF z;
210 POP_REF (p, &z);
211 CHECK_REF (p, z, MOID (SUB (p)));
212 A68_ARRAY *arr; A68_TUPLE *tup;
213 GET_DESCRIPTOR (arr, tup, &z);
214 INT_T index = 0;
215 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
216 NODE_T top_seq;
217 GINFO_T g;
218 NODE_T *seq = &top_seq;
219 GINFO (seq) = &g;
220 SEQUENCE (seq) = NO_NODE;
221 genie_subscript (indexer, &tup, &index, &seq);
222 SEQUENCE (p) = SEQUENCE (&top_seq);
223 STATUS_SET (p, SEQUENCE_MASK);
224 } else {
225 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; tup++, q = SEQUENCE (q)) {
226 A68_INT *j = (A68_INT *) STACK_TOP;
227 GENIE_UNIT_NO_GC (q);
228 INT_T k = VALUE (j);
229 if (k < LWB (tup) || k > UPB (tup)) {
230 diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
231 exit_genie (q, A68_RUNTIME_ERROR);
232 }
233 index += (SPAN (tup) * k - SHIFT (tup));
234 }
235 }
236 // Slice of a name yields a name.
237 A68_SP = pop_sp;
238 if (slice_name) {
239 A68_REF name = ARRAY (arr);
240 OFFSET (&name) += ROW_ELEMENT (arr, index);
241 REF_SCOPE (&name) = scope;
242 PUSH_REF (p, name);
243 if (STATUS_TEST (p, SEQUENCE_MASK)) {
244 UNIT (&self) = genie_slice_name_quick;
245 SOURCE (&self) = p;
246 }
247 } else {
248 BYTE_T *tos = STACK_TOP;
249 PUSH (p, &((ADDRESS (&(ARRAY (arr))))[ROW_ELEMENT (arr, index)]), SIZE (m_slice));
250 genie_check_initialisation (p, tos, m_slice);
251 }
252 return self;
253 } else if (ANNOTATION (indexer) == TRIMMER) {
254 // Trimming selects a subarray from an array.
255 int dim = DIM (DEFLEX (m_slice));
256 A68_REF ref_desc_copy = heap_generator (p, MOID (p), DESCRIPTOR_SIZE (dim));
257 // Get descriptor.
258 A68_REF z;
259 POP_REF (p, &z);
260 // Get indexer.
261 CHECK_REF (p, z, MOID (SUB (p)));
262 A68_ARRAY *old_des = DEREF (A68_ARRAY, &z), *new_des = DEREF (A68_ARRAY, &ref_desc_copy);
263 BYTE_T *ref_old = ADDRESS (&z) + SIZE_ALIGNED (A68_ARRAY);
264 BYTE_T *ref_new = ADDRESS (&ref_desc_copy) + SIZE_ALIGNED (A68_ARRAY);
265 DIM (new_des) = dim;
266 MOID (new_des) = MOID (old_des);
267 ELEM_SIZE (new_des) = ELEM_SIZE (old_des);
268 INT_T offset = SLICE_OFFSET (old_des);
269 genie_trimmer (indexer, &ref_new, &ref_old, &offset);
270 SLICE_OFFSET (new_des) = offset;
271 FIELD_OFFSET (new_des) = FIELD_OFFSET (old_des);
272 ARRAY (new_des) = ARRAY (old_des);
273 // Trim of a name is a name.
274 if (slice_name) {
275 A68_REF ref_trim = heap_generator (p, MOID (p), A68_REF_SIZE);
276 *DEREF (A68_REF, &ref_trim) = ref_desc_copy;
277 REF_SCOPE (&ref_trim) = scope;
278 PUSH_REF (p, ref_trim);
279 } else {
280 PUSH_REF (p, ref_desc_copy);
281 }
282 return self;
283 } else {
284 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
285 return self;
286 }
287 }
288
289 //! @brief SELECTION from a value
290
291 PROP_T genie_selection_value_quick (NODE_T * p)
292 {
293 NODE_T *selector = SUB (p);
294 MOID_T *result_mode = MOID (selector);
295 ADDR_T pop_sp = A68_SP;
296 int size = SIZE (result_mode);
297 INT_T offset = OFFSET (NODE_PACK (SUB (selector)));
298 GENIE_UNIT_NO_GC (NEXT (selector));
299 A68_SP = pop_sp;
300 if (offset > 0) {
301 MOVE (STACK_TOP, STACK_OFFSET (offset), (unt) size);
302 genie_check_initialisation (p, STACK_TOP, result_mode);
303 }
304 INCREMENT_STACK_POINTER (selector, size);
305 return GPROP (p);
306 }
307
308 //! @brief SELECTION from a name
309
310 PROP_T genie_selection_name_quick (NODE_T * p)
311 {
312 NODE_T *selector = SUB (p);
313 MOID_T *struct_mode = MOID (NEXT (selector));
314 A68_REF *z = (A68_REF *) STACK_TOP;
315 GENIE_UNIT_NO_GC (NEXT (selector));
316 CHECK_REF (selector, *z, struct_mode);
317 OFFSET (z) += OFFSET (NODE_PACK (SUB (selector)));
318 return GPROP (p);
319 }
320
321 //! @brief Push selection from secondary.
322
323 PROP_T genie_selection (NODE_T * p)
324 {
325 NODE_T *select = SUB (p);
326 MOID_T *m_str = MOID (NEXT (select)), *m_sel = MOID (select);
327 BOOL_T select_name = (BOOL_T) (IS_REF (m_str));
328 PROP_T self;
329 SOURCE (&self) = p;
330 UNIT (&self) = genie_selection;
331 GENIE_UNIT_NO_GC (NEXT (select));
332 // Multiple selections.
333 if (select_name && (IS_FLEX (SUB (m_str)) || IS_ROW (SUB (m_str)))) {
334 A68_REF *r_src;
335 POP_ADDRESS (select, r_src, A68_REF);
336 CHECK_REF (p, *r_src, m_str);
337 r_src = DEREF (A68_REF, r_src);
338 int dim = DIM (DEFLEX (SUB (m_str)));
339 int d_size = DESCRIPTOR_SIZE (dim);
340 A68_REF r_dst = heap_generator (select, m_sel, d_size);
341 MOVE (ADDRESS (&r_dst), DEREF (BYTE_T, r_src), (unt) d_size);
342 MOID ((DEREF (A68_ARRAY, &r_dst))) = SUB_SUB (m_sel);
343 FIELD_OFFSET (DEREF (A68_ARRAY, &r_dst)) += OFFSET (NODE_PACK (SUB (select)));
344 A68_REF r_sel = heap_generator (select, m_sel, A68_REF_SIZE);
345 *DEREF (A68_REF, &r_sel) = r_dst;
346 PUSH_REF (select, r_sel);
347 UNIT (&self) = genie_selection;
348 } else if (m_str != NO_MOID && (IS_FLEX (m_str) || IS_ROW (m_str))) {
349 A68_REF *r_src;
350 POP_ADDRESS (select, r_src, A68_REF);
351 int dim = DIM (DEFLEX (m_str));
352 int d_size = DESCRIPTOR_SIZE (dim);
353 A68_REF r_dst = heap_generator (select, m_sel, d_size);
354 MOVE (ADDRESS (&r_dst), DEREF (BYTE_T, r_src), (unt) d_size);
355 MOID ((DEREF (A68_ARRAY, &r_dst))) = SUB (m_sel);
356 FIELD_OFFSET (DEREF (A68_ARRAY, &r_dst)) += OFFSET (NODE_PACK (SUB (select)));
357 PUSH_REF (select, r_dst);
358 UNIT (&self) = genie_selection;
359 }
360 // Normal selections.
361 else if (select_name && IS_STRUCT (SUB (m_str))) {
362 A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE));
363 CHECK_REF (select, *z, m_str);
364 OFFSET (z) += OFFSET (NODE_PACK (SUB (select)));
365 UNIT (&self) = genie_selection_name_quick;
366 } else if (IS_STRUCT (m_str)) {
367 DECREMENT_STACK_POINTER (select, SIZE (m_str));
368 MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (SUB (select)))), (unt) SIZE (m_sel));
369 genie_check_initialisation (p, STACK_TOP, m_sel);
370 INCREMENT_STACK_POINTER (select, SIZE (m_sel));
371 UNIT (&self) = genie_selection_value_quick;
372 }
373 return self;
374 }
375
376 //! @brief Push selection from primary.
377
378 PROP_T genie_field_selection (NODE_T * p)
379 {
380 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
381 NODE_T *entry = p;
382 A68_REF *z = (A68_REF *) STACK_TOP;
383 A68_PROCEDURE *w = (A68_PROCEDURE *) STACK_TOP;
384 PROP_T self;
385 SOURCE (&self) = entry;
386 UNIT (&self) = genie_field_selection;
387 GENIE_UNIT_NO_GC (SUB (p));
388 for (p = SEQUENCE (SUB (p)); p != NO_NODE; p = SEQUENCE (p)) {
389 MOID_T *m = MOID (p);
390 MOID_T *m_sel = MOID (NODE_PACK (p));
391 BOOL_T coerce = A68_TRUE;
392 while (coerce) {
393 if (IS_REF (m) && ISNT (SUB (m), STRUCT_SYMBOL)) {
394 int size = SIZE (SUB (m));
395 A68_SP = pop_sp;
396 CHECK_REF (p, *z, m);
397 PUSH (p, ADDRESS (z), size);
398 genie_check_initialisation (p, STACK_OFFSET (-size), MOID (p));
399 m = SUB (m);
400 } else if (IS (m, PROC_SYMBOL)) {
401 genie_check_initialisation (p, (BYTE_T *) w, m);
402 genie_call_procedure (p, m, m, M_VOID, w, pop_sp, pop_fp);
403 STACK_DNS (p, MOID (p), A68_FP);
404 m = SUB (m);
405 } else {
406 coerce = A68_FALSE;
407 }
408 }
409 if (IS_REF (m) && IS (SUB (m), STRUCT_SYMBOL)) {
410 CHECK_REF (p, *z, m);
411 OFFSET (z) += OFFSET (NODE_PACK (p));
412 } else if (IS_STRUCT (m)) {
413 A68_SP = pop_sp;
414 MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (p))), (unt) SIZE (m_sel));
415 INCREMENT_STACK_POINTER (p, SIZE (m_sel));
416 }
417 }
418 return self;
419 }
420
