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 // 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 NODE_T *seq = &top_seq;
218 GINFO_T g;
219 GINFO (&top_seq) = &g;
220 genie_subscript (indexer, &tup, &index, &seq);
221 SEQUENCE (p) = SEQUENCE (&top_seq);
222 STATUS_SET (p, SEQUENCE_MASK);
223 } else {
224 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; tup++, q = SEQUENCE (q)) {
225 A68_INT *j = (A68_INT *) STACK_TOP;
226 GENIE_UNIT_NO_GC (q);
227 INT_T k = VALUE (j);
228 if (k < LWB (tup) || k > UPB (tup)) {
229 diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
230 exit_genie (q, A68_RUNTIME_ERROR);
231 }
232 index += (SPAN (tup) * k - SHIFT (tup));
233 }
234 }
235 // Slice of a name yields a name.
236 A68_SP = pop_sp;
237 if (slice_name) {
238 A68_REF name = ARRAY (arr);
239 OFFSET (&name) += ROW_ELEMENT (arr, index);
240 REF_SCOPE (&name) = scope;
241 PUSH_REF (p, name);
242 if (STATUS_TEST (p, SEQUENCE_MASK)) {
243 UNIT (&self) = genie_slice_name_quick;
244 SOURCE (&self) = p;
245 }
246 } else {
247 BYTE_T *tos = STACK_TOP;
248 PUSH (p, &((ADDRESS (&(ARRAY (arr))))[ROW_ELEMENT (arr, index)]), SIZE (m_slice));
249 genie_check_initialisation (p, tos, m_slice);
250 }
251 return self;
252 } else if (ANNOTATION (indexer) == TRIMMER) {
253 // Trimming selects a subarray from an array.
254 int dim = DIM (DEFLEX (m_slice));
255 A68_REF ref_desc_copy = heap_generator (p, MOID (p), DESCRIPTOR_SIZE (dim));
256 // Get descriptor.
257 A68_REF z;
258 POP_REF (p, &z);
259 // Get indexer.
260 CHECK_REF (p, z, MOID (SUB (p)));
261 A68_ARRAY *old_des = DEREF (A68_ARRAY, &z), *new_des = DEREF (A68_ARRAY, &ref_desc_copy);
262 BYTE_T *ref_old = ADDRESS (&z) + SIZE_ALIGNED (A68_ARRAY);
263 BYTE_T *ref_new = ADDRESS (&ref_desc_copy) + SIZE_ALIGNED (A68_ARRAY);
264 DIM (new_des) = dim;
265 MOID (new_des) = MOID (old_des);
266 ELEM_SIZE (new_des) = ELEM_SIZE (old_des);
267 INT_T offset = SLICE_OFFSET (old_des);
268 genie_trimmer (indexer, &ref_new, &ref_old, &offset);
269 SLICE_OFFSET (new_des) = offset;
270 FIELD_OFFSET (new_des) = FIELD_OFFSET (old_des);
271 ARRAY (new_des) = ARRAY (old_des);
272 // Trim of a name is a name.
273 if (slice_name) {
274 A68_REF ref_trim = heap_generator (p, MOID (p), A68_REF_SIZE);
275 *DEREF (A68_REF, &ref_trim) = ref_desc_copy;
276 REF_SCOPE (&ref_trim) = scope;
277 PUSH_REF (p, ref_trim);
278 } else {
279 PUSH_REF (p, ref_desc_copy);
280 }
281 return self;
282 } else {
283 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
284 return self;
285 }
286 }
287
288 //! @brief SELECTION from a value
289
290 PROP_T genie_selection_value_quick (NODE_T * p)
291 {
292 NODE_T *selector = SUB (p);
293 MOID_T *result_mode = MOID (selector);
294 ADDR_T pop_sp = A68_SP;
295 int size = SIZE (result_mode);
296 INT_T offset = OFFSET (NODE_PACK (SUB (selector)));
297 GENIE_UNIT_NO_GC (NEXT (selector));
298 A68_SP = pop_sp;
299 if (offset > 0) {
300 MOVE (STACK_TOP, STACK_OFFSET (offset), (unt) size);
301 genie_check_initialisation (p, STACK_TOP, result_mode);
302 }
303 INCREMENT_STACK_POINTER (selector, size);
304 return GPROP (p);
305 }
306
307 //! @brief SELECTION from a name
308
309 PROP_T genie_selection_name_quick (NODE_T * p)
310 {
311 NODE_T *selector = SUB (p);
312 MOID_T *struct_mode = MOID (NEXT (selector));
313 A68_REF *z = (A68_REF *) STACK_TOP;
314 GENIE_UNIT_NO_GC (NEXT (selector));
315 CHECK_REF (selector, *z, struct_mode);
316 OFFSET (z) += OFFSET (NODE_PACK (SUB (selector)));
317 return GPROP (p);
318 }
319
320 //! @brief Push selection from secondary.
321
322 PROP_T genie_selection (NODE_T * p)
323 {
324 NODE_T *select = SUB (p);
325 MOID_T *m_str = MOID (NEXT (select)), *m_sel = MOID (select);
326 BOOL_T select_name = (BOOL_T) (IS_REF (m_str));
327 PROP_T self;
328 SOURCE (&self) = p;
329 UNIT (&self) = genie_selection;
330 GENIE_UNIT_NO_GC (NEXT (select));
331 // Multiple selections.
332 if (select_name && (IS_FLEX (SUB (m_str)) || IS_ROW (SUB (m_str)))) {
333 A68_REF *r_src;
334 POP_ADDRESS (select, r_src, A68_REF);
335 CHECK_REF (p, *r_src, m_str);
336 r_src = DEREF (A68_REF, r_src);
337 int dim = DIM (DEFLEX (SUB (m_str)));
338 int d_size = DESCRIPTOR_SIZE (dim);
339 A68_REF r_dst = heap_generator (select, m_sel, d_size);
340 MOVE (ADDRESS (&r_dst), DEREF (BYTE_T, r_src), (unt) d_size);
341 MOID ((DEREF (A68_ARRAY, &r_dst))) = SUB_SUB (m_sel);
342 FIELD_OFFSET (DEREF (A68_ARRAY, &r_dst)) += OFFSET (NODE_PACK (SUB (select)));
343 A68_REF r_sel = heap_generator (select, m_sel, A68_REF_SIZE);
344 *DEREF (A68_REF, &r_sel) = r_dst;
345 PUSH_REF (select, r_sel);
346 UNIT (&self) = genie_selection;
347 } else if (m_str != NO_MOID && (IS_FLEX (m_str) || IS_ROW (m_str))) {
348 A68_REF *r_src;
349 POP_ADDRESS (select, r_src, A68_REF);
350 int dim = DIM (DEFLEX (m_str));
351 int d_size = DESCRIPTOR_SIZE (dim);
352 A68_REF r_dst = heap_generator (select, m_sel, d_size);
353 MOVE (ADDRESS (&r_dst), DEREF (BYTE_T, r_src), (unt) d_size);
354 MOID ((DEREF (A68_ARRAY, &r_dst))) = SUB (m_sel);
355 FIELD_OFFSET (DEREF (A68_ARRAY, &r_dst)) += OFFSET (NODE_PACK (SUB (select)));
356 PUSH_REF (select, r_dst);
357 UNIT (&self) = genie_selection;
358 }
359 // Normal selections.
360 else if (select_name && IS_STRUCT (SUB (m_str))) {
361 A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE));
362 CHECK_REF (select, *z, m_str);
363 OFFSET (z) += OFFSET (NODE_PACK (SUB (select)));
364 UNIT (&self) = genie_selection_name_quick;
365 } else if (IS_STRUCT (m_str)) {
366 DECREMENT_STACK_POINTER (select, SIZE (m_str));
367 MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (SUB (select)))), (unt) SIZE (m_sel));
368 genie_check_initialisation (p, STACK_TOP, m_sel);
369 INCREMENT_STACK_POINTER (select, SIZE (m_sel));
370 UNIT (&self) = genie_selection_value_quick;
371 }
372 return self;
373 }
374
375 //! @brief Push selection from primary.
376
377 PROP_T genie_field_selection (NODE_T * p)
378 {
379 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
380 NODE_T *entry = p;
381 A68_REF *z = (A68_REF *) STACK_TOP;
382 A68_PROCEDURE *w = (A68_PROCEDURE *) STACK_TOP;
383 PROP_T self;
384 SOURCE (&self) = entry;
385 UNIT (&self) = genie_field_selection;
386 GENIE_UNIT_NO_GC (SUB (p));
387 for (p = SEQUENCE (SUB (p)); p != NO_NODE; p = SEQUENCE (p)) {
388 MOID_T *m = MOID (p);
389 MOID_T *m_sel = MOID (NODE_PACK (p));
390 BOOL_T coerce = A68_TRUE;
391 while (coerce) {
392 if (IS_REF (m) && ISNT (SUB (m), STRUCT_SYMBOL)) {
393 int size = SIZE (SUB (m));
394 A68_SP = pop_sp;
395 CHECK_REF (p, *z, m);
396 PUSH (p, ADDRESS (z), size);
397 genie_check_initialisation (p, STACK_OFFSET (-size), MOID (p));
398 m = SUB (m);
399 } else if (IS (m, PROC_SYMBOL)) {
400 genie_check_initialisation (p, (BYTE_T *) w, m);
401 genie_call_procedure (p, m, m, M_VOID, w, pop_sp, pop_fp);
402 STACK_DNS (p, MOID (p), A68_FP);
403 m = SUB (m);
404 } else {
405 coerce = A68_FALSE;
406 }
407 }
408 if (IS_REF (m) && IS (SUB (m), STRUCT_SYMBOL)) {
409 CHECK_REF (p, *z, m);
410 OFFSET (z) += OFFSET (NODE_PACK (p));
411 } else if (IS_STRUCT (m)) {
412 A68_SP = pop_sp;
413 MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (p))), (unt) SIZE (m_sel));
414 INCREMENT_STACK_POINTER (p, SIZE (m_sel));
415 }
416 }
417 return self;
418 }
419
