a68g-genie.h
1 //! @file a68g-genie.h
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 related definitions.
25
26 #if !defined (__A68G_GENIE_H__)
27 #define __A68G_GENIE_H__
28
29 //! @brief PROC VOID gc heap
30
31 // Prelude errors can also occur in the constant folder
32
33 #define CHECK_INT_SHORTEN(p, i)\
34 PRELUDE_ERROR (((i) > INT_MAX || (i) < -INT_MAX), p, ERROR_MATH, M_INT)
35
36 #define CHECK_INT_ADDITION(p, i, j)\
37 PRELUDE_ERROR (\
38 ((j) > 0 && (i) > (A68_MAX_INT - (j))) || ((j) < 0 && (i) < (-A68_MAX_INT - (j))),\
39 p, "M overflow", M_INT)
40
41 #define CHECK_INT_MULTIPLICATION(p, i, j)\
42 PRELUDE_ERROR (\
43 (j) != 0 && ABS (i) > A68_MAX_INT / ABS (j),\
44 p, "M overflow", M_INT)
45
46 #define CHECK_BITS_ADDITION(p, i, j)\
47 if (!MODULAR_MATH (p)) {\
48 PRELUDE_ERROR (((i) > (A68_MAX_BITS - (j))), p, ERROR_MATH, M_BITS);\
49 }
50
51 #define CHECK_BITS_SUBTRACTION(p, i, j)\
52 if (!MODULAR_MATH (p)) {\
53 PRELUDE_ERROR (((j) > (i)), p, ERROR_MATH, M_BITS);\
54 }
55
56 #define CHECK_BITS_MULTIPLICATION(p, i, j)\
57 if (!MODULAR_MATH (p)) {\
58 PRELUDE_ERROR ((j) != 0 && (i) > A68_MAX_BITS / (j), p, ERROR_MATH, M_BITS);\
59 }
60
61 #define CHECK_INT_DIVISION(p, i, j)\
62 PRELUDE_ERROR ((j) == 0, p, ERROR_DIVISION_BY_ZERO, M_INT)
63
64 #define PRELUDE_ERROR(cond, p, txt, add)\
65 if (cond) {\
66 if (A68 (in_execution)) {\
67 diagnostic (A68_RUNTIME_ERROR, p, txt, add);\
68 exit_genie (p, A68_RUNTIME_ERROR);\
69 } else {\
70 diagnostic (A68_MATH_ERROR, p, txt, add);\
71 }}
72
73 // Check on a NIL name
74
75 #define CHECK_REF(p, z, m)\
76 if (! INITIALISED (&z)) {\
77 diagnostic (A68_RUNTIME_ERROR, (p), ERROR_EMPTY_VALUE_FROM, (m));\
78 exit_genie ((p), A68_RUNTIME_ERROR);\
79 } else if (IS_NIL (z)) {\
80 diagnostic (A68_RUNTIME_ERROR, (p), ERROR_ACCESSING_NIL, (m));\
81 exit_genie ((p), A68_RUNTIME_ERROR);\
82 }
83
84 // Macros for row-handling
85
86 // An A68G row is a reference to a descriptor in the heap:
87 // A68_REF row -> A68_ARRAY ----+ ARRAY: Description of row, ref to elements.
88 // A68_TUPLE 1 | TUPLE: Bounds, one for every dimension.
89 // ... |
90 // A68_TUPLE dim |
91 // ... |
92 // ... |
93 // Element 1 <---+ Sequential row elements in the heap.
94 // ...
95 // Element n
96
97 #define DESCRIPTOR_SIZE(n) (SIZE_ALIGNED (A68_ARRAY) + (n) * SIZE_ALIGNED (A68_TUPLE))
98
99 #define NEW_ROW_1D(des, row, arr, tup, row_m, mod, upb)\
100 (des) = heap_generator (p, (row_m), DESCRIPTOR_SIZE (1));\
101 (row) = heap_generator (p, (row_m), (upb) * SIZE (mod));\
102 DIM (&(arr)) = 1;\
103 MOID (&(arr)) = (mod);\
104 ELEM_SIZE (&(arr)) = SIZE (mod);\
105 SLICE_OFFSET (&(arr)) = 0;\
106 FIELD_OFFSET (&(arr)) = 0;\
107 ARRAY (&(arr)) = (row);\
108 LWB (&(tup)) = 1;\
109 UPB (&(tup)) = (upb);\
110 SHIFT (&(tup)) = LWB (&(tup));\
111 SPAN (&(tup)) = 1;\
112 K (&(tup)) = 0;\
113 PUT_DESCRIPTOR ((arr), (tup), &(des));
114
115 #define GET_DESCRIPTOR(arr, tup, p)\
116 arr = (A68_ARRAY *) ARRAY_ADDRESS (p);\
117 tup = (A68_TUPLE *) & (((BYTE_T *) (arr)) [SIZE_ALIGNED (A68_ARRAY)]);
118
119 #define GET_DESCRIPTOR2(arr, tup1, tup2, p)\
120 arr = (A68_ARRAY *) ARRAY_ADDRESS (p);\
121 tup1 = (A68_TUPLE *) & (((BYTE_T *) (arr)) [SIZE_ALIGNED (A68_ARRAY)]);\
122 tup2 = (A68_TUPLE *) & (((BYTE_T *) (arr)) [SIZE_ALIGNED (A68_ARRAY) + sizeof (A68_TUPLE)]);
123
124 #define PUT_DESCRIPTOR(arr, tup, p) {\
125 BYTE_T *a_p = ARRAY_ADDRESS (p);\
126 *(A68_ARRAY *) a_p = (arr);\
127 *(A68_TUPLE *) &(((BYTE_T *) (a_p)) [SIZE_ALIGNED (A68_ARRAY)]) = (tup);\
128 }
129
130 #define PUT_DESCRIPTOR2(arr, tup1, tup2, p) {\
131 BYTE_T *a_p = ARRAY_ADDRESS (p);\
132 *(A68_ARRAY *) a_p = (arr);\
133 *(A68_TUPLE *) &(((BYTE_T *) (a_p)) [SIZE_ALIGNED (A68_ARRAY)]) = (tup1);\
134 *(A68_TUPLE *) &(((BYTE_T *) (a_p)) [SIZE_ALIGNED (A68_ARRAY) + sizeof (A68_TUPLE)]) = (tup2);\
135 }
136
137 #define ROW_SIZE(tup) ((LWB (tup) <= UPB (tup)) ? (UPB (tup) - LWB (tup) + 1) : 0)
138 #define ROW_ELEMENT(arr, k) (((ADDR_T) k + SLICE_OFFSET (arr)) * ELEM_SIZE (arr) + FIELD_OFFSET (arr))
139 #define INDEX_1_DIM(arr, tup, k) ROW_ELEMENT (arr, (SPAN (tup) * (int) (k) - SHIFT (tup)))
140
141 #define VECTOR_OFFSET(arr, tup)\
142 ((LWB (tup) * SPAN (tup) - SHIFT (tup) + SLICE_OFFSET (arr)) * ELEM_SIZE (arr) + FIELD_OFFSET (arr))
143
144 #define MATRIX_OFFSET(arr, tup1, tup2)\
145 ((LWB (tup1) * SPAN (tup1) - SHIFT (tup1) + LWB (tup2) * SPAN (tup2) - SHIFT (tup2) + SLICE_OFFSET (arr)) * ELEM_SIZE (arr) + FIELD_OFFSET (arr))
146
147 // Execution
148
149 #define GENIE_UNIT_2(p, dest) {\
150 PROP_T *_prop_ = &GPROP (p);\
151 dest = (*(UNIT (_prop_))) (SOURCE (_prop_));}
152
153 #define GENIE_UNIT_NO_GC_2(p, dest) {\
154 A68_GC (sema) ++;\
155 GENIE_UNIT_2 ((p), (dest));\
156 A68_GC (sema) --;}
157
158 #define GENIE_UNIT(p) {\
159 PROP_T *_prop_ = &GPROP (p);\
160 (void) (*(UNIT (_prop_))) (SOURCE (_prop_));}
161
162 #define GENIE_UNIT_NO_GC(p) {\
163 A68_GC (sema) ++;\
164 GENIE_UNIT ((p));\
165 A68_GC (sema) --;}
166
167 #define GENIE_UNIT_TRACE(p) {\
168 if (STATUS_TEST (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK | \
169 BREAKPOINT_INTERRUPT_MASK | BREAKPOINT_WATCH_MASK | BREAKPOINT_TRACE_MASK))) {\
170 single_step ((p), STATUS (p));\
171 }\
172 GENIE_UNIT (p);}
173
174 // Stuff for the garbage collector
175
176 // Check whether the heap fills
177
178 #define DEFAULT_PREEMPTIVE 0.8
179
180 // Save a handle from the GC
181
182 #define BLOCK_GC_HANDLE(z) {\
183 if (IS_IN_HEAP (z)) {\
184 STATUS_SET (REF_HANDLE(z), BLOCK_GC_MASK);\
185 }}
186
187 #define UNBLOCK_GC_HANDLE(z) {\
188 if (IS_IN_HEAP (z)) {\
189 STATUS_CLEAR (REF_HANDLE (z), BLOCK_GC_MASK);\
190 }}
191
192 // Tests for objects of mode INT
193
194 #define CHECK_INDEX(p, k, t) {\
195 if (VALUE (k) < LWB (t) || VALUE (k) > UPB (t)) {\
196 diagnostic (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);\
197 exit_genie (p, A68_RUNTIME_ERROR);\
198 }}
199
200 // Tests for objects of mode REAL
201
202 #if defined (HAVE_IEEE_754)
203 #define CHECK_REAL(p, u) PRELUDE_ERROR (!a68_finite_real (u), p, ERROR_INFINITE, M_REAL)
204 #define CHECK_COMPLEX(p, u, v) PRELUDE_ERROR (!a68_finite_real (u) || !a68_finite_real (v), p, ERROR_INFINITE, M_COMPLEX)
205 #else
206 #define CHECK_REAL(p, u) {;}
207 #define CHECK_COMPLEX(p, u, v) {;}
208 #endif
209
210 #define MATH_RTE(p, z, m, t) PRELUDE_ERROR (z, (p), (t == NO_TEXT ? ERROR_MATH : t), (m))
211
212 // Macros.
213
214 #define C_FUNCTION(p, f)\
215 A68_REAL *x;\
216 POP_OPERAND_ADDRESS (p, x, A68_REAL);\
217 errno = 0;\
218 VALUE (x) = f (VALUE (x));\
219 MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);
220
221 #define OWN_FUNCTION(p, f)\
222 A68_REAL *x;\
223 POP_OPERAND_ADDRESS (p, x, A68_REAL);\
224 errno = 0;\
225 VALUE (x) = f (p, VALUE (x));\
226 MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);
227
228 // Macros for standard environ
229
230 #define A68_ENV_INT(n, k) void n (NODE_T *p) {PUSH_PRIMAL (p, (k), INT);}
231 #define A68_ENV_REAL(n, z) void n (NODE_T *p) {PUSH_PRIMAL (p, (z), REAL);}
232
233 // Macros for the evaluation stack
234
235 #define INCREMENT_STACK_POINTER(err, i)\
236 {A68_SP += (ADDR_T) A68_ALIGN (i); (void) (err);}
237
238 #define DECREMENT_STACK_POINTER(err, i)\
239 {A68_SP -= A68_ALIGN (i); (void) (err);}
240
241 #define PUSH(p, addr, size) {\
242 BYTE_T *_sp_ = STACK_TOP;\
243 INCREMENT_STACK_POINTER ((p), (int) (size));\
244 COPY (_sp_, (BYTE_T *) (addr), (int) (size));\
245 }
246
247 #define POP(p, addr, size) {\
248 DECREMENT_STACK_POINTER((p), (int) (size));\
249 COPY ((BYTE_T *) (addr), STACK_TOP, (int) (size));\
250 }
251
252 #define POP_ALIGNED(p, addr, size) {\
253 DECREMENT_STACK_POINTER((p), (int) (size));\
254 COPY_ALIGNED ((BYTE_T *) (addr), STACK_TOP, (int) (size));\
255 }
256
257 #define POP_ADDRESS(p, addr, type) {\
258 DECREMENT_STACK_POINTER((p), (int) SIZE_ALIGNED (type));\
259 (addr) = (type *) STACK_TOP;\
260 }
261
262 #define POP_OPERAND_ADDRESS(p, i, type) {\
263 (void) (p);\
264 (i) = (type *) (STACK_OFFSET (-SIZE_ALIGNED (type)));\
265 }
266
267 #define POP_OPERAND_ADDRESSES(p, i, j, type) {\
268 DECREMENT_STACK_POINTER ((p), (int) SIZE_ALIGNED (type));\
269 (j) = (type *) STACK_TOP;\
270 (i) = (type *) (STACK_OFFSET (-SIZE_ALIGNED (type)));\
271 }
272
273 #define POP_3_OPERAND_ADDRESSES(p, i, j, k, type) {\
274 DECREMENT_STACK_POINTER ((p), (int) (2 * SIZE_ALIGNED (type)));\
275 (k) = (type *) (STACK_OFFSET (SIZE_ALIGNED (type)));\
276 (j) = (type *) STACK_TOP;\
277 (i) = (type *) (STACK_OFFSET (-SIZE_ALIGNED (type)));\
278 }
279
280 #define PUSH_VALUE(p, z, mode) {\
281 mode *_x_ = (mode *) STACK_TOP;\
282 STATUS (_x_) = INIT_MASK;\
283 VALUE (_x_) = (z);\
284 INCREMENT_STACK_POINTER ((p), SIZE_ALIGNED (mode));\
285 }
286
287 #define PUSH_PRIMAL(p, z, m) {\
288 A68_##m *_x_ = (A68_##m *) STACK_TOP;\
289 int _size_ = SIZE_ALIGNED (A68_##m);\
290 STATUS (_x_) = INIT_MASK;\
291 VALUE (_x_) = (z);\
292 INCREMENT_STACK_POINTER ((p), _size_);\
293 }
294
295 #define PUSH_OBJECT(p, z, mode) {\
296 *(mode *) STACK_TOP = (z);\
297 INCREMENT_STACK_POINTER (p, SIZE_ALIGNED (mode));\
298 }
299
300 #define POP_OBJECT(p, z, mode) {\
301 DECREMENT_STACK_POINTER((p), SIZE_ALIGNED (mode));\
302 (*(z)) = *((mode *) STACK_TOP);\
303 }
304
305 #define PUSH_COMPLEX(p, re, im) {\
306 PUSH_PRIMAL (p, re, REAL);\
307 PUSH_PRIMAL (p, im, REAL);\
308 }
309
310 #define POP_COMPLEX(p, re, im) {\
311 POP_OBJECT (p, im, A68_REAL);\
312 POP_OBJECT (p, re, A68_REAL);\
313 }
314
315 #define PUSH_BYTES(p, k) {\
316 A68_BYTES *_z_ = (A68_BYTES *) STACK_TOP;\
317 STATUS (_z_) = INIT_MASK;\
318 MOVE (VALUE (_z_), k, A68_BYTES_WIDTH);\
319 INCREMENT_STACK_POINTER((p), SIZE_ALIGNED (A68_BYTES));\
320 }
321
322 #define PUSH_LONG_BYTES(p, k) {\
323 A68_LONG_BYTES *_z_ = (A68_LONG_BYTES *) STACK_TOP;\
324 STATUS (_z_) = INIT_MASK;\
325 MOVE (VALUE (_z_), k, A68_LONG_BYTES_WIDTH);\
326 INCREMENT_STACK_POINTER((p), SIZE_ALIGNED (A68_LONG_BYTES));\
327 }
328
329 #define PUSH_REF(p, z) PUSH_OBJECT (p, z, A68_REF)
330 #define PUSH_PROCEDURE(p, z) PUSH_OBJECT (p, z, A68_PROCEDURE)
331 #define PUSH_FORMAT(p, z) PUSH_OBJECT (p, z, A68_FORMAT)
332
333 #define POP_REF(p, z) POP_OBJECT (p, z, A68_REF)
334 #define POP_PROCEDURE(p, z) POP_OBJECT (p, z, A68_PROCEDURE)
335
336 #define PUSH_UNION(p, z) {\
337 A68_UNION *_x_ = (A68_UNION *) STACK_TOP;\
338 STATUS (_x_) = INIT_MASK;\
339 VALUE (_x_) = (z);\
340 INCREMENT_STACK_POINTER ((p), SIZE_ALIGNED (A68_UNION));\
341 }
342
343 // Interpreter macros
344
345 #define INITIALISED(z) ((BOOL_T) (STATUS (z) & INIT_MASK))
346 #define MODULAR_MATH(z) ((BOOL_T) (STATUS (z) & MODULAR_MASK))
347 #define LHS_MODE(p) (MOID (PACK (MOID (p))))
348 #define RHS_MODE(p) (MOID (NEXT (PACK (MOID (p)))))
349
350 // Transput related macros
351
352 #define IS_NIL_FORMAT(f) ((BOOL_T) (BODY (f) == NO_NODE && ENVIRON (f) == 0))
353
354 // Macros for check on initialisation of values
355
356 #define CHECK_INIT(p, c, q)\
357 if (!(c)) {\
358 diagnostic (A68_RUNTIME_ERROR, (p), ERROR_EMPTY_VALUE_FROM, (q));\
359 exit_genie ((p), A68_RUNTIME_ERROR);\
360 }
361
362 #define CHECK_DNS2(p, scope, limit, mode)\
363 if (scope > limit) {\
364 BUFFER txt;\
365 ASSERT (a68_bufprt (txt, SNPRINTF_SIZE, ERROR_SCOPE_DYNAMIC_1) >= 0);\
366 diagnostic (A68_RUNTIME_ERROR, p, txt, mode);\
367 exit_genie (p, A68_RUNTIME_ERROR);\
368 }
369
370 #define CHECK_DNS(p, m, w, limit)\
371 if (NEED_DNS (GINFO (p))) {\
372 ADDR_T _lim = ((limit) < A68_GLOBALS ? A68_GLOBALS : (limit));\
373 if (IS ((m), REF_SYMBOL)) {\
374 CHECK_DNS2 (p, (REF_SCOPE ((A68_REF *) (w))), _lim, (m));\
375 } else if (IS ((m), PROC_SYMBOL)) {\
376 CHECK_DNS2 (p, ENVIRON ((A68_PROCEDURE *) (w)), _lim, (m));\
377 } else if (IS ((m), FORMAT_SYMBOL)) {\
378 CHECK_DNS2 (p, ENVIRON ((A68_FORMAT *) w), _lim, (m));\
379 }}
380
381 //
382 // The void * cast in next macro is to stop warnings about dropping a volatile
383 // qualifier to a pointer. This is safe here.
384
385 #define STACK_DNS(p, m, limit)\
386 if (p != NO_NODE && GINFO (p) != NO_GINFO) {\
387 CHECK_DNS ((NODE_T *)(void *)(p), (m),\
388 (STACK_OFFSET (-SIZE (m))), (limit));\
389 }
390
391 // Genie routines.
392
393 PROP_T genie_column_function (NODE_T *);
394 PROP_T genie_diagonal_function (NODE_T *);
395 PROP_T genie_row_function (NODE_T *);
396 PROP_T genie_transpose_function (NODE_T *);
397 PROP_T genie_and_function (NODE_T *);
398 PROP_T genie_assertion (NODE_T *);
399 PROP_T genie_assignation_constant (NODE_T *);
400 PROP_T genie_assignation (NODE_T *);
401 PROP_T genie_assignation_quick (NODE_T * p);
402 PROP_T genie_call (NODE_T *);
403 PROP_T genie_cast (NODE_T *);
404 PROP_T genie_closed (volatile NODE_T *);
405 PROP_T genie_coercion (NODE_T *);
406 PROP_T genie_collateral (NODE_T *);
407 PROP_T genie_conditional (volatile NODE_T *);
408 PROP_T genie_constant (NODE_T *);
409 PROP_T genie_denotation (NODE_T *);
410 PROP_T genie_deproceduring (NODE_T *);
411 PROP_T genie_dereference_frame_identifier (NODE_T *);
412 PROP_T genie_dereference_generic_identifier (NODE_T *);
413 PROP_T genie_dereference_selection_name_quick (NODE_T *);
414 PROP_T genie_dereference_slice_name_quick (NODE_T *);
415 PROP_T genie_dereferencing (NODE_T *);
416 PROP_T genie_dereferencing_quick (NODE_T *);
417 PROP_T genie_dyadic (NODE_T *);
418 PROP_T genie_dyadic_quick (NODE_T *);
419 PROP_T genie_enclosed (volatile NODE_T *);
420 PROP_T genie_field_selection (NODE_T *);
421 PROP_T genie_format_text (NODE_T *);
422 PROP_T genie_formula (NODE_T *);
423 PROP_T genie_frame_identifier (NODE_T *);
424 PROP_T genie_identifier (NODE_T *);
425 PROP_T genie_identifier_standenv (NODE_T *);
426 PROP_T genie_identifier_standenv_proc (NODE_T *);
427 PROP_T genie_identity_relation (NODE_T *);
428 PROP_T genie_int_case (volatile NODE_T *);
429 PROP_T genie_loop (volatile NODE_T *);
430 PROP_T genie_loop (volatile NODE_T *);
431 PROP_T genie_monadic (NODE_T *);
432 PROP_T genie_nihil (NODE_T *);
433 PROP_T genie_or_function (NODE_T *);
434 PROP_T genie_routine_text (NODE_T *);
435 PROP_T genie_rowing (NODE_T *);
436 PROP_T genie_rowing_ref_row_of_row (NODE_T *);
437 PROP_T genie_rowing_ref_row_row (NODE_T *);
438 PROP_T genie_rowing_row_of_row (NODE_T *);
439 PROP_T genie_rowing_row_row (NODE_T *);
440 PROP_T genie_selection_name_quick (NODE_T *);
441 PROP_T genie_selection (NODE_T *);
442 PROP_T genie_selection_value_quick (NODE_T *);
443 PROP_T genie_skip (NODE_T *);
444 PROP_T genie_slice_name_quick (NODE_T *);
445 PROP_T genie_slice (NODE_T *);
446 PROP_T genie_united_case (volatile NODE_T *);
447 PROP_T genie_uniting (NODE_T *);
448 PROP_T genie_unit (NODE_T *);
449 PROP_T genie_voiding_assignation_constant (NODE_T *);
450 PROP_T genie_voiding_assignation (NODE_T *);
451 PROP_T genie_voiding (NODE_T *);
452 PROP_T genie_widen_int_to_real (NODE_T *);
453 PROP_T genie_widen (NODE_T *);
454
455 A68_REF genie_clone (NODE_T *, MOID_T *, A68_REF *, A68_REF *);
456 A68_REF genie_make_ref_row_of_row (NODE_T *, MOID_T *, MOID_T *, ADDR_T);
457 A68_REF genie_make_ref_row_row (NODE_T *, MOID_T *, MOID_T *, ADDR_T);
458 A68_REF genie_make_rowrow (NODE_T *, MOID_T *, int, ADDR_T);
459
460 void genie (void *);
461 void genie_clone_stack (NODE_T *, MOID_T *, A68_REF *, A68_REF *);
462 void genie_serial_units_no_label (NODE_T *, ADDR_T, NODE_T **);
463 void genie_jump (NODE_T *);
464
465 #endif
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
