genie.c
1 //! @file genie.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-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 driver.
25
26 // This file contains interpreter ("genie") routines related to executing primitive
27 // A68 actions.
28 //
29 // The genie is self-optimising as when it traverses the tree, it stores terminals
30 // it ends up in at the root where traversing for that terminal started.
31 // Such piece of information is called a PROP.
32
33 #include "a68g.h"
34 #include "a68g-genie.h"
35 #include "a68g-frames.h"
36 #include "a68g-prelude.h"
37 #include "a68g-mp.h"
38 #include "a68g-parser.h"
39 #include "a68g-transput.h"
40
41 //! @brief Set flags throughout tree.
42
43 void change_masks (NODE_T * p, unt mask, BOOL_T set)
44 {
45 for (; p != NO_NODE; FORWARD (p)) {
46 change_masks (SUB (p), mask, set);
47 if (LINE_NUMBER (p) > 0) {
48 if (set == A68G_TRUE) {
49 STATUS_SET (p, mask);
50 } else {
51 STATUS_CLEAR (p, mask);
52 }
53 }
54 }
55 }
56
57 //! @brief Set flags throughout tree.
58
59 void change_gc_masks (NODE_T * p, BOOL_T set)
60 {
61 for (; p != NO_NODE; FORWARD (p)) {
62 switch (ATTRIBUTE (p)) {
63 case CALL: {
64 change_gc_masks (SUB (p), A68G_TRUE);
65 break;
66 }
67 case SLICE: {
68 change_gc_masks (SUB (p), A68G_TRUE);
69 break;
70 }
71 default: {
72 change_gc_masks (SUB (p), set);
73 break;
74 }
75 }
76 if (LINE_NUMBER (p) > 0) {
77 if (set == A68G_TRUE) {
78 STATUS_SET (p, BLOCK_GC_MASK);
79 } else {
80 STATUS_CLEAR (p, BLOCK_GC_MASK);
81 }
82 }
83 }
84 }
85
86 //! @brief Leave interpretation.
87
88 void exit_genie (NODE_T * p, int ret)
89 {
90 #if defined (HAVE_CURSES)
91 genie_curses_end (p);
92 #endif
93 A68G (close_tty_on_exit) = A68G_TRUE;
94 if (!A68G (in_execution)) {
95 return;
96 }
97 if (ret == A68G_RUNTIME_ERROR && A68G (in_monitor)) {
98 return;
99 } else if (ret == A68G_RUNTIME_ERROR && OPTION_DEBUG (&A68G_JOB)) {
100 diagnostics_to_terminal (TOP_LINE (&A68G_JOB), A68G_RUNTIME_ERROR);
101 single_step (p, (unt) BREAKPOINT_ERROR_MASK);
102 A68G (in_execution) = A68G_FALSE;
103 A68G (ret_line_number) = LINE_NUMBER (p);
104 A68G (ret_code) = ret;
105 longjmp (A68G (genie_exit_label), 1);
106 } else {
107 if ((ret & A68G_FORCE_QUIT) != NULL_MASK) {
108 ret &= ~A68G_FORCE_QUIT;
109 }
110 #if defined (BUILD_PARALLEL_CLAUSE)
111 if (!is_main_thread ()) {
112 genie_set_exit_from_threads (ret);
113 } else {
114 A68G (in_execution) = A68G_FALSE;
115 A68G (ret_line_number) = LINE_NUMBER (p);
116 A68G (ret_code) = ret;
117 longjmp (A68G (genie_exit_label), 1);
118 }
119 #else
120 A68G (in_execution) = A68G_FALSE;
121 A68G (ret_line_number) = LINE_NUMBER (p);
122 A68G (ret_code) = ret;
123 longjmp (A68G (genie_exit_label), 1);
124 #endif
125 }
126 }
127
128 //! @brief Genie init rng.
129
130 void genie_init_rng (void)
131 {
132 time_t t;
133 if (time (&t) != -1) {
134 init_rng ((unt) t);
135 }
136 }
137
138 //! @brief Tie label to the clause it is defined in.
139
140 void tie_label_to_serial (NODE_T * p)
141 {
142 for (; p != NO_NODE; FORWARD (p)) {
143 if (IS (p, SERIAL_CLAUSE)) {
144 BOOL_T valid_follow;
145 if (NEXT (p) == NO_NODE) {
146 valid_follow = A68G_TRUE;
147 } else if (IS (NEXT (p), CLOSE_SYMBOL)) {
148 valid_follow = A68G_TRUE;
149 } else if (IS (NEXT (p), END_SYMBOL)) {
150 valid_follow = A68G_TRUE;
151 } else if (IS (NEXT (p), EDOC_SYMBOL)) {
152 valid_follow = A68G_TRUE;
153 } else if (IS (NEXT (p), OD_SYMBOL)) {
154 valid_follow = A68G_TRUE;
155 } else {
156 valid_follow = A68G_FALSE;
157 }
158 if (valid_follow) {
159 JUMP_TO (TABLE (SUB (p))) = NO_NODE;
160 }
161 }
162 tie_label_to_serial (SUB (p));
163 }
164 }
165
166 //! @brief Tie label to the clause it is defined in.
167
168 void tie_label (NODE_T * p, NODE_T * unit)
169 {
170 for (; p != NO_NODE; FORWARD (p)) {
171 if (IS (p, DEFINING_IDENTIFIER)) {
172 UNIT (TAX (p)) = unit;
173 }
174 tie_label (SUB (p), unit);
175 }
176 }
177
178 //! @brief Tie label to the clause it is defined in.
179
180 void tie_label_to_unit (NODE_T * p)
181 {
182 for (; p != NO_NODE; FORWARD (p)) {
183 if (IS (p, LABELED_UNIT)) {
184 tie_label (SUB_SUB (p), NEXT_SUB (p));
185 }
186 tie_label_to_unit (SUB (p));
187 }
188 }
189
190 //! @brief Fast way to indicate a mode.
191
192 int mode_attribute (MOID_T * p)
193 {
194 if (IS_REF (p)) {
195 return REF_SYMBOL;
196 } else if (IS (p, PROC_SYMBOL)) {
197 return PROC_SYMBOL;
198 } else if (IS_UNION (p)) {
199 return UNION_SYMBOL;
200 } else if (p == M_INT) {
201 return MODE_INT;
202 } else if (p == M_LONG_INT) {
203 return MODE_LONG_INT;
204 } else if (p == M_LONG_LONG_INT) {
205 return MODE_LONG_LONG_INT;
206 } else if (p == M_REAL) {
207 return MODE_REAL;
208 } else if (p == M_LONG_REAL) {
209 return MODE_LONG_REAL;
210 } else if (p == M_LONG_LONG_REAL) {
211 return MODE_LONG_LONG_REAL;
212 } else if (p == M_COMPLEX) {
213 return MODE_COMPLEX;
214 } else if (p == M_LONG_COMPLEX) {
215 return MODE_LONG_COMPLEX;
216 } else if (p == M_LONG_LONG_COMPLEX) {
217 return MODE_LONG_LONG_COMPLEX;
218 } else if (p == M_BOOL) {
219 return MODE_BOOL;
220 } else if (p == M_CHAR) {
221 return MODE_CHAR;
222 } else if (p == M_BITS) {
223 return MODE_BITS;
224 } else if (p == M_LONG_BITS) {
225 return MODE_LONG_BITS;
226 } else if (p == M_LONG_LONG_BITS) {
227 return MODE_LONG_LONG_BITS;
228 } else if (p == M_BYTES) {
229 return MODE_BYTES;
230 } else if (p == M_LONG_BYTES) {
231 return MODE_LONG_BYTES;
232 } else if (p == M_FILE) {
233 return MODE_FILE;
234 } else if (p == M_FORMAT) {
235 return MODE_FORMAT;
236 } else if (p == M_PIPE) {
237 return MODE_PIPE;
238 } else if (p == M_SOUND) {
239 return MODE_SOUND;
240 } else {
241 return MODE_NO_CHECK;
242 }
243 }
244
245 //! @brief Perform tasks before interpretation.
246
247 void genie_preprocess (NODE_T * p, int *max_lev, void *compile_plugin)
248 {
249 #if defined (BUILD_A68G_COMPILER)
250 static char *last_compile_name = NO_TEXT;
251 static PROP_PROC *last_compile_unit = NO_PPROC;
252 #endif
253 for (; p != NO_NODE; FORWARD (p)) {
254 if (STATUS_TEST (p, BREAKPOINT_MASK)) {
255 if (!(STATUS_TEST (p, INTERRUPTIBLE_MASK))) {
256 STATUS_CLEAR (p, BREAKPOINT_MASK);
257 }
258 }
259 if (GINFO (p) != NO_GINFO) {
260 IS_COERCION (GINFO (p)) = is_coercion (p);
261 IS_NEW_LEXICAL_LEVEL (GINFO (p)) = is_new_lexical_level (p);
262 // The default.
263 UNIT (&GPROP (p)) = genie_unit;
264 SOURCE (&GPROP (p)) = p;
265 #if defined (BUILD_A68G_COMPILER)
266 if (OPTION_OPT_LEVEL (&A68G_JOB) > 0 && COMPILE_NAME (GINFO (p)) != NO_TEXT && compile_plugin != NULL) {
267 if (COMPILE_NAME (GINFO (p)) == last_compile_name) {
268 // We copy.
269 UNIT (&GPROP (p)) = last_compile_unit;
270 } else {
271 // We look up.
272 // Next line may provoke a warning even with this POSIX workaround. Tant pis.
273 *(void **) &(UNIT (&GPROP (p))) = dlsym (compile_plugin, COMPILE_NAME (GINFO (p)));
274 ABEND (UNIT (&GPROP (p)) == NULL, ERROR_INTERNAL_CONSISTENCY, dlerror ());
275 last_compile_name = COMPILE_NAME (GINFO (p));
276 last_compile_unit = UNIT (&GPROP (p));
277 }
278 }
279 #endif
280 }
281 if (MOID (p) != NO_MOID) {
282 SIZE (MOID (p)) = moid_size (MOID (p));
283 DIGITS (MOID (p)) = moid_digits (MOID (p));
284 SHORT_ID (MOID (p)) = mode_attribute (MOID (p));
285 if (GINFO (p) != NO_GINFO) {
286 NEED_DNS (GINFO (p)) = A68G_FALSE;
287 if (IS_REF (MOID (p))) {
288 NEED_DNS (GINFO (p)) = A68G_TRUE;
289 } else if (IS (MOID (p), PROC_SYMBOL)) {
290 NEED_DNS (GINFO (p)) = A68G_TRUE;
291 } else if (IS (MOID (p), FORMAT_SYMBOL)) {
292 NEED_DNS (GINFO (p)) = A68G_TRUE;
293 }
294 }
295 }
296 if (TABLE (p) != NO_TABLE) {
297 if (LEX_LEVEL (p) > *max_lev) {
298 *max_lev = LEX_LEVEL (p);
299 }
300 }
301 if (IS (p, FORMAT_TEXT)) {
302 TAG_T *q = TAX (p);
303 if (q != NO_TAG && NODE (q) != NO_NODE) {
304 NODE (q) = p;
305 }
306 } else if (IS (p, DEFINING_IDENTIFIER)) {
307 TAG_T *q = TAX (p);
308 if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
309 LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
310 }
311 } else if (IS (p, IDENTIFIER)) {
312 TAG_T *q = TAX (p);
313 if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
314 LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
315 OFFSET (GINFO (p)) = &(A68G_STACK[FRAME_INFO_SIZE + OFFSET (q)]);
316 }
317 } else if (IS (p, OPERATOR)) {
318 TAG_T *q = TAX (p);
319 if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
320 LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
321 OFFSET (GINFO (p)) = &(A68G_STACK[FRAME_INFO_SIZE + OFFSET (q)]);
322 }
323 }
324 if (SUB (p) != NO_NODE) {
325 if (GINFO (p) != NO_GINFO) {
326 GPARENT (SUB (p)) = p;
327 }
328 genie_preprocess (SUB (p), max_lev, compile_plugin);
329 }
330 }
331 }
332
333 //! @brief Get outermost lexical level in the user program.
334
335 void get_global_level (NODE_T * p)
336 {
337 for (; p != NO_NODE; FORWARD (p)) {
338 if (LINE_NUMBER (p) != 0 && IS (p, UNIT)) {
339 if (LEX_LEVEL (p) < A68G (global_level)) {
340 A68G (global_level) = LEX_LEVEL (p);
341 }
342 }
343 get_global_level (SUB (p));
344 }
345 }
346
347 //! @brief Driver for the interpreter.
348
349 void genie (void *compile_plugin)
350 {
351 // Fill in final info for modes.
352 for (MOID_T *m = TOP_MOID (&A68G_JOB); m != NO_MOID; FORWARD (m)) {
353 SIZE (m) = moid_size (m);
354 DIGITS (m) = moid_digits (m);
355 SHORT_ID (m) = mode_attribute (m);
356 }
357 // Preprocessing.
358 A68G (max_lex_lvl) = 0;
359 // genie_lex_levels (TOP_NODE (&A68G_JOB), 1);.
360 genie_preprocess (TOP_NODE (&A68G_JOB), &A68G (max_lex_lvl), compile_plugin);
361 change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_INTERRUPT_MASK, A68G_FALSE);
362 change_gc_masks (TOP_NODE (&A68G_JOB), A68G_FALSE);
363 A68G_MON (watchpoint_expression) = NO_TEXT;
364 A68G (frame_stack_limit) = A68G (frame_end) - A68G (storage_overhead);
365 A68G (expr_stack_limit) = A68G (stack_end) - A68G (storage_overhead);
366 if (OPTION_REGRESSION_TEST (&A68G_JOB)) {
367 init_rng (1);
368 } else {
369 genie_init_rng ();
370 }
371 io_close_tty_line ();
372 if (OPTION_TRACE (&A68G_JOB)) {
373 ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "genie: frame stack %uk, expression stack %uk, heap %uk, handles %uk\n", A68G (frame_stack_size) / KILOBYTE, A68G (expr_stack_size) / KILOBYTE, A68G (heap_size) / KILOBYTE, A68G (handle_pool_size) / KILOBYTE) >= 0);
374 WRITE (A68G_STDOUT, A68G (output_line));
375 }
376 install_signal_handlers ();
377 set_default_event_procedure (&A68G (on_gc_event));
378 A68G (do_confirm_exit) = A68G_TRUE;
379 #if defined (BUILD_PARALLEL_CLAUSE)
380 ASSERT (pthread_mutex_init (&A68G_PAR (unit_sema), NULL) == 0);
381 #endif
382 // Dive into the program.
383 if (setjmp (A68G (genie_exit_label)) == 0) {
384 NODE_T *p = SUB (TOP_NODE (&A68G_JOB));
385 // If we are to stop in the monitor, set a breakpoint on the first unit.
386 if (OPTION_DEBUG (&A68G_JOB)) {
387 change_masks (TOP_NODE (&A68G_JOB), BREAKPOINT_TEMPORARY_MASK, A68G_TRUE);
388 WRITE (A68G_STDOUT, "Execution begins ...");
389 }
390 errno = 0;
391 A68G (ret_code) = 0;
392 A68G (global_level) = INT_MAX;
393 A68G_GLOBALS = 0;
394 get_global_level (p);
395 A68G_FP = A68G (frame_start);
396 A68G_SP = A68G (stack_start);
397 FRAME_DYNAMIC_LINK (A68G_FP) = 0;
398 FRAME_DNS (A68G_FP) = 0;
399 FRAME_STATIC_LINK (A68G_FP) = 0;
400 FRAME_NUMBER (A68G_FP) = 0;
401 FRAME_TREE (A68G_FP) = (NODE_T *) p;
402 FRAME_LEXICAL_LEVEL (A68G_FP) = LEX_LEVEL (p);
403 FRAME_PARAMETER_LEVEL (A68G_FP) = LEX_LEVEL (p);
404 FRAME_PARAMETERS (A68G_FP) = A68G_FP;
405 initialise_frame (p);
406 genie_init_heap (p);
407 genie_init_transput (TOP_NODE (&A68G_JOB));
408 A68G (cputime_0) = seconds ();
409 A68G (walltime_0) = wall_seconds ();
410 A68G_GC (sema) = 0;
411 // Here we go ...
412 A68G (in_execution) = A68G_TRUE;
413 A68G (f_entry) = TOP_NODE (&A68G_JOB);
414 #if defined (BUILD_UNIX)
415 (void) a68g_alarm (INTERRUPT_INTERVAL);
416 #endif
417 if (OPTION_TRACE (&A68G_JOB)) {
418 WIS (TOP_NODE (&A68G_JOB));
419 }
420 (void) genie_enclosed (TOP_NODE (&A68G_JOB));
421 } else {
422 // Here we have jumped out of the interpreter. What happened?.
423 if (OPTION_DEBUG (&A68G_JOB)) {
424 WRITE (A68G_STDOUT, "Execution discontinued");
425 }
426 if (A68G (ret_code) == A68G_RERUN) {
427 diagnostics_to_terminal (TOP_LINE (&A68G_JOB), A68G_RUNTIME_ERROR);
428 genie (compile_plugin);
429 } else if (A68G (ret_code) == A68G_RUNTIME_ERROR) {
430 if (OPTION_BACKTRACE (&A68G_JOB)) {
431 int printed = 0;
432 ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0);
433 WRITE (A68G_STDOUT, A68G (output_line));
434 stack_dump (A68G_STDOUT, A68G_FP, 16, &printed);
435 WRITE (A68G_STDOUT, NEWLINE_STRING);
436 }
437 if (FILE_LISTING_OPENED (&A68G_JOB)) {
438 int printed = 0;
439 ASSERT (a68g_bufprt (A68G (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0);
440 WRITE (FILE_LISTING_FD (&A68G_JOB), A68G (output_line));
441 stack_dump (FILE_LISTING_FD (&A68G_JOB), A68G_FP, 32, &printed);
442 }
443 }
444 }
445 A68G (in_execution) = A68G_FALSE;
446 }
447
448 //! @brief Shows line where 'p' is at and draws a '-' beneath the position.
449
450 void where_in_source (FILE_T f, NODE_T * p)
451 {
452 write_source_line (f, LINE (INFO (p)), p, A68G_NO_DIAGNOSTICS);
453 }
454
455 // Since Algol 68 can pass procedures as parameters, we use static links rather
456 // than a display.
457
458 //! @brief Initialise PROC and OP identities.
459
460 void genie_init_proc_op (NODE_T * p, NODE_T ** seq, int *count)
461 {
462 for (; p != NO_NODE; FORWARD (p)) {
463 switch (ATTRIBUTE (p)) {
464 case OP_SYMBOL:
465 case PROC_SYMBOL:
466 case OPERATOR_PLAN:
467 case DECLARER: {
468 break;
469 }
470 case DEFINING_IDENTIFIER:
471 case DEFINING_OPERATOR: {
472 // Store position so we need not search again.
473 NODE_T *save = *seq;
474 (*seq) = p;
475 SEQUENCE (*seq) = save;
476 (*count)++;
477 return;
478 }
479 default: {
480 genie_init_proc_op (SUB (p), seq, count);
481 break;
482 }
483 }
484 }
485 }
486
487 //! @brief Initialise PROC and OP identity declarations.
488
489 void genie_find_proc_op (NODE_T * p, int *count)
490 {
491 for (; p != NO_NODE; FORWARD (p)) {
492 if (GINFO (p) != NO_GINFO && IS_NEW_LEXICAL_LEVEL (GINFO (p))) {
493 // Don't enter a new lexical level - it will have its own initialisation.
494 return;
495 } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) {
496 genie_init_proc_op (SUB (p), &(SEQUENCE (TABLE (p))), count);
497 return;
498 } else {
499 genie_find_proc_op (SUB (p), count);
500 }
501 }
502 }
503
504 //! @brief Initialise stack frame.
505
506 void initialise_frame (NODE_T * p)
507 {
508 if (INITIALISE_ANON (TABLE (p))) {
509 TAG_T *_a_;
510 INITIALISE_ANON (TABLE (p)) = A68G_FALSE;
511 for (_a_ = ANONYMOUS (TABLE (p)); _a_ != NO_TAG; FORWARD (_a_)) {
512 if (PRIO (_a_) == ROUTINE_TEXT) {
513 int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_)));
514 A68G_PROCEDURE *_z_ = (A68G_PROCEDURE *) (FRAME_OBJECT (OFFSET (_a_)));
515 STATUS (_z_) = INIT_MASK;
516 NODE (&(BODY (_z_))) = NODE (_a_);
517 if (youngest > 0) {
518 STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest);
519 } else {
520 ENVIRON (_z_) = 0;
521 }
522 LOCALE (_z_) = NO_HANDLE;
523 MOID (_z_) = MOID (_a_);
524 INITIALISE_ANON (TABLE (p)) = A68G_TRUE;
525 } else if (PRIO (_a_) == FORMAT_TEXT) {
526 int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_)));
527 A68G_FORMAT *_z_ = (A68G_FORMAT *) (FRAME_OBJECT (OFFSET (_a_)));
528 STATUS (_z_) = INIT_MASK;
529 BODY (_z_) = NODE (_a_);
530 if (youngest > 0) {
531 STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest);
532 } else {
533 ENVIRON (_z_) = 0;
534 }
535 INITIALISE_ANON (TABLE (p)) = A68G_TRUE;
536 }
537 }
538 }
539 if (PROC_OPS (TABLE (p))) {
540 NODE_T *_q_;
541 if (SEQUENCE (TABLE (p)) == NO_NODE) {
542 int count = 0;
543 genie_find_proc_op (p, &count);
544 PROC_OPS (TABLE (p)) = (BOOL_T) (count > 0);
545 }
546 for (_q_ = SEQUENCE (TABLE (p)); _q_ != NO_NODE; _q_ = SEQUENCE (_q_)) {
547 NODE_T *u = NEXT_NEXT (_q_);
548 if (IS (u, ROUTINE_TEXT)) {
549 NODE_T *src = SOURCE (&(GPROP (u)));
550 *(A68G_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68G_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src))));
551 } else if ((IS (u, UNIT) && IS (SUB (u), ROUTINE_TEXT))) {
552 NODE_T *src = SOURCE (&(GPROP (SUB (u))));
553 *(A68G_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68G_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src))));
554 }
555 }
556 }
557 INITIALISE_FRAME (TABLE (p)) = (BOOL_T) (INITIALISE_ANON (TABLE (p)) || PROC_OPS (TABLE (p)));
558 }
559
560 //! @brief Whether item at "w" of mode "q" is initialised.
561
562 void genie_check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q)
563 {
564 switch (SHORT_ID (q)) {
565 case REF_SYMBOL: {
566 A68G_REF *z = (A68G_REF *) w;
567 CHECK_INIT (p, INITIALISED (z), q);
568 return;
569 }
570 case PROC_SYMBOL: {
571 A68G_PROCEDURE *z = (A68G_PROCEDURE *) w;
572 CHECK_INIT (p, INITIALISED (z), q);
573 return;
574 }
575 case MODE_INT: {
576 A68G_INT *z = (A68G_INT *) w;
577 CHECK_INIT (p, INITIALISED (z), q);
578 return;
579 }
580 case MODE_REAL: {
581 A68G_REAL *z = (A68G_REAL *) w;
582 CHECK_INIT (p, INITIALISED (z), q);
583 return;
584 }
585 case MODE_COMPLEX: {
586 A68G_REAL *r = (A68G_REAL *) w;
587 A68G_REAL *i = (A68G_REAL *) (w + SIZE_ALIGNED (A68G_REAL));
588 CHECK_INIT (p, INITIALISED (r), q);
589 CHECK_INIT (p, INITIALISED (i), q);
590 return;
591 }
592 #if (A68G_LEVEL >= 3)
593 case MODE_LONG_INT:
594 case MODE_LONG_REAL:
595 case MODE_LONG_BITS: {
596 A68G_DOUBLE *z = (A68G_DOUBLE *) w;
597 CHECK_INIT (p, INITIALISED (z), q);
598 return;
599 }
600 case MODE_LONG_COMPLEX: {
601 A68G_LONG_REAL *r = (A68G_LONG_REAL *) w;
602 A68G_LONG_REAL *i = (A68G_LONG_REAL *) (w + SIZE_ALIGNED (A68G_LONG_REAL));
603 CHECK_INIT (p, INITIALISED (r), q);
604 CHECK_INIT (p, INITIALISED (i), q);
605 return;
606 }
607 case MODE_LONG_LONG_INT:
608 case MODE_LONG_LONG_REAL:
609 case MODE_LONG_LONG_BITS: {
610 MP_T *z = (MP_T *) w;
611 CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q);
612 return;
613 }
614 #else
615 case MODE_LONG_INT:
616 case MODE_LONG_LONG_INT:
617 case MODE_LONG_REAL:
618 case MODE_LONG_LONG_REAL:
619 case MODE_LONG_BITS:
620 case MODE_LONG_LONG_BITS: {
621 MP_T *z = (MP_T *) w;
622 CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q);
623 return;
624 }
625 case MODE_LONG_COMPLEX: {
626 MP_T *r = (MP_T *) w;
627 MP_T *i = (MP_T *) (w + size_mp ());
628 CHECK_INIT (p, (unt) r[0] & INIT_MASK, q);
629 CHECK_INIT (p, (unt) i[0] & INIT_MASK, q);
630 return;
631 }
632 #endif
633 case MODE_LONG_LONG_COMPLEX: {
634 MP_T *r = (MP_T *) w;
635 MP_T *i = (MP_T *) (w + size_long_mp ());
636 CHECK_INIT (p, (unt) r[0] & INIT_MASK, q);
637 CHECK_INIT (p, (unt) i[0] & INIT_MASK, q);
638 return;
639 }
640 case MODE_BOOL: {
641 A68G_BOOL *z = (A68G_BOOL *) w;
642 CHECK_INIT (p, INITIALISED (z), q);
643 return;
644 }
645 case MODE_CHAR: {
646 A68G_CHAR *z = (A68G_CHAR *) w;
647 CHECK_INIT (p, INITIALISED (z), q);
648 return;
649 }
650 case MODE_BITS: {
651 A68G_BITS *z = (A68G_BITS *) w;
652 CHECK_INIT (p, INITIALISED (z), q);
653 return;
654 }
655 case MODE_BYTES: {
656 A68G_BYTES *z = (A68G_BYTES *) w;
657 CHECK_INIT (p, INITIALISED (z), q);
658 return;
659 }
660 case MODE_LONG_BYTES: {
661 A68G_LONG_BYTES *z = (A68G_LONG_BYTES *) w;
662 CHECK_INIT (p, INITIALISED (z), q);
663 return;
664 }
665 case MODE_FILE: {
666 A68G_FILE *z = (A68G_FILE *) w;
667 CHECK_INIT (p, INITIALISED (z), q);
668 return;
669 }
670 case MODE_FORMAT: {
671 A68G_FORMAT *z = (A68G_FORMAT *) w;
672 CHECK_INIT (p, INITIALISED (z), q);
673 return;
674 }
675 case MODE_PIPE: {
676 A68G_REF *pipe_read = (A68G_REF *) w;
677 A68G_REF *pipe_write = (A68G_REF *) (w + A68G_REF_SIZE);
678 A68G_INT *pid = (A68G_INT *) (w + 2 * A68G_REF_SIZE);
679 CHECK_INIT (p, INITIALISED (pipe_read), q);
680 CHECK_INIT (p, INITIALISED (pipe_write), q);
681 CHECK_INIT (p, INITIALISED (pid), q);
682 return;
683 }
684 case MODE_SOUND: {
685 A68G_SOUND *z = (A68G_SOUND *) w;
686 CHECK_INIT (p, INITIALISED (z), q);
687 return;
688 }
689 }
690 }
691
692 //! @brief Propagator_name.
693
694 char *propagator_name (const PROP_PROC * p)
695 {
696 if (p == genie_and_function) {
697 return "genie_and_function";
698 }
699 if (p == genie_assertion) {
700 return "genie_assertion";
701 }
702 if (p == genie_assignation) {
703 return "genie_assignation";
704 }
705 if (p == genie_assignation_constant) {
706 return "genie_assignation_constant";
707 }
708 if (p == genie_call) {
709 return "genie_call";
710 }
711 if (p == genie_cast) {
712 return "genie_cast";
713 }
714 if (p == (PROP_PROC *) genie_closed) {
715 return "genie_closed";
716 }
717 if (p == genie_coercion) {
718 return "genie_coercion";
719 }
720 if (p == genie_collateral) {
721 return "genie_collateral";
722 }
723 if (p == genie_column_function) {
724 return "genie_column_function";
725 }
726 if (p == (PROP_PROC *) genie_conditional) {
727 return "genie_conditional";
728 }
729 if (p == genie_constant) {
730 return "genie_constant";
731 }
732 if (p == genie_denotation) {
733 return "genie_denotation";
734 }
735 if (p == genie_deproceduring) {
736 return "genie_deproceduring";
737 }
738 if (p == genie_dereference_frame_identifier) {
739 return "genie_dereference_frame_identifier";
740 }
741 if (p == genie_dereference_selection_name_quick) {
742 return "genie_dereference_selection_name_quick";
743 }
744 if (p == genie_dereference_slice_name_quick) {
745 return "genie_dereference_slice_name_quick";
746 }
747 if (p == genie_dereferencing) {
748 return "genie_dereferencing";
749 }
750 if (p == genie_dereferencing_quick) {
751 return "genie_dereferencing_quick";
752 }
753 if (p == genie_diagonal_function) {
754 return "genie_diagonal_function";
755 }
756 if (p == genie_dyadic) {
757 return "genie_dyadic";
758 }
759 if (p == genie_dyadic_quick) {
760 return "genie_dyadic_quick";
761 }
762 if (p == (PROP_PROC *) genie_enclosed) {
763 return "genie_enclosed";
764 }
765 if (p == genie_format_text) {
766 return "genie_format_text";
767 }
768 if (p == genie_formula) {
769 return "genie_formula";
770 }
771 if (p == genie_generator) {
772 return "genie_generator";
773 }
774 if (p == genie_identifier) {
775 return "genie_identifier";
776 }
777 if (p == genie_identifier_standenv) {
778 return "genie_identifier_standenv";
779 }
780 if (p == genie_identifier_standenv_proc) {
781 return "genie_identifier_standenv_proc";
782 }
783 if (p == genie_identity_relation) {
784 return "genie_identity_relation";
785 }
786 if (p == (PROP_PROC *) genie_int_case) {
787 return "genie_int_case";
788 }
789 if (p == genie_field_selection) {
790 return "genie_field_selection";
791 }
792 if (p == genie_frame_identifier) {
793 return "genie_frame_identifier";
794 }
795 if (p == (PROP_PROC *) genie_loop) {
796 return "genie_loop";
797 }
798 if (p == genie_monadic) {
799 return "genie_monadic";
800 }
801 if (p == genie_nihil) {
802 return "genie_nihil";
803 }
804 if (p == genie_or_function) {
805 return "genie_or_function";
806 }
807 #if defined (BUILD_PARALLEL_CLAUSE)
808 if (p == genie_parallel) {
809 return "genie_parallel";
810 }
811 #endif
812 if (p == genie_routine_text) {
813 return "genie_routine_text";
814 }
815 if (p == genie_row_function) {
816 return "genie_row_function";
817 }
818 if (p == genie_rowing) {
819 return "genie_rowing";
820 }
821 if (p == genie_rowing_ref_row_of_row) {
822 return "genie_rowing_ref_row_of_row";
823 }
824 if (p == genie_rowing_ref_row_row) {
825 return "genie_rowing_ref_row_row";
826 }
827 if (p == genie_rowing_row_of_row) {
828 return "genie_rowing_row_of_row";
829 }
830 if (p == genie_rowing_row_row) {
831 return "genie_rowing_row_row";
832 }
833 if (p == genie_selection) {
834 return "genie_selection";
835 }
836 if (p == genie_selection_name_quick) {
837 return "genie_selection_name_quick";
838 }
839 if (p == genie_selection_value_quick) {
840 return "genie_selection_value_quick";
841 }
842 if (p == genie_skip) {
843 return "genie_skip";
844 }
845 if (p == genie_slice) {
846 return "genie_slice";
847 }
848 if (p == genie_slice_name_quick) {
849 return "genie_slice_name_quick";
850 }
851 if (p == genie_transpose_function) {
852 return "genie_transpose_function";
853 }
854 if (p == genie_unit) {
855 return "genie_unit";
856 }
857 if (p == (PROP_PROC *) genie_united_case) {
858 return "genie_united_case";
859 }
860 if (p == genie_uniting) {
861 return "genie_uniting";
862 }
863 if (p == genie_voiding) {
864 return "genie_voiding";
865 }
866 if (p == genie_voiding_assignation) {
867 return "genie_voiding_assignation";
868 }
869 if (p == genie_voiding_assignation_constant) {
870 return "genie_voiding_assignation_constant";
871 }
872 if (p == genie_widen) {
873 return "genie_widen";
874 }
875 if (p == genie_widen_int_to_real) {
876 return "genie_widen_int_to_real";
877 }
878 return NO_TEXT;
879 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
