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 == A68_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), A68_TRUE);
65 break;
66 }
67 case SLICE: {
68 change_gc_masks (SUB (p), A68_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 == A68_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 A68 (close_tty_on_exit) = A68_TRUE;
94 if (!A68 (in_execution)) {
95 return;
96 }
97 if (ret == A68_RUNTIME_ERROR && A68 (in_monitor)) {
98 return;
99 } else if (ret == A68_RUNTIME_ERROR && OPTION_DEBUG (&A68_JOB)) {
100 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR);
101 single_step (p, (unt) BREAKPOINT_ERROR_MASK);
102 A68 (in_execution) = A68_FALSE;
103 A68 (ret_line_number) = LINE_NUMBER (p);
104 A68 (ret_code) = ret;
105 longjmp (A68 (genie_exit_label), 1);
106 } else {
107 if ((ret & A68_FORCE_QUIT) != NULL_MASK) {
108 ret &= ~A68_FORCE_QUIT;
109 }
110 #if defined (BUILD_PARALLEL_CLAUSE)
111 if (!is_main_thread ()) {
112 genie_set_exit_from_threads (ret);
113 } else {
114 A68 (in_execution) = A68_FALSE;
115 A68 (ret_line_number) = LINE_NUMBER (p);
116 A68 (ret_code) = ret;
117 longjmp (A68 (genie_exit_label), 1);
118 }
119 #else
120 A68 (in_execution) = A68_FALSE;
121 A68 (ret_line_number) = LINE_NUMBER (p);
122 A68 (ret_code) = ret;
123 longjmp (A68 (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 = A68_TRUE;
147 } else if (IS (NEXT (p), CLOSE_SYMBOL)) {
148 valid_follow = A68_TRUE;
149 } else if (IS (NEXT (p), END_SYMBOL)) {
150 valid_follow = A68_TRUE;
151 } else if (IS (NEXT (p), EDOC_SYMBOL)) {
152 valid_follow = A68_TRUE;
153 } else if (IS (NEXT (p), OD_SYMBOL)) {
154 valid_follow = A68_TRUE;
155 } else {
156 valid_follow = A68_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_A68_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_A68_COMPILER)
266 if (OPTION_OPT_LEVEL (&A68_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)) = A68_FALSE;
287 if (IS_REF (MOID (p))) {
288 NEED_DNS (GINFO (p)) = A68_TRUE;
289 } else if (IS (MOID (p), PROC_SYMBOL)) {
290 NEED_DNS (GINFO (p)) = A68_TRUE;
291 } else if (IS (MOID (p), FORMAT_SYMBOL)) {
292 NEED_DNS (GINFO (p)) = A68_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)) = &(A68_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)) = &(A68_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) < A68 (global_level)) {
340 A68 (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 (&A68_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 A68 (max_lex_lvl) = 0;
359 // genie_lex_levels (TOP_NODE (&A68_JOB), 1);.
360 genie_preprocess (TOP_NODE (&A68_JOB), &A68 (max_lex_lvl), compile_plugin);
361 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE);
362 change_gc_masks (TOP_NODE (&A68_JOB), A68_FALSE);
363 A68_MON (watchpoint_expression) = NO_TEXT;
364 A68 (frame_stack_limit) = A68 (frame_end) - A68 (storage_overhead);
365 A68 (expr_stack_limit) = A68 (stack_end) - A68 (storage_overhead);
366 if (OPTION_REGRESSION_TEST (&A68_JOB)) {
367 init_rng (1);
368 } else {
369 genie_init_rng ();
370 }
371 io_close_tty_line ();
372 if (OPTION_TRACE (&A68_JOB)) {
373 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "genie: frame stack %uk, expression stack %uk, heap %uk, handles %uk\n", A68 (frame_stack_size) / KILOBYTE, A68 (expr_stack_size) / KILOBYTE, A68 (heap_size) / KILOBYTE, A68 (handle_pool_size) / KILOBYTE) >= 0);
374 WRITE (A68_STDOUT, A68 (output_line));
375 }
376 install_signal_handlers ();
377 set_default_event_procedure (&A68 (on_gc_event));
378 A68 (do_confirm_exit) = A68_TRUE;
379 #if defined (BUILD_PARALLEL_CLAUSE)
380 ASSERT (pthread_mutex_init (&A68_PAR (unit_sema), NULL) == 0);
381 #endif
382 // Dive into the program.
383 if (setjmp (A68 (genie_exit_label)) == 0) {
384 NODE_T *p = SUB (TOP_NODE (&A68_JOB));
385 // If we are to stop in the monitor, set a breakpoint on the first unit.
386 if (OPTION_DEBUG (&A68_JOB)) {
387 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
388 WRITE (A68_STDOUT, "Execution begins ...");
389 }
390 errno = 0;
391 A68 (ret_code) = 0;
392 A68 (global_level) = INT_MAX;
393 A68_GLOBALS = 0;
394 get_global_level (p);
395 A68_FP = A68 (frame_start);
396 A68_SP = A68 (stack_start);
397 FRAME_DYNAMIC_LINK (A68_FP) = 0;
398 FRAME_DNS (A68_FP) = 0;
399 FRAME_STATIC_LINK (A68_FP) = 0;
400 FRAME_NUMBER (A68_FP) = 0;
401 FRAME_TREE (A68_FP) = (NODE_T *) p;
402 FRAME_LEXICAL_LEVEL (A68_FP) = LEX_LEVEL (p);
403 FRAME_PARAMETER_LEVEL (A68_FP) = LEX_LEVEL (p);
404 FRAME_PARAMETERS (A68_FP) = A68_FP;
405 initialise_frame (p);
406 genie_init_heap (p);
407 genie_init_transput (TOP_NODE (&A68_JOB));
408 A68 (cputime_0) = seconds ();
409 A68_GC (sema) = 0;
410 // Here we go ...
411 A68 (in_execution) = A68_TRUE;
412 A68 (f_entry) = TOP_NODE (&A68_JOB);
413 #if defined (BUILD_UNIX)
414 (void) a68_alarm (INTERRUPT_INTERVAL);
415 #endif
416 if (OPTION_TRACE (&A68_JOB)) {
417 WIS (TOP_NODE (&A68_JOB));
418 }
419 (void) genie_enclosed (TOP_NODE (&A68_JOB));
420 } else {
421 // Here we have jumped out of the interpreter. What happened?.
422 if (OPTION_DEBUG (&A68_JOB)) {
423 WRITE (A68_STDOUT, "Execution discontinued");
424 }
425 if (A68 (ret_code) == A68_RERUN) {
426 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR);
427 genie (compile_plugin);
428 } else if (A68 (ret_code) == A68_RUNTIME_ERROR) {
429 if (OPTION_BACKTRACE (&A68_JOB)) {
430 int printed = 0;
431 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0);
432 WRITE (A68_STDOUT, A68 (output_line));
433 stack_dump (A68_STDOUT, A68_FP, 16, &printed);
434 WRITE (A68_STDOUT, NEWLINE_STRING);
435 }
436 if (FILE_LISTING_OPENED (&A68_JOB)) {
437 int printed = 0;
438 ASSERT (a68_bufprt (A68 (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0);
439 WRITE (FILE_LISTING_FD (&A68_JOB), A68 (output_line));
440 stack_dump (FILE_LISTING_FD (&A68_JOB), A68_FP, 32, &printed);
441 }
442 }
443 }
444 A68 (in_execution) = A68_FALSE;
445 }
446
447 //! @brief Shows line where 'p' is at and draws a '-' beneath the position.
448
449 void where_in_source (FILE_T f, NODE_T * p)
450 {
451 write_source_line (f, LINE (INFO (p)), p, A68_NO_DIAGNOSTICS);
452 }
453
454 // Since Algol 68 can pass procedures as parameters, we use static links rather
455 // than a display.
456
457 //! @brief Initialise PROC and OP identities.
458
459 void genie_init_proc_op (NODE_T * p, NODE_T ** seq, int *count)
460 {
461 for (; p != NO_NODE; FORWARD (p)) {
462 switch (ATTRIBUTE (p)) {
463 case OP_SYMBOL:
464 case PROC_SYMBOL:
465 case OPERATOR_PLAN:
466 case DECLARER: {
467 break;
468 }
469 case DEFINING_IDENTIFIER:
470 case DEFINING_OPERATOR: {
471 // Store position so we need not search again.
472 NODE_T *save = *seq;
473 (*seq) = p;
474 SEQUENCE (*seq) = save;
475 (*count)++;
476 return;
477 }
478 default: {
479 genie_init_proc_op (SUB (p), seq, count);
480 break;
481 }
482 }
483 }
484 }
485
486 //! @brief Initialise PROC and OP identity declarations.
487
488 void genie_find_proc_op (NODE_T * p, int *count)
489 {
490 for (; p != NO_NODE; FORWARD (p)) {
491 if (GINFO (p) != NO_GINFO && IS_NEW_LEXICAL_LEVEL (GINFO (p))) {
492 // Don't enter a new lexical level - it will have its own initialisation.
493 return;
494 } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) {
495 genie_init_proc_op (SUB (p), &(SEQUENCE (TABLE (p))), count);
496 return;
497 } else {
498 genie_find_proc_op (SUB (p), count);
499 }
500 }
501 }
502
503 //! @brief Initialise stack frame.
504
505 void initialise_frame (NODE_T * p)
506 {
507 if (INITIALISE_ANON (TABLE (p))) {
508 TAG_T *_a_;
509 INITIALISE_ANON (TABLE (p)) = A68_FALSE;
510 for (_a_ = ANONYMOUS (TABLE (p)); _a_ != NO_TAG; FORWARD (_a_)) {
511 if (PRIO (_a_) == ROUTINE_TEXT) {
512 int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_)));
513 A68_PROCEDURE *_z_ = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (_a_)));
514 STATUS (_z_) = INIT_MASK;
515 NODE (&(BODY (_z_))) = NODE (_a_);
516 if (youngest > 0) {
517 STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest);
518 } else {
519 ENVIRON (_z_) = 0;
520 }
521 LOCALE (_z_) = NO_HANDLE;
522 MOID (_z_) = MOID (_a_);
523 INITIALISE_ANON (TABLE (p)) = A68_TRUE;
524 } else if (PRIO (_a_) == FORMAT_TEXT) {
525 int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_)));
526 A68_FORMAT *_z_ = (A68_FORMAT *) (FRAME_OBJECT (OFFSET (_a_)));
527 STATUS (_z_) = INIT_MASK;
528 BODY (_z_) = NODE (_a_);
529 if (youngest > 0) {
530 STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest);
531 } else {
532 ENVIRON (_z_) = 0;
533 }
534 INITIALISE_ANON (TABLE (p)) = A68_TRUE;
535 }
536 }
537 }
538 if (PROC_OPS (TABLE (p))) {
539 NODE_T *_q_;
540 if (SEQUENCE (TABLE (p)) == NO_NODE) {
541 int count = 0;
542 genie_find_proc_op (p, &count);
543 PROC_OPS (TABLE (p)) = (BOOL_T) (count > 0);
544 }
545 for (_q_ = SEQUENCE (TABLE (p)); _q_ != NO_NODE; _q_ = SEQUENCE (_q_)) {
546 NODE_T *u = NEXT_NEXT (_q_);
547 if (IS (u, ROUTINE_TEXT)) {
548 NODE_T *src = SOURCE (&(GPROP (u)));
549 *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src))));
550 } else if ((IS (u, UNIT) && IS (SUB (u), ROUTINE_TEXT))) {
551 NODE_T *src = SOURCE (&(GPROP (SUB (u))));
552 *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src))));
553 }
554 }
555 }
556 INITIALISE_FRAME (TABLE (p)) = (BOOL_T) (INITIALISE_ANON (TABLE (p)) || PROC_OPS (TABLE (p)));
557 }
558
559 //! @brief Whether item at "w" of mode "q" is initialised.
560
561 void genie_check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q)
562 {
563 switch (SHORT_ID (q)) {
564 case REF_SYMBOL: {
565 A68_REF *z = (A68_REF *) w;
566 CHECK_INIT (p, INITIALISED (z), q);
567 return;
568 }
569 case PROC_SYMBOL: {
570 A68_PROCEDURE *z = (A68_PROCEDURE *) w;
571 CHECK_INIT (p, INITIALISED (z), q);
572 return;
573 }
574 case MODE_INT: {
575 A68_INT *z = (A68_INT *) w;
576 CHECK_INIT (p, INITIALISED (z), q);
577 return;
578 }
579 case MODE_REAL: {
580 A68_REAL *z = (A68_REAL *) w;
581 CHECK_INIT (p, INITIALISED (z), q);
582 return;
583 }
584 case MODE_COMPLEX: {
585 A68_REAL *r = (A68_REAL *) w;
586 A68_REAL *i = (A68_REAL *) (w + SIZE_ALIGNED (A68_REAL));
587 CHECK_INIT (p, INITIALISED (r), q);
588 CHECK_INIT (p, INITIALISED (i), q);
589 return;
590 }
591 #if (A68_LEVEL >= 3)
592 case MODE_LONG_INT:
593 case MODE_LONG_REAL:
594 case MODE_LONG_BITS: {
595 A68_DOUBLE *z = (A68_DOUBLE *) w;
596 CHECK_INIT (p, INITIALISED (z), q);
597 return;
598 }
599 case MODE_LONG_COMPLEX: {
600 A68_LONG_REAL *r = (A68_LONG_REAL *) w;
601 A68_LONG_REAL *i = (A68_LONG_REAL *) (w + SIZE_ALIGNED (A68_LONG_REAL));
602 CHECK_INIT (p, INITIALISED (r), q);
603 CHECK_INIT (p, INITIALISED (i), q);
604 return;
605 }
606 case MODE_LONG_LONG_INT:
607 case MODE_LONG_LONG_REAL:
608 case MODE_LONG_LONG_BITS: {
609 MP_T *z = (MP_T *) w;
610 CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q);
611 return;
612 }
613 #else
614 case MODE_LONG_INT:
615 case MODE_LONG_LONG_INT:
616 case MODE_LONG_REAL:
617 case MODE_LONG_LONG_REAL:
618 case MODE_LONG_BITS:
619 case MODE_LONG_LONG_BITS: {
620 MP_T *z = (MP_T *) w;
621 CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q);
622 return;
623 }
624 case MODE_LONG_COMPLEX: {
625 MP_T *r = (MP_T *) w;
626 MP_T *i = (MP_T *) (w + size_mp ());
627 CHECK_INIT (p, (unt) r[0] & INIT_MASK, q);
628 CHECK_INIT (p, (unt) i[0] & INIT_MASK, q);
629 return;
630 }
631 #endif
632 case MODE_LONG_LONG_COMPLEX: {
633 MP_T *r = (MP_T *) w;
634 MP_T *i = (MP_T *) (w + size_long_mp ());
635 CHECK_INIT (p, (unt) r[0] & INIT_MASK, q);
636 CHECK_INIT (p, (unt) i[0] & INIT_MASK, q);
637 return;
638 }
639 case MODE_BOOL: {
640 A68_BOOL *z = (A68_BOOL *) w;
641 CHECK_INIT (p, INITIALISED (z), q);
642 return;
643 }
644 case MODE_CHAR: {
645 A68_CHAR *z = (A68_CHAR *) w;
646 CHECK_INIT (p, INITIALISED (z), q);
647 return;
648 }
649 case MODE_BITS: {
650 A68_BITS *z = (A68_BITS *) w;
651 CHECK_INIT (p, INITIALISED (z), q);
652 return;
653 }
654 case MODE_BYTES: {
655 A68_BYTES *z = (A68_BYTES *) w;
656 CHECK_INIT (p, INITIALISED (z), q);
657 return;
658 }
659 case MODE_LONG_BYTES: {
660 A68_LONG_BYTES *z = (A68_LONG_BYTES *) w;
661 CHECK_INIT (p, INITIALISED (z), q);
662 return;
663 }
664 case MODE_FILE: {
665 A68_FILE *z = (A68_FILE *) w;
666 CHECK_INIT (p, INITIALISED (z), q);
667 return;
668 }
669 case MODE_FORMAT: {
670 A68_FORMAT *z = (A68_FORMAT *) w;
671 CHECK_INIT (p, INITIALISED (z), q);
672 return;
673 }
674 case MODE_PIPE: {
675 A68_REF *pipe_read = (A68_REF *) w;
676 A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE);
677 A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE);
678 CHECK_INIT (p, INITIALISED (pipe_read), q);
679 CHECK_INIT (p, INITIALISED (pipe_write), q);
680 CHECK_INIT (p, INITIALISED (pid), q);
681 return;
682 }
683 case MODE_SOUND: {
684 A68_SOUND *z = (A68_SOUND *) w;
685 CHECK_INIT (p, INITIALISED (z), q);
686 return;
687 }
688 }
689 }
690
691 //! @brief Propagator_name.
692
693 char *propagator_name (const PROP_PROC * p)
694 {
695 if (p == genie_and_function) {
696 return "genie_and_function";
697 }
698 if (p == genie_assertion) {
699 return "genie_assertion";
700 }
701 if (p == genie_assignation) {
702 return "genie_assignation";
703 }
704 if (p == genie_assignation_constant) {
705 return "genie_assignation_constant";
706 }
707 if (p == genie_call) {
708 return "genie_call";
709 }
710 if (p == genie_cast) {
711 return "genie_cast";
712 }
713 if (p == (PROP_PROC *) genie_closed) {
714 return "genie_closed";
715 }
716 if (p == genie_coercion) {
717 return "genie_coercion";
718 }
719 if (p == genie_collateral) {
720 return "genie_collateral";
721 }
722 if (p == genie_column_function) {
723 return "genie_column_function";
724 }
725 if (p == (PROP_PROC *) genie_conditional) {
726 return "genie_conditional";
727 }
728 if (p == genie_constant) {
729 return "genie_constant";
730 }
731 if (p == genie_denotation) {
732 return "genie_denotation";
733 }
734 if (p == genie_deproceduring) {
735 return "genie_deproceduring";
736 }
737 if (p == genie_dereference_frame_identifier) {
738 return "genie_dereference_frame_identifier";
739 }
740 if (p == genie_dereference_selection_name_quick) {
741 return "genie_dereference_selection_name_quick";
742 }
743 if (p == genie_dereference_slice_name_quick) {
744 return "genie_dereference_slice_name_quick";
745 }
746 if (p == genie_dereferencing) {
747 return "genie_dereferencing";
748 }
749 if (p == genie_dereferencing_quick) {
750 return "genie_dereferencing_quick";
751 }
752 if (p == genie_diagonal_function) {
753 return "genie_diagonal_function";
754 }
755 if (p == genie_dyadic) {
756 return "genie_dyadic";
757 }
758 if (p == genie_dyadic_quick) {
759 return "genie_dyadic_quick";
760 }
761 if (p == (PROP_PROC *) genie_enclosed) {
762 return "genie_enclosed";
763 }
764 if (p == genie_format_text) {
765 return "genie_format_text";
766 }
767 if (p == genie_formula) {
768 return "genie_formula";
769 }
770 if (p == genie_generator) {
771 return "genie_generator";
772 }
773 if (p == genie_identifier) {
774 return "genie_identifier";
775 }
776 if (p == genie_identifier_standenv) {
777 return "genie_identifier_standenv";
778 }
779 if (p == genie_identifier_standenv_proc) {
780 return "genie_identifier_standenv_proc";
781 }
782 if (p == genie_identity_relation) {
783 return "genie_identity_relation";
784 }
785 if (p == (PROP_PROC *) genie_int_case) {
786 return "genie_int_case";
787 }
788 if (p == genie_field_selection) {
789 return "genie_field_selection";
790 }
791 if (p == genie_frame_identifier) {
792 return "genie_frame_identifier";
793 }
794 if (p == (PROP_PROC *) genie_loop) {
795 return "genie_loop";
796 }
797 if (p == genie_monadic) {
798 return "genie_monadic";
799 }
800 if (p == genie_nihil) {
801 return "genie_nihil";
802 }
803 if (p == genie_or_function) {
804 return "genie_or_function";
805 }
806 #if defined (BUILD_PARALLEL_CLAUSE)
807 if (p == genie_parallel) {
808 return "genie_parallel";
809 }
810 #endif
811 if (p == genie_routine_text) {
812 return "genie_routine_text";
813 }
814 if (p == genie_row_function) {
815 return "genie_row_function";
816 }
817 if (p == genie_rowing) {
818 return "genie_rowing";
819 }
820 if (p == genie_rowing_ref_row_of_row) {
821 return "genie_rowing_ref_row_of_row";
822 }
823 if (p == genie_rowing_ref_row_row) {
824 return "genie_rowing_ref_row_row";
825 }
826 if (p == genie_rowing_row_of_row) {
827 return "genie_rowing_row_of_row";
828 }
829 if (p == genie_rowing_row_row) {
830 return "genie_rowing_row_row";
831 }
832 if (p == genie_selection) {
833 return "genie_selection";
834 }
835 if (p == genie_selection_name_quick) {
836 return "genie_selection_name_quick";
837 }
838 if (p == genie_selection_value_quick) {
839 return "genie_selection_value_quick";
840 }
841 if (p == genie_skip) {
842 return "genie_skip";
843 }
844 if (p == genie_slice) {
845 return "genie_slice";
846 }
847 if (p == genie_slice_name_quick) {
848 return "genie_slice_name_quick";
849 }
850 if (p == genie_transpose_function) {
851 return "genie_transpose_function";
852 }
853 if (p == genie_unit) {
854 return "genie_unit";
855 }
856 if (p == (PROP_PROC *) genie_united_case) {
857 return "genie_united_case";
858 }
859 if (p == genie_uniting) {
860 return "genie_uniting";
861 }
862 if (p == genie_voiding) {
863 return "genie_voiding";
864 }
865 if (p == genie_voiding_assignation) {
866 return "genie_voiding_assignation";
867 }
868 if (p == genie_voiding_assignation_constant) {
869 return "genie_voiding_assignation_constant";
870 }
871 if (p == genie_widen) {
872 return "genie_widen";
873 }
874 if (p == genie_widen_int_to_real) {
875 return "genie_widen_int_to_real";
876 }
877 return NO_TEXT;
878 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
