genie-coerce.c
1 //! @file genie-coerce.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 mode coercion routines.
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
34 //! @brief Push result of cast (coercions are deeper in the tree).
35
36 PROP_T genie_cast (NODE_T * p)
37 {
38 GENIE_UNIT (NEXT_SUB (p));
39 PROP_T self;
40 UNIT (&self) = genie_cast;
41 SOURCE (&self) = p;
42 return self;
43 }
44
45 //! @brief Unite value in the stack and push result.
46
47 PROP_T genie_uniting (NODE_T * p)
48 {
49 ADDR_T pop_sp = A68_SP;
50 MOID_T *u = MOID (p), *v = MOID (SUB (p));
51 if (ATTRIBUTE (v) != UNION_SYMBOL) {
52 MOID_T *w = unites_to (v, u);
53 PUSH_UNION (p, (void *) w);
54 GENIE_UNIT (SUB (p));
55 STACK_DNS (p, SUB (v), A68_FP);
56 } else {
57 A68_UNION *m = (A68_UNION *) STACK_TOP;
58 GENIE_UNIT (SUB (p));
59 STACK_DNS (p, SUB (v), A68_FP);
60 VALUE (m) = (void *) unites_to ((MOID_T *) VALUE (m), u);
61 if (!IS (u, ROWS_SYMBOL) && VALUE (m) == NO_MOID) {
62 diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE_FROM, v);
63 exit_genie (p, A68_RUNTIME_ERROR);
64 }
65 }
66 A68_SP = pop_sp + SIZE (u);
67 PROP_T self;
68 UNIT (&self) = genie_uniting;
69 SOURCE (&self) = p;
70 return self;
71 }
72
73 //! @brief Store widened constant as a constant.
74
75 void make_constant_widening (NODE_T * p, MOID_T * m, PROP_T * self)
76 {
77 if (SUB (p) != NO_NODE && CONSTANT (GINFO (SUB (p))) != NO_CONSTANT) {
78 int size = SIZE (m);
79 UNIT (self) = genie_constant;
80 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
81 SIZE (GINFO (p)) = size;
82 COPY (CONSTANT (GINFO (p)), (void *) (STACK_OFFSET (-size)), size);
83 }
84 }
85
86 //! @brief (optimised) push INT widened to REAL
87
88 PROP_T genie_widen_int_to_real (NODE_T * p)
89 {
90 A68_INT *i = (A68_INT *) STACK_TOP;
91 A68_REAL *z = (A68_REAL *) STACK_TOP;
92 GENIE_UNIT (SUB (p));
93 INCREMENT_STACK_POINTER (p, SIZE_ALIGNED (A68_REAL) - SIZE (M_INT));
94 VALUE (z) = (REAL_T) VALUE (i);
95 STATUS (z) = INIT_MASK;
96 return GPROP (p);
97 }
98
99 //! @brief Widen value in the stack.
100
101 PROP_T genie_widen (NODE_T * p)
102 {
103 #define COERCE_FROM_TO(p, a, b) (MOID (p) == (b) && MOID (SUB (p)) == (a))
104 PROP_T self;
105 UNIT (&self) = genie_widen;
106 SOURCE (&self) = p;
107 // INT widenings.
108 if (COERCE_FROM_TO (p, M_INT, M_REAL)) {
109 (void) genie_widen_int_to_real (p);
110 UNIT (&self) = genie_widen_int_to_real;
111 make_constant_widening (p, M_REAL, &self);
112 } else if (COERCE_FROM_TO (p, M_INT, M_LONG_INT)) {
113 GENIE_UNIT (SUB (p));
114 #if (A68_LEVEL >= 3)
115 genie_lengthen_int_to_double_int (p);
116 #else
117 genie_lengthen_int_to_mp (p);
118 #endif
119 make_constant_widening (p, M_LONG_INT, &self);
120 } else if (COERCE_FROM_TO (p, M_LONG_INT, M_LONG_LONG_INT)) {
121 GENIE_UNIT (SUB (p));
122 #if (A68_LEVEL >= 3)
123 genie_lengthen_double_int_to_mp (p);
124 #else
125 genie_lengthen_mp_to_long_mp (p);
126 #endif
127 make_constant_widening (p, M_LONG_LONG_INT, &self);
128 } else if (COERCE_FROM_TO (p, M_LONG_INT, M_LONG_REAL)) {
129 #if (A68_LEVEL >= 3)
130 (void) genie_widen_double_int_to_double (p);
131 #else
132 // 1-1 mapping.
133 GENIE_UNIT (SUB (p));
134 #endif
135 make_constant_widening (p, M_LONG_REAL, &self);
136 } else if (COERCE_FROM_TO (p, M_LONG_LONG_INT, M_LONG_LONG_REAL)) {
137 GENIE_UNIT (SUB (p));
138 // 1-1 mapping.
139 make_constant_widening (p, M_LONG_LONG_REAL, &self);
140 }
141 // REAL widenings.
142 else if (COERCE_FROM_TO (p, M_REAL, M_LONG_REAL)) {
143 GENIE_UNIT (SUB (p));
144 #if (A68_LEVEL >= 3)
145 genie_lengthen_real_to_double (p);
146 #else
147 genie_lengthen_real_to_mp (p);
148 #endif
149 make_constant_widening (p, M_LONG_REAL, &self);
150 } else if (COERCE_FROM_TO (p, M_LONG_REAL, M_LONG_LONG_REAL)) {
151 GENIE_UNIT (SUB (p));
152 #if (A68_LEVEL >= 3)
153 genie_lengthen_double_to_mp (p);
154 #else
155 genie_lengthen_mp_to_long_mp (p);
156 #endif
157 make_constant_widening (p, M_LONG_LONG_REAL, &self);
158 } else if (COERCE_FROM_TO (p, M_REAL, M_COMPLEX)) {
159 GENIE_UNIT (SUB (p));
160 PUSH_VALUE (p, 0.0, A68_REAL);
161 make_constant_widening (p, M_COMPLEX, &self);
162 } else if (COERCE_FROM_TO (p, M_LONG_REAL, M_LONG_COMPLEX)) {
163 #if (A68_LEVEL >= 3)
164 DOUBLE_NUM_T z;
165 z.f = 0.0q;
166 GENIE_UNIT (SUB (p));
167 PUSH_VALUE (p, z, A68_LONG_REAL);
168 #else
169 GENIE_UNIT (SUB (p));
170 (void) nil_mp (p, DIGITS (M_LONG_REAL));
171 make_constant_widening (p, M_LONG_COMPLEX, &self);
172 #endif
173 } else if (COERCE_FROM_TO (p, M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX)) {
174 GENIE_UNIT (SUB (p));
175 (void) nil_mp (p, DIGITS (M_LONG_LONG_REAL));
176 make_constant_widening (p, M_LONG_LONG_COMPLEX, &self);
177 } else if (COERCE_FROM_TO (p, M_COMPLEX, M_LONG_COMPLEX)) {
178 // COMPLEX widenings.
179 GENIE_UNIT (SUB (p));
180 #if (A68_LEVEL >= 3)
181 genie_lengthen_complex_to_double_compl (p);
182 #else
183 genie_lengthen_complex_to_mp_complex (p);
184 #endif
185 make_constant_widening (p, M_LONG_COMPLEX, &self);
186 } else if (COERCE_FROM_TO (p, M_LONG_COMPLEX, M_LONG_LONG_COMPLEX)) {
187 GENIE_UNIT (SUB (p));
188 #if (A68_LEVEL >= 3)
189 genie_lengthen_double_compl_to_long_mp_complex (p);
190 #else
191 genie_lengthen_mp_complex_to_long_mp_complex (p);
192 #endif
193 make_constant_widening (p, M_LONG_LONG_COMPLEX, &self);
194 } else if (COERCE_FROM_TO (p, M_BITS, M_LONG_BITS)) {
195 // BITS widenings.
196 GENIE_UNIT (SUB (p));
197 #if (A68_LEVEL >= 3)
198 genie_lengthen_bits_to_double_bits (p);
199 #else
200 genie_lengthen_int_to_mp (p);
201 #endif
202 make_constant_widening (p, M_LONG_BITS, &self);
203 } else if (COERCE_FROM_TO (p, M_LONG_BITS, M_LONG_LONG_BITS)) {
204 #if (A68_LEVEL >= 3)
205 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
206 #else
207 GENIE_UNIT (SUB (p));
208 genie_lengthen_mp_to_long_mp (p);
209 make_constant_widening (p, M_LONG_LONG_BITS, &self);
210 #endif
211 } else if (COERCE_FROM_TO (p, M_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_BITS, M_FLEX_ROW_BOOL)) {
212 GENIE_UNIT (SUB (p));
213 A68_BITS x;
214 POP_OBJECT (p, &x, A68_BITS);
215 A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup;
216 NEW_ROW_1D (z, row, arr, tup, M_ROW_BOOL, M_BOOL, A68_BITS_WIDTH);
217 BYTE_T *base = ADDRESS (&row) + SIZE (M_BOOL) * (A68_BITS_WIDTH - 1);
218 UNSIGNED_T bit = 1;
219 for (int k = A68_BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_BOOL), bit <<= 1) {
220 STATUS ((A68_BOOL *) base) = INIT_MASK;
221 VALUE ((A68_BOOL *) base) = (BOOL_T) ((VALUE (&x) & bit) != 0 ? A68_TRUE : A68_FALSE);
222 }
223 PUSH_REF (p, z);
224 } else if (COERCE_FROM_TO (p, M_LONG_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_LONG_BITS, M_FLEX_ROW_BOOL)) {
225 #if (A68_LEVEL >= 3)
226 GENIE_UNIT (SUB (p));
227 A68_LONG_BITS x;
228 POP_OBJECT (p, &x, A68_LONG_BITS);
229 A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup;
230 NEW_ROW_1D (z, row, arr, tup, M_ROW_BOOL, M_BOOL, A68_LONG_BITS_WIDTH);
231 BYTE_T *base = ADDRESS (&row) + SIZE (M_BOOL) * (A68_LONG_BITS_WIDTH - 1);
232 UNSIGNED_T bit = 1;
233 for (int k = A68_BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_BOOL), bit <<= 1) {
234 STATUS ((A68_BOOL *) base) = INIT_MASK;
235 VALUE ((A68_BOOL *) base) = (BOOL_T) ((LW (VALUE (&x)) & bit) != 0 ? A68_TRUE : A68_FALSE);
236 }
237 bit = 1;
238 for (int k = A68_BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (M_BOOL), bit <<= 1) {
239 STATUS ((A68_BOOL *) base) = INIT_MASK;
240 VALUE ((A68_BOOL *) base) = (BOOL_T) ((HW (VALUE (&x)) & bit) != 0 ? A68_TRUE : A68_FALSE);
241 }
242 PUSH_REF (p, z);
243 #else
244 GENIE_UNIT (SUB (p));
245 genie_lengthen_long_bits_to_row_bool (p);
246 #endif
247 } else if (COERCE_FROM_TO (p, M_LONG_LONG_BITS, M_ROW_BOOL) || COERCE_FROM_TO (p, M_LONG_LONG_BITS, M_FLEX_ROW_BOOL)) {
248 #if (A68_LEVEL <= 2)
249 GENIE_UNIT (SUB (p));
250 genie_lengthen_long_bits_to_row_bool (p);
251 #endif
252 } else if (COERCE_FROM_TO (p, M_BYTES, M_ROW_CHAR) || COERCE_FROM_TO (p, M_BYTES, M_FLEX_ROW_CHAR)) {
253 GENIE_UNIT (SUB (p));
254 A68_BYTES z;
255 POP_OBJECT (p, &z, A68_BYTES);
256 PUSH_REF (p, c_string_to_row_char (p, VALUE (&z), A68_BYTES_WIDTH));
257 } else if (COERCE_FROM_TO (p, M_LONG_BYTES, M_ROW_CHAR) || COERCE_FROM_TO (p, M_LONG_BYTES, M_FLEX_ROW_CHAR)) {
258 GENIE_UNIT (SUB (p));
259 A68_LONG_BYTES z;
260 POP_OBJECT (p, &z, A68_LONG_BYTES);
261 PUSH_REF (p, c_string_to_row_char (p, VALUE (&z), A68_LONG_BYTES_WIDTH));
262 } else {
263 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CANNOT_WIDEN, MOID (SUB (p)), MOID (p));
264 exit_genie (p, A68_RUNTIME_ERROR);
265 }
266 return self;
267 #undef COERCE_FROM_TO
268 }
269
270 //! @brief Cast a jump to a PROC VOID without executing the jump.
271
272 void genie_proceduring (NODE_T * p)
273 {
274 NODE_T *jump = SUB (p);
275 NODE_T *q = SUB (jump);
276 NODE_T *label = (IS (q, GOTO_SYMBOL) ? NEXT (q) : q);
277 A68_PROCEDURE z;
278 STATUS (&z) = INIT_MASK;
279 NODE (&(BODY (&z))) = jump;
280 STATIC_LINK_FOR_FRAME (ENVIRON (&z), 1 + TAG_LEX_LEVEL (TAX (label)));
281 LOCALE (&z) = NO_HANDLE;
282 MOID (&z) = M_PROC_VOID;
283 PUSH_PROCEDURE (p, z);
284 }
285
286 //! @brief (optimised) dereference value of a unit
287
288 PROP_T genie_dereferencing_quick (NODE_T * p)
289 {
290 BYTE_T *tos = STACK_TOP;
291 A68_REF *z = (A68_REF *) tos;
292 ADDR_T pop_sp = A68_SP;
293 GENIE_UNIT (SUB (p));
294 A68_SP = pop_sp;
295 CHECK_REF (p, *z, MOID (SUB (p)));
296 PUSH (p, ADDRESS (z), SIZE (MOID (p)));
297 genie_check_initialisation (p, tos, MOID (p));
298 return GPROP (p);
299 }
300
301 //! @brief Dereference an identifier.
302
303 PROP_T genie_dereference_frame_identifier (NODE_T * p)
304 {
305 MOID_T *deref = SUB_MOID (p);
306 BYTE_T *tos = STACK_TOP;
307 A68_REF *z;
308 FRAME_GET (z, A68_REF, p);
309 PUSH (p, ADDRESS (z), SIZE (deref));
310 genie_check_initialisation (p, tos, deref);
311 return GPROP (p);
312 }
313
314 //! @brief Dereference an identifier.
315
316 PROP_T genie_dereference_generic_identifier (NODE_T * p)
317 {
318 MOID_T *deref = SUB_MOID (p);
319 BYTE_T *tos = STACK_TOP;
320 A68_REF *z;
321 FRAME_GET (z, A68_REF, p);
322 CHECK_REF (p, *z, MOID (SUB (p)));
323 PUSH (p, ADDRESS (z), SIZE (deref));
324 genie_check_initialisation (p, tos, deref);
325 return GPROP (p);
326 }
327
328 //! @brief Slice REF [] A to A.
329
330 PROP_T genie_dereference_slice_name_quick (NODE_T * p)
331 {
332 MOID_T *ref_m = MOID (p); MOID_T *deref_m = SUB (ref_m);
333 ADDR_T pop_sp = A68_SP;
334 // Get REF [] and [].
335 BYTE_T *tos = STACK_TOP;
336 A68_REF *z = (A68_REF *) tos;
337 GENIE_UNIT (SUB (p));
338 CHECK_REF (p, *z, ref_m);
339 A68_ARRAY *arr; A68_TUPLE *tup;
340 GET_DESCRIPTOR (arr, tup, DEREF (A68_ROW, z));
341 // Compute index.
342 A68_SP = pop_sp;
343 int index = 0;
344 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
345 A68_INT *j = (A68_INT *) STACK_TOP;
346 GENIE_UNIT (q);
347 int k = VALUE (j);
348 if (k < LWB (tup) || k > UPB (tup)) {
349 diagnostic (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS);
350 exit_genie (q, A68_RUNTIME_ERROR);
351 }
352 index += (SPAN (tup) * k - SHIFT (tup));
353 tup++;
354 A68_SP = pop_sp;
355 }
356 // Push element.
357 PUSH (p, &((ADDRESS (&(ARRAY (arr))))[ROW_ELEMENT (arr, index)]), SIZE (deref_m));
358 genie_check_initialisation (p, tos, deref_m);
359 return GPROP (p);
360 }
361
362 //! @brief Dereference SELECTION from a name.
363
364 PROP_T genie_dereference_selection_name_quick (NODE_T * p)
365 {
366 NODE_T *selector = SUB (p);
367 MOID_T *struct_m = MOID (NEXT (selector));
368 MOID_T *result_m = SUB_MOID (selector);
369 BYTE_T *tos = STACK_TOP;
370 A68_REF *z = (A68_REF *) tos;
371 ADDR_T pop_sp = A68_SP;
372 GENIE_UNIT (NEXT (selector));
373 CHECK_REF (selector, *z, struct_m);
374 OFFSET (z) += OFFSET (NODE_PACK (SUB (selector)));
375 A68_SP = pop_sp;
376 PUSH (p, ADDRESS (z), SIZE (result_m));
377 genie_check_initialisation (p, tos, result_m);
378 return GPROP (p);
379 }
380
381 //! @brief Dereference name in the stack.
382
383 PROP_T genie_dereferencing (NODE_T * p)
384 {
385 PROP_T self;
386 GENIE_UNIT_2 (SUB (p), self);
387 A68_REF z;
388 POP_REF (p, &z);
389 CHECK_REF (p, z, MOID (SUB (p)));
390 PUSH (p, ADDRESS (&z), SIZE (MOID (p)));
391 genie_check_initialisation (p, STACK_OFFSET (-SIZE (MOID (p))), MOID (p));
392 if (UNIT (&self) == genie_frame_identifier) {
393 if (IS_IN_FRAME (&z)) {
394 UNIT (&self) = genie_dereference_frame_identifier;
395 } else {
396 UNIT (&self) = genie_dereference_generic_identifier;
397 }
398 UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self);
399 } else if (UNIT (&self) == genie_slice_name_quick) {
400 UNIT (&self) = genie_dereference_slice_name_quick;
401 UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self);
402 } else if (UNIT (&self) == genie_selection_name_quick) {
403 UNIT (&self) = genie_dereference_selection_name_quick;
404 UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self);
405 } else {
406 UNIT (&self) = genie_dereferencing_quick;
407 SOURCE (&self) = p;
408 }
409 return self;
410 }
411
412 //! @brief Deprocedure PROC in the stack.
413
414 PROP_T genie_deproceduring (NODE_T * p)
415 {
416 NODE_T *proc = SUB (p);
417 MOID_T *proc_m = MOID (proc);
418 PROP_T self;
419 UNIT (&self) = genie_deproceduring;
420 SOURCE (&self) = p;
421 // Get procedure.
422 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
423 A68_PROCEDURE *z = (A68_PROCEDURE *) STACK_TOP;
424 GENIE_UNIT (proc);
425 A68_SP = pop_sp;
426 genie_check_initialisation (p, (BYTE_T *) z, proc_m);
427 genie_call_procedure (p, proc_m, proc_m, M_VOID, z, pop_sp, pop_fp);
428 STACK_DNS (p, MOID (p), A68_FP);
429 return self;
430 }
431
432 //! @brief Voiden value in the stack.
433
434 PROP_T genie_voiding (NODE_T * p)
435 {
436 PROP_T self, source;
437 ADDR_T sp_for_voiding = A68_SP;
438 SOURCE (&self) = p;
439 GENIE_UNIT_2 (SUB (p), source);
440 A68_SP = sp_for_voiding;
441 if (UNIT (&source) == genie_assignation_quick) {
442 UNIT (&self) = genie_voiding_assignation;
443 SOURCE (&self) = SOURCE (&source);
444 } else if (UNIT (&source) == genie_assignation_constant) {
445 UNIT (&self) = genie_voiding_assignation_constant;
446 SOURCE (&self) = SOURCE (&source);
447 } else {
448 UNIT (&self) = genie_voiding;
449 }
450 return self;
451 }
452
453 //! @brief Coerce value in the stack.
454
455 PROP_T genie_coercion (NODE_T * p)
456 {
457 PROP_T self;
458 UNIT (&self) = genie_coercion;
459 SOURCE (&self) = p;
460 switch (ATTRIBUTE (p)) {
461 case VOIDING: {
462 self = genie_voiding (p);
463 break;
464 }
465 case UNITING: {
466 self = genie_uniting (p);
467 break;
468 }
469 case WIDENING: {
470 self = genie_widen (p);
471 break;
472 }
473 case ROWING: {
474 self = genie_rowing (p);
475 break;
476 }
477 case DEREFERENCING: {
478 self = genie_dereferencing (p);
479 break;
480 }
481 case DEPROCEDURING: {
482 self = genie_deproceduring (p);
483 break;
484 }
485 case PROCEDURING: {
486 genie_proceduring (p);
487 break;
488 }
489 }
490 GPROP (p) = self;
491 return self;
492 }
