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