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