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-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 //! @section Synopsis
23 //!
24 //! Interpreter driver.
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 Nop for the genie, for instance '+' for INT or REAL.
36
37 void genie_idle (NODE_T * p)
38 {
39 (void) p;
40 }
41
42 //! @brief Unimplemented feature handler.
43
44 void genie_unimplemented (NODE_T * p)
45 {
46 diagnostic (A68_RUNTIME_ERROR, p, ERROR_UNIMPLEMENTED);
47 exit_genie (p, A68_RUNTIME_ERROR);
48 }
49
50 //! @brief PROC sleep = (INT) INT
51
52 void genie_sleep (NODE_T * p)
53 {
54 A68_INT secs;
55 int wait;
56 POP_OBJECT (p, &secs, A68_INT);
57 wait = VALUE (&secs);
58 PRELUDE_ERROR (wait < 0, p, ERROR_INVALID_ARGUMENT, M_INT);
59 while (wait > 0) {
60 wait = (int) sleep ((unt) wait);
61 }
62 PUSH_VALUE (p, (INT_T) 0, A68_INT);
63 }
64
65 //! @brief PROC system = (STRING) INT
66
67 void genie_system (NODE_T * p)
68 {
69 int sys_ret_code, size;
70 A68_REF cmd;
71 A68_REF ref_z;
72 POP_REF (p, &cmd);
73 CHECK_INIT (p, INITIALISED (&cmd), M_STRING);
74 size = 1 + a68_string_size (p, cmd);
75 ref_z = heap_generator (p, M_C_STRING, 1 + size);
76 sys_ret_code = system (a_to_c_string (p, DEREF (char, &ref_z), cmd));
77 PUSH_VALUE (p, sys_ret_code, A68_INT);
78 }
79
80 //! @brief Set flags throughout tree.
81
82 void change_masks (NODE_T * p, unt mask, BOOL_T set)
83 {
84 for (; p != NO_NODE; FORWARD (p)) {
85 change_masks (SUB (p), mask, set);
86 if (LINE_NUMBER (p) > 0) {
87 if (set == A68_TRUE) {
88 STATUS_SET (p, mask);
89 } else {
90 STATUS_CLEAR (p, mask);
91 }
92 }
93 }
94 }
95
96 //! @brief Leave interpretation.
97
98 void exit_genie (NODE_T * p, int ret)
99 {
100 #if defined (HAVE_CURSES)
101 genie_curses_end (p);
102 #endif
103 A68 (close_tty_on_exit) = A68_TRUE;
104 if (!A68 (in_execution)) {
105 return;
106 }
107 if (ret == A68_RUNTIME_ERROR && A68 (in_monitor)) {
108 return;
109 } else if (ret == A68_RUNTIME_ERROR && OPTION_DEBUG (&A68_JOB)) {
110 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR);
111 single_step (p, (unt) BREAKPOINT_ERROR_MASK);
112 A68 (in_execution) = A68_FALSE;
113 A68 (ret_line_number) = LINE_NUMBER (p);
114 A68 (ret_code) = ret;
115 longjmp (A68 (genie_exit_label), 1);
116 } else {
117 if ((ret & A68_FORCE_QUIT) != NULL_MASK) {
118 ret &= ~A68_FORCE_QUIT;
119 }
120 #if defined (BUILD_PARALLEL_CLAUSE)
121 if (!is_main_thread ()) {
122 genie_set_exit_from_threads (ret);
123 } else {
124 A68 (in_execution) = A68_FALSE;
125 A68 (ret_line_number) = LINE_NUMBER (p);
126 A68 (ret_code) = ret;
127 longjmp (A68 (genie_exit_label), 1);
128 }
129 #else
130 A68 (in_execution) = A68_FALSE;
131 A68 (ret_line_number) = LINE_NUMBER (p);
132 A68 (ret_code) = ret;
133 longjmp (A68 (genie_exit_label), 1);
134 #endif
135 }
136 }
137
138 //! @brief Genie init rng.
139
140 void genie_init_rng (void)
141 {
142 time_t t;
143 if (time (&t) != -1) {
144 init_rng ((unt) t);
145 }
146 }
147
148 //! @brief Tie label to the clause it is defined in.
149
150 void tie_label_to_serial (NODE_T * p)
151 {
152 for (; p != NO_NODE; FORWARD (p)) {
153 if (IS (p, SERIAL_CLAUSE)) {
154 BOOL_T valid_follow;
155 if (NEXT (p) == NO_NODE) {
156 valid_follow = A68_TRUE;
157 } else if (IS (NEXT (p), CLOSE_SYMBOL)) {
158 valid_follow = A68_TRUE;
159 } else if (IS (NEXT (p), END_SYMBOL)) {
160 valid_follow = A68_TRUE;
161 } else if (IS (NEXT (p), EDOC_SYMBOL)) {
162 valid_follow = A68_TRUE;
163 } else if (IS (NEXT (p), OD_SYMBOL)) {
164 valid_follow = A68_TRUE;
165 } else {
166 valid_follow = A68_FALSE;
167 }
168 if (valid_follow) {
169 JUMP_TO (TABLE (SUB (p))) = NO_NODE;
170 }
171 }
172 tie_label_to_serial (SUB (p));
173 }
174 }
175
176 //! @brief Tie label to the clause it is defined in.
177
178 void tie_label (NODE_T * p, NODE_T * unit)
179 {
180 for (; p != NO_NODE; FORWARD (p)) {
181 if (IS (p, DEFINING_IDENTIFIER)) {
182 UNIT (TAX (p)) = unit;
183 }
184 tie_label (SUB (p), unit);
185 }
186 }
187
188 //! @brief Tie label to the clause it is defined in.
189
190 void tie_label_to_unit (NODE_T * p)
191 {
192 for (; p != NO_NODE; FORWARD (p)) {
193 if (IS (p, LABELED_UNIT)) {
194 tie_label (SUB_SUB (p), NEXT_SUB (p));
195 }
196 tie_label_to_unit (SUB (p));
197 }
198 }
199
200 //! @brief Fast way to indicate a mode.
201
202 int mode_attribute (MOID_T * p)
203 {
204 if (IS_REF (p)) {
205 return REF_SYMBOL;
206 } else if (IS (p, PROC_SYMBOL)) {
207 return PROC_SYMBOL;
208 } else if (IS_UNION (p)) {
209 return UNION_SYMBOL;
210 } else if (p == M_INT) {
211 return MODE_INT;
212 } else if (p == M_LONG_INT) {
213 return MODE_LONG_INT;
214 } else if (p == M_LONG_LONG_INT) {
215 return MODE_LONG_LONG_INT;
216 } else if (p == M_REAL) {
217 return MODE_REAL;
218 } else if (p == M_LONG_REAL) {
219 return MODE_LONG_REAL;
220 } else if (p == M_LONG_LONG_REAL) {
221 return MODE_LONG_LONG_REAL;
222 } else if (p == M_COMPLEX) {
223 return MODE_COMPLEX;
224 } else if (p == M_LONG_COMPLEX) {
225 return MODE_LONG_COMPLEX;
226 } else if (p == M_LONG_LONG_COMPLEX) {
227 return MODE_LONG_LONG_COMPLEX;
228 } else if (p == M_BOOL) {
229 return MODE_BOOL;
230 } else if (p == M_CHAR) {
231 return MODE_CHAR;
232 } else if (p == M_BITS) {
233 return MODE_BITS;
234 } else if (p == M_LONG_BITS) {
235 return MODE_LONG_BITS;
236 } else if (p == M_LONG_LONG_BITS) {
237 return MODE_LONG_LONG_BITS;
238 } else if (p == M_BYTES) {
239 return MODE_BYTES;
240 } else if (p == M_LONG_BYTES) {
241 return MODE_LONG_BYTES;
242 } else if (p == M_FILE) {
243 return MODE_FILE;
244 } else if (p == M_FORMAT) {
245 return MODE_FORMAT;
246 } else if (p == M_PIPE) {
247 return MODE_PIPE;
248 } else if (p == M_SOUND) {
249 return MODE_SOUND;
250 } else {
251 return MODE_NO_CHECK;
252 }
253 }
254
255 //! @brief Perform tasks before interpretation.
256
257 void genie_preprocess (NODE_T * p, int *max_lev, void *compile_plugin)
258 {
259 #if defined (BUILD_A68_COMPILER)
260 static char *last_compile_name = NO_TEXT;
261 static PROP_PROC *last_compile_unit = NO_PPROC;
262 #endif
263 for (; p != NO_NODE; FORWARD (p)) {
264 if (STATUS_TEST (p, BREAKPOINT_MASK)) {
265 if (!(STATUS_TEST (p, INTERRUPTIBLE_MASK))) {
266 STATUS_CLEAR (p, BREAKPOINT_MASK);
267 }
268 }
269 if (GINFO (p) != NO_GINFO) {
270 IS_COERCION (GINFO (p)) = is_coercion (p);
271 IS_NEW_LEXICAL_LEVEL (GINFO (p)) = is_new_lexical_level (p);
272 // The default.
273 UNIT (&GPROP (p)) = genie_unit;
274 SOURCE (&GPROP (p)) = p;
275 #if defined (BUILD_A68_COMPILER)
276 if (OPTION_OPT_LEVEL (&A68_JOB) > 0 && COMPILE_NAME (GINFO (p)) != NO_TEXT && compile_plugin != NULL) {
277 if (COMPILE_NAME (GINFO (p)) == last_compile_name) {
278 // We copy.
279 UNIT (&GPROP (p)) = last_compile_unit;
280 } else {
281 // We look up.
282 // Next line may provoke a warning even with this POSIX workaround. Tant pis.
283 *(void **) &(UNIT (&GPROP (p))) = dlsym (compile_plugin, COMPILE_NAME (GINFO (p)));
284 ABEND (UNIT (&GPROP (p)) == NULL, ERROR_INTERNAL_CONSISTENCY, dlerror ());
285 last_compile_name = COMPILE_NAME (GINFO (p));
286 last_compile_unit = UNIT (&GPROP (p));
287 }
288 }
289 #endif
290 }
291 if (MOID (p) != NO_MOID) {
292 SIZE (MOID (p)) = moid_size (MOID (p));
293 DIGITS (MOID (p)) = moid_digits (MOID (p));
294 SHORT_ID (MOID (p)) = mode_attribute (MOID (p));
295 if (GINFO (p) != NO_GINFO) {
296 NEED_DNS (GINFO (p)) = A68_FALSE;
297 if (IS_REF (MOID (p))) {
298 NEED_DNS (GINFO (p)) = A68_TRUE;
299 } else if (IS (MOID (p), PROC_SYMBOL)) {
300 NEED_DNS (GINFO (p)) = A68_TRUE;
301 } else if (IS (MOID (p), FORMAT_SYMBOL)) {
302 NEED_DNS (GINFO (p)) = A68_TRUE;
303 }
304 }
305 }
306 if (TABLE (p) != NO_TABLE) {
307 if (LEX_LEVEL (p) > *max_lev) {
308 *max_lev = LEX_LEVEL (p);
309 }
310 }
311 if (IS (p, FORMAT_TEXT)) {
312 TAG_T *q = TAX (p);
313 if (q != NO_TAG && NODE (q) != NO_NODE) {
314 NODE (q) = p;
315 }
316 } else if (IS (p, DEFINING_IDENTIFIER)) {
317 TAG_T *q = TAX (p);
318 if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
319 LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
320 }
321 } else if (IS (p, IDENTIFIER)) {
322 TAG_T *q = TAX (p);
323 if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
324 LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
325 OFFSET (GINFO (p)) = &(A68_STACK[FRAME_INFO_SIZE + OFFSET (q)]);
326 }
327 } else if (IS (p, OPERATOR)) {
328 TAG_T *q = TAX (p);
329 if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) {
330 LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q));
331 OFFSET (GINFO (p)) = &(A68_STACK[FRAME_INFO_SIZE + OFFSET (q)]);
332 }
333 }
334 if (SUB (p) != NO_NODE) {
335 if (GINFO (p) != NO_GINFO) {
336 GPARENT (SUB (p)) = p;
337 }
338 genie_preprocess (SUB (p), max_lev, compile_plugin);
339 }
340 }
341 }
342
343 //! @brief Get outermost lexical level in the user program.
344
345 void get_global_level (NODE_T * p)
346 {
347 for (; p != NO_NODE; FORWARD (p)) {
348 if (LINE_NUMBER (p) != 0 && IS (p, UNIT)) {
349 if (LEX_LEVEL (p) < A68 (global_level)) {
350 A68 (global_level) = LEX_LEVEL (p);
351 }
352 }
353 get_global_level (SUB (p));
354 }
355 }
356
357 //! @brief Driver for the interpreter.
358
359 void genie (void *compile_plugin)
360 {
361 MOID_T *m;
362 // Fill in final info for modes.
363 for (m = TOP_MOID (&A68_JOB); m != NO_MOID; FORWARD (m)) {
364 SIZE (m) = moid_size (m);
365 DIGITS (m) = moid_digits (m);
366 SHORT_ID (m) = mode_attribute (m);
367 }
368 // Preprocessing.
369 A68 (max_lex_lvl) = 0;
370 // genie_lex_levels (TOP_NODE (&A68_JOB), 1);.
371 genie_preprocess (TOP_NODE (&A68_JOB), &A68 (max_lex_lvl), compile_plugin);
372 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_FALSE);
373 A68_MON (watchpoint_expression) = NO_TEXT;
374 A68 (frame_stack_limit) = A68 (frame_end) - A68 (storage_overhead);
375 A68 (expr_stack_limit) = A68 (stack_end) - A68 (storage_overhead);
376 if (OPTION_REGRESSION_TEST (&A68_JOB)) {
377 init_rng (1);
378 } else {
379 genie_init_rng ();
380 }
381 io_close_tty_line ();
382 if (OPTION_TRACE (&A68_JOB)) {
383 ASSERT (snprintf (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);
384 WRITE (STDOUT_FILENO, A68 (output_line));
385 }
386 install_signal_handlers ();
387 set_default_event_procedure (&A68 (on_gc_event));
388 A68 (do_confirm_exit) = A68_TRUE;
389 #if defined (BUILD_PARALLEL_CLAUSE)
390 ASSERT (pthread_mutex_init (&A68_PAR (unit_sema), NULL) == 0);
391 #endif
392 // Dive into the program.
393 if (setjmp (A68 (genie_exit_label)) == 0) {
394 NODE_T *p = SUB (TOP_NODE (&A68_JOB));
395 // If we are to stop in the monitor, set a breakpoint on the first unit.
396 if (OPTION_DEBUG (&A68_JOB)) {
397 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_TEMPORARY_MASK, A68_TRUE);
398 WRITE (STDOUT_FILENO, "Execution begins ...");
399 }
400 errno = 0;
401 A68 (ret_code) = 0;
402 A68 (global_level) = INT_MAX;
403 A68_GLOBALS = 0;
404 get_global_level (p);
405 A68_FP = A68 (frame_start);
406 A68_SP = A68 (stack_start);
407 FRAME_DYNAMIC_LINK (A68_FP) = 0;
408 FRAME_DNS (A68_FP) = 0;
409 FRAME_STATIC_LINK (A68_FP) = 0;
410 FRAME_NUMBER (A68_FP) = 0;
411 FRAME_TREE (A68_FP) = (NODE_T *) p;
412 FRAME_LEXICAL_LEVEL (A68_FP) = LEX_LEVEL (p);
413 FRAME_PARAMETER_LEVEL (A68_FP) = LEX_LEVEL (p);
414 FRAME_PARAMETERS (A68_FP) = A68_FP;
415 initialise_frame (p);
416 genie_init_heap (p);
417 genie_init_transput (TOP_NODE (&A68_JOB));
418 A68 (cputime_0) = seconds ();
419 // Here we go ...
420 A68 (in_execution) = A68_TRUE;
421 A68 (f_entry) = TOP_NODE (&A68_JOB);
422 #if defined (BUILD_UNIX)
423 (void) alarm (1);
424 #endif
425 if (OPTION_TRACE (&A68_JOB)) {
426 WIS (TOP_NODE (&A68_JOB));
427 }
428 (void) genie_enclosed (TOP_NODE (&A68_JOB));
429 } else {
430 // Here we have jumped out of the interpreter. What happened?.
431 if (OPTION_DEBUG (&A68_JOB)) {
432 WRITE (STDOUT_FILENO, "Execution discontinued");
433 }
434 if (A68 (ret_code) == A68_RERUN) {
435 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_RUNTIME_ERROR);
436 genie (compile_plugin);
437 } else if (A68 (ret_code) == A68_RUNTIME_ERROR) {
438 if (OPTION_BACKTRACE (&A68_JOB)) {
439 int printed = 0;
440 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0);
441 WRITE (STDOUT_FILENO, A68 (output_line));
442 stack_dump (STDOUT_FILENO, A68_FP, 16, &printed);
443 WRITE (STDOUT_FILENO, NEWLINE_STRING);
444 }
445 if (FILE_LISTING_OPENED (&A68_JOB)) {
446 int printed = 0;
447 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "\nStack backtrace") >= 0);
448 WRITE (FILE_LISTING_FD (&A68_JOB), A68 (output_line));
449 stack_dump (FILE_LISTING_FD (&A68_JOB), A68_FP, 32, &printed);
450 }
451 }
452 }
453 A68 (in_execution) = A68_FALSE;
454 }
455
456 // This file contains interpreter ("genie") routines related to executing primitive
457 // A68 actions.
458 //
459 // The genie is self-optimising as when it traverses the tree, it stores terminals
460 // it ends up in at the root where traversing for that terminal started.
461 // Such piece of information is called a PROP.
462
463 //! @brief Shows line where 'p' is at and draws a '-' beneath the position.
464
465 void where_in_source (FILE_T f, NODE_T * p)
466 {
467 write_source_line (f, LINE (INFO (p)), p, A68_NO_DIAGNOSTICS);
468 }
469
470 // Since Algol 68 can pass procedures as parameters, we use static links rather
471 // than a display.
472
473 //! @brief Initialise PROC and OP identities.
474
475 void genie_init_proc_op (NODE_T * p, NODE_T ** seq, int *count)
476 {
477 for (; p != NO_NODE; FORWARD (p)) {
478 switch (ATTRIBUTE (p)) {
479 case OP_SYMBOL:
480 case PROC_SYMBOL:
481 case OPERATOR_PLAN:
482 case DECLARER:
483 {
484 break;
485 }
486 case DEFINING_IDENTIFIER:
487 case DEFINING_OPERATOR:
488 {
489 // Store position so we need not search again.
490 NODE_T *save = *seq;
491 (*seq) = p;
492 SEQUENCE (*seq) = save;
493 (*count)++;
494 return;
495 }
496 default:
497 {
498 genie_init_proc_op (SUB (p), seq, count);
499 break;
500 }
501 }
502 }
503 }
504
505 //! @brief Initialise PROC and OP identity declarations.
506
507 void genie_find_proc_op (NODE_T * p, int *count)
508 {
509 for (; p != NO_NODE; FORWARD (p)) {
510 if (GINFO (p) != NO_GINFO && IS_NEW_LEXICAL_LEVEL (GINFO (p))) {
511 // Don't enter a new lexical level - it will have its own initialisation.
512 return;
513 } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) {
514 genie_init_proc_op (SUB (p), &(SEQUENCE (TABLE (p))), count);
515 return;
516 } else {
517 genie_find_proc_op (SUB (p), count);
518 }
519 }
520 }
521
522 //! @brief Initialise stack frame.
523
524 void initialise_frame (NODE_T * p)
525 {
526 if (INITIALISE_ANON (TABLE (p))) {
527 TAG_T *_a_;
528 INITIALISE_ANON (TABLE (p)) = A68_FALSE;
529 for (_a_ = ANONYMOUS (TABLE (p)); _a_ != NO_TAG; FORWARD (_a_)) {
530 if (PRIO (_a_) == ROUTINE_TEXT) {
531 int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_)));
532 A68_PROCEDURE *_z_ = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (_a_)));
533 STATUS (_z_) = INIT_MASK;
534 NODE (&(BODY (_z_))) = NODE (_a_);
535 if (youngest > 0) {
536 STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest);
537 } else {
538 ENVIRON (_z_) = 0;
539 }
540 LOCALE (_z_) = NO_HANDLE;
541 MOID (_z_) = MOID (_a_);
542 INITIALISE_ANON (TABLE (p)) = A68_TRUE;
543 } else if (PRIO (_a_) == FORMAT_TEXT) {
544 int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_)));
545 A68_FORMAT *_z_ = (A68_FORMAT *) (FRAME_OBJECT (OFFSET (_a_)));
546 STATUS (_z_) = INIT_MASK;
547 BODY (_z_) = NODE (_a_);
548 if (youngest > 0) {
549 STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest);
550 } else {
551 ENVIRON (_z_) = 0;
552 }
553 INITIALISE_ANON (TABLE (p)) = A68_TRUE;
554 }
555 }
556 }
557 if (PROC_OPS (TABLE (p))) {
558 NODE_T *_q_;
559 if (SEQUENCE (TABLE (p)) == NO_NODE) {
560 int count = 0;
561 genie_find_proc_op (p, &count);
562 PROC_OPS (TABLE (p)) = (BOOL_T) (count > 0);
563 }
564 for (_q_ = SEQUENCE (TABLE (p)); _q_ != NO_NODE; _q_ = SEQUENCE (_q_)) {
565 NODE_T *u = NEXT_NEXT (_q_);
566 if (IS (u, ROUTINE_TEXT)) {
567 NODE_T *src = SOURCE (&(GPROP (u)));
568 *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src))));
569 } else if ((IS (u, UNIT) && IS (SUB (u), ROUTINE_TEXT))) {
570 NODE_T *src = SOURCE (&(GPROP (SUB (u))));
571 *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src))));
572 }
573 }
574 }
575 INITIALISE_FRAME (TABLE (p)) = (BOOL_T) (INITIALISE_ANON (TABLE (p)) || PROC_OPS (TABLE (p)));
576 }
577
578 //! @brief Whether item at "w" of mode "q" is initialised.
579
580 void genie_check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q)
581 {
582 switch (SHORT_ID (q)) {
583 case REF_SYMBOL:
584 {
585 A68_REF *z = (A68_REF *) w;
586 CHECK_INIT (p, INITIALISED (z), q);
587 return;
588 }
589 case PROC_SYMBOL:
590 {
591 A68_PROCEDURE *z = (A68_PROCEDURE *) w;
592 CHECK_INIT (p, INITIALISED (z), q);
593 return;
594 }
595 case MODE_INT:
596 {
597 A68_INT *z = (A68_INT *) w;
598 CHECK_INIT (p, INITIALISED (z), q);
599 return;
600 }
601 case MODE_REAL:
602 {
603 A68_REAL *z = (A68_REAL *) w;
604 CHECK_INIT (p, INITIALISED (z), q);
605 return;
606 }
607 case MODE_COMPLEX:
608 {
609 A68_REAL *r = (A68_REAL *) w;
610 A68_REAL *i = (A68_REAL *) (w + SIZE_ALIGNED (A68_REAL));
611 CHECK_INIT (p, INITIALISED (r), q);
612 CHECK_INIT (p, INITIALISED (i), q);
613 return;
614 }
615 #if (A68_LEVEL >= 3)
616 case MODE_LONG_INT:
617 case MODE_LONG_REAL:
618 case MODE_LONG_BITS:
619 {
620 A68_DOUBLE *z = (A68_DOUBLE *) w;
621 CHECK_INIT (p, INITIALISED (z), q);
622 return;
623 }
624 case MODE_LONG_COMPLEX:
625 {
626 A68_LONG_REAL *r = (A68_LONG_REAL *) w;
627 A68_LONG_REAL *i = (A68_LONG_REAL *) (w + SIZE_ALIGNED (A68_LONG_REAL));
628 CHECK_INIT (p, INITIALISED (r), q);
629 CHECK_INIT (p, INITIALISED (i), q);
630 return;
631 }
632 case MODE_LONG_LONG_INT:
633 case MODE_LONG_LONG_REAL:
634 case MODE_LONG_LONG_BITS:
635 {
636 MP_T *z = (MP_T *) w;
637 CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q);
638 return;
639 }
640 #else
641 case MODE_LONG_INT:
642 case MODE_LONG_LONG_INT:
643 case MODE_LONG_REAL:
644 case MODE_LONG_LONG_REAL:
645 case MODE_LONG_BITS:
646 case MODE_LONG_LONG_BITS:
647 {
648 MP_T *z = (MP_T *) w;
649 CHECK_INIT (p, (unt) MP_STATUS (z) & INIT_MASK, q);
650 return;
651 }
652 case MODE_LONG_COMPLEX:
653 {
654 MP_T *r = (MP_T *) w;
655 MP_T *i = (MP_T *) (w + size_mp ());
656 CHECK_INIT (p, (unt) r[0] & INIT_MASK, q);
657 CHECK_INIT (p, (unt) i[0] & INIT_MASK, q);
658 return;
659 }
660 #endif
661 case MODE_LONG_LONG_COMPLEX:
662 {
663 MP_T *r = (MP_T *) w;
664 MP_T *i = (MP_T *) (w + size_long_mp ());
665 CHECK_INIT (p, (unt) r[0] & INIT_MASK, q);
666 CHECK_INIT (p, (unt) i[0] & INIT_MASK, q);
667 return;
668 }
669 case MODE_BOOL:
670 {
671 A68_BOOL *z = (A68_BOOL *) w;
672 CHECK_INIT (p, INITIALISED (z), q);
673 return;
674 }
675 case MODE_CHAR:
676 {
677 A68_CHAR *z = (A68_CHAR *) w;
678 CHECK_INIT (p, INITIALISED (z), q);
679 return;
680 }
681 case MODE_BITS:
682 {
683 A68_BITS *z = (A68_BITS *) w;
684 CHECK_INIT (p, INITIALISED (z), q);
685 return;
686 }
687 case MODE_BYTES:
688 {
689 A68_BYTES *z = (A68_BYTES *) w;
690 CHECK_INIT (p, INITIALISED (z), q);
691 return;
692 }
693 case MODE_LONG_BYTES:
694 {
695 A68_LONG_BYTES *z = (A68_LONG_BYTES *) w;
696 CHECK_INIT (p, INITIALISED (z), q);
697 return;
698 }
699 case MODE_FILE:
700 {
701 A68_FILE *z = (A68_FILE *) w;
702 CHECK_INIT (p, INITIALISED (z), q);
703 return;
704 }
705 case MODE_FORMAT:
706 {
707 A68_FORMAT *z = (A68_FORMAT *) w;
708 CHECK_INIT (p, INITIALISED (z), q);
709 return;
710 }
711 case MODE_PIPE:
712 {
713 A68_REF *pipe_read = (A68_REF *) w;
714 A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE);
715 A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE);
716 CHECK_INIT (p, INITIALISED (pipe_read), q);
717 CHECK_INIT (p, INITIALISED (pipe_write), q);
718 CHECK_INIT (p, INITIALISED (pid), q);
719 return;
720 }
721 case MODE_SOUND:
722 {
723 A68_SOUND *z = (A68_SOUND *) w;
724 CHECK_INIT (p, INITIALISED (z), q);
725 return;
726 }
727 }
728 }
729
730 //! @brief Push constant stored in the tree.
731
732 PROP_T genie_constant (NODE_T * p)
733 {
734 PUSH (p, CONSTANT (GINFO (p)), SIZE (GINFO (p)));
735 return GPROP (p);
736 }
737
738 //! @brief Push argument units.
739
740 void genie_argument (NODE_T * p, NODE_T ** seq)
741 {
742 for (; p != NO_NODE; FORWARD (p)) {
743 if (IS (p, UNIT)) {
744 EXECUTE_UNIT (p);
745 STACK_DNS (p, MOID (p), A68_FP);
746 SEQUENCE (*seq) = p;
747 (*seq) = p;
748 return;
749 } else if (IS (p, TRIMMER)) {
750 return;
751 } else {
752 genie_argument (SUB (p), seq);
753 }
754 }
755 }
756
757 //! @brief Evaluate partial call.
758
759 void genie_partial_call (NODE_T * p, MOID_T * pr_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE z, ADDR_T pop_sp, ADDR_T pop_fp)
760 {
761 int voids = 0;
762 BYTE_T *u, *v;
763 PACK_T *s, *t;
764 A68_REF ref;
765 A68_HANDLE *loc;
766 // Get locale for the new procedure descriptor. Copy is necessary.
767 if (LOCALE (&z) == NO_HANDLE) {
768 int size = 0;
769 for (s = PACK (pr_mode); s != NO_PACK; FORWARD (s)) {
770 size += (SIZE (M_BOOL) + SIZE (MOID (s)));
771 }
772 ref = heap_generator (p, pr_mode, size);
773 loc = REF_HANDLE (&ref);
774 } else {
775 int size = SIZE (LOCALE (&z));
776 ref = heap_generator (p, pr_mode, size);
777 loc = REF_HANDLE (&ref);
778 COPY (POINTER (loc), POINTER (LOCALE (&z)), size);
779 }
780 // Move arguments from stack to locale using pmap.
781 u = POINTER (loc);
782 s = PACK (pr_mode);
783 v = STACK_ADDRESS (pop_sp);
784 t = PACK (pmap);
785 for (; t != NO_PACK && s != NO_PACK; FORWARD (t)) {
786 // Skip already initialised arguments.
787 while (u != NULL && VALUE ((A68_BOOL *) & u[0])) {
788 u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
789 FORWARD (s);
790 }
791 if (u != NULL && MOID (t) == M_VOID) {
792 // Move to next field in locale.
793 voids++;
794 u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
795 FORWARD (s);
796 } else {
797 // Move argument from stack to locale.
798 A68_BOOL w;
799 STATUS (&w) = INIT_MASK;
800 VALUE (&w) = A68_TRUE;
801 *(A68_BOOL *) & u[0] = w;
802 COPY (&(u[SIZE (M_BOOL)]), v, SIZE (MOID (t)));
803 u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
804 v = &(v[SIZE (MOID (t))]);
805 FORWARD (s);
806 }
807 }
808 A68_SP = pop_sp;
809 LOCALE (&z) = loc;
810 // Is closure complete?.
811 if (voids == 0) {
812 // Closure is complete. Push locale onto the stack and call procedure body.
813 A68_SP = pop_sp;
814 u = POINTER (loc);
815 v = STACK_ADDRESS (A68_SP);
816 s = PACK (pr_mode);
817 for (; s != NO_PACK; FORWARD (s)) {
818 int size = SIZE (MOID (s));
819 COPY (v, &u[SIZE (M_BOOL)], size);
820 u = &(u[SIZE (M_BOOL) + size]);
821 v = &(v[SIZE (MOID (s))]);
822 INCREMENT_STACK_POINTER (p, size);
823 }
824 genie_call_procedure (p, pr_mode, pproc, M_VOID, &z, pop_sp, pop_fp);
825 } else {
826 // Closure is not complete. Return procedure body.
827 PUSH_PROCEDURE (p, z);
828 }
829 }
830
831 //! @brief Closure and deproceduring of routines with PARAMSETY.
832
833 void genie_call_procedure (NODE_T * p, MOID_T * pr_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE * z, ADDR_T pop_sp, ADDR_T pop_fp)
834 {
835 if (pmap != M_VOID && pr_mode != pmap) {
836 genie_partial_call (p, pr_mode, pproc, pmap, *z, pop_sp, pop_fp);
837 } else if (STATUS (z) & STANDENV_PROC_MASK) {
838 (void) ((*(PROCEDURE (&(BODY (z))))) (p));
839 } else if (STATUS (z) & SKIP_PROCEDURE_MASK) {
840 A68_SP = pop_sp;
841 genie_push_undefined (p, SUB ((MOID (z))));
842 } else {
843 NODE_T *body = NODE (&(BODY (z)));
844 if (IS (body, ROUTINE_TEXT)) {
845 NODE_T *entry = SUB (body);
846 PACK_T *args = PACK (pr_mode);
847 ADDR_T fp0 = 0;
848 // Copy arguments from stack to frame.
849 OPEN_PROC_FRAME (entry, ENVIRON (z));
850 INIT_STATIC_FRAME (entry);
851 FRAME_DNS (A68_FP) = pop_fp;
852 for (; args != NO_PACK; FORWARD (args)) {
853 int size = SIZE (MOID (args));
854 COPY ((FRAME_OBJECT (fp0)), STACK_ADDRESS (pop_sp + fp0), size);
855 fp0 += size;
856 }
857 A68_SP = pop_sp;
858 ARGSIZE (GINFO (p)) = fp0;
859 // Interpret routine text.
860 if (DIM (pr_mode) > 0) {
861 // With PARAMETERS.
862 entry = NEXT (NEXT_NEXT (entry));
863 } else {
864 // Without PARAMETERS.
865 entry = NEXT_NEXT (entry);
866 }
867 EXECUTE_UNIT_TRACE (entry);
868 if (A68_FP == A68_MON (finish_frame_pointer)) {
869 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
870 }
871 CLOSE_FRAME;
872 STACK_DNS (p, SUB (pr_mode), A68_FP);
873 } else {
874 OPEN_PROC_FRAME (body, ENVIRON (z));
875 INIT_STATIC_FRAME (body);
876 FRAME_DNS (A68_FP) = pop_fp;
877 EXECUTE_UNIT_TRACE (body);
878 if (A68_FP == A68_MON (finish_frame_pointer)) {
879 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
880 }
881 CLOSE_FRAME;
882 STACK_DNS (p, SUB (pr_mode), A68_FP);
883 }
884 }
885 }
886
887 //! @brief Call event routine.
888
889 void genie_call_event_routine (NODE_T * p, MOID_T * m, A68_PROCEDURE * proc, ADDR_T pop_sp, ADDR_T pop_fp)
890 {
891 if (NODE (&(BODY (proc))) != NO_NODE) {
892 A68_PROCEDURE save = *proc;
893 set_default_event_procedure (proc);
894 genie_call_procedure (p, MOID (&save), m, m, &save, pop_sp, pop_fp);
895 (*proc) = save;
896 }
897 }
898
899 //! @brief Call PROC with arguments and push result.
900
901 PROP_T genie_call_standenv_quick (NODE_T * p)
902 {
903 NODE_T *pr = SUB (p), *q = SEQUENCE (p);
904 TAG_T *proc = TAX (SOURCE (&GPROP (pr)));
905 // Get arguments.
906 for (; q != NO_NODE; q = SEQUENCE (q)) {
907 EXECUTE_UNIT (q);
908 STACK_DNS (p, MOID (q), A68_FP);
909 }
910 (void) ((*(PROCEDURE (proc))) (p));
911 return GPROP (p);
912 }
913
914 //! @brief Call PROC with arguments and push result.
915
916 PROP_T genie_call_quick (NODE_T * p)
917 {
918 A68_PROCEDURE z;
919 NODE_T *proc = SUB (p);
920 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
921 // Get procedure.
922 EXECUTE_UNIT (proc);
923 POP_OBJECT (proc, &z, A68_PROCEDURE);
924 genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
925 // Get arguments.
926 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
927 NODE_T top_seq;
928 NODE_T *seq = &top_seq;
929 GINFO_T g;
930 GINFO (&top_seq) = &g;
931 genie_argument (NEXT (proc), &seq);
932 SEQUENCE (p) = SEQUENCE (&top_seq);
933 STATUS_SET (p, SEQUENCE_MASK);
934 } else {
935 NODE_T *q = SEQUENCE (p);
936 for (; q != NO_NODE; q = SEQUENCE (q)) {
937 EXECUTE_UNIT (q);
938 STACK_DNS (p, MOID (q), A68_FP);
939 }
940 }
941 genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
942 return GPROP (p);
943 }
944
945 //! @brief Call PROC with arguments and push result.
946
947 PROP_T genie_call (NODE_T * p)
948 {
949 PROP_T self;
950 A68_PROCEDURE z;
951 NODE_T *proc = SUB (p);
952 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
953 UNIT (&self) = genie_call_quick;
954 SOURCE (&self) = p;
955 // Get procedure.
956 EXECUTE_UNIT (proc);
957 POP_OBJECT (proc, &z, A68_PROCEDURE);
958 genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
959 // Get arguments.
960 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
961 NODE_T top_seq;
962 NODE_T *seq = &top_seq;
963 GINFO_T g;
964 GINFO (&top_seq) = &g;
965 genie_argument (NEXT (proc), &seq);
966 SEQUENCE (p) = SEQUENCE (&top_seq);
967 STATUS_SET (p, SEQUENCE_MASK);
968 } else {
969 NODE_T *q = SEQUENCE (p);
970 for (; q != NO_NODE; q = SEQUENCE (q)) {
971 EXECUTE_UNIT (q);
972 }
973 }
974 genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
975 if (PARTIAL_LOCALE (GINFO (proc)) != M_VOID && MOID (&z) != PARTIAL_LOCALE (GINFO (proc))) {
976 ;
977 } else if (STATUS (&z) & STANDENV_PROC_MASK) {
978 if (UNIT (&GPROP (proc)) == genie_identifier_standenv_proc) {
979 UNIT (&self) = genie_call_standenv_quick;
980 }
981 }
982 return self;
983 }
984
985 //! @brief Push value of denotation.
986
987 PROP_T genie_denotation (NODE_T * p)
988 {
989 MOID_T *moid = MOID (p);
990 PROP_T self;
991 UNIT (&self) = genie_denotation;
992 SOURCE (&self) = p;
993 if (moid == M_INT) {
994 // INT denotation.
995 A68_INT z;
996 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
997 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
998 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
999 exit_genie (p, A68_RUNTIME_ERROR);
1000 }
1001 UNIT (&self) = genie_constant;
1002 STATUS (&z) = INIT_MASK;
1003 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE (M_INT));
1004 SIZE (GINFO (p)) = SIZE (M_INT);
1005 COPY (CONSTANT (GINFO (p)), &z, SIZE (M_INT));
1006 PUSH_VALUE (p, VALUE ((A68_INT *) (CONSTANT (GINFO (p)))), A68_INT);
1007 return self;
1008 }
1009 if (moid == M_REAL) {
1010 // REAL denotation.
1011 A68_REAL z;
1012 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
1013 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1014 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1015 exit_genie (p, A68_RUNTIME_ERROR);
1016 }
1017 STATUS (&z) = INIT_MASK;
1018 UNIT (&self) = genie_constant;
1019 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_REAL));
1020 SIZE (GINFO (p)) = SIZE_ALIGNED (A68_REAL);
1021 COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_REAL));
1022 PUSH_VALUE (p, VALUE ((A68_REAL *) (CONSTANT (GINFO (p)))), A68_REAL);
1023 return self;
1024 }
1025 #if (A68_LEVEL >= 3)
1026 if (moid == M_LONG_INT) {
1027 // LONG INT denotation.
1028 A68_LONG_INT z;
1029 size_t len = (size_t) SIZE_ALIGNED (A68_LONG_INT);
1030 NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
1031 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1032 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1033 exit_genie (p, A68_RUNTIME_ERROR);
1034 }
1035 UNIT (&self) = genie_constant;
1036 STATUS (&z) = INIT_MASK;
1037 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) len);
1038 SIZE (GINFO (p)) = len;
1039 COPY (CONSTANT (GINFO (p)), &z, len);
1040 PUSH_VALUE (p, VALUE ((A68_LONG_INT *) (CONSTANT (GINFO (p)))), A68_LONG_INT);
1041 return self;
1042 }
1043 if (moid == M_LONG_REAL) {
1044 // LONG REAL denotation.
1045 A68_LONG_REAL z;
1046 NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
1047 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1048 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1049 exit_genie (p, A68_RUNTIME_ERROR);
1050 }
1051 STATUS (&z) = INIT_MASK;
1052 UNIT (&self) = genie_constant;
1053 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_LONG_REAL));
1054 SIZE (GINFO (p)) = SIZE_ALIGNED (A68_LONG_REAL);
1055 COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_LONG_REAL));
1056 PUSH_VALUE (p, VALUE ((A68_LONG_REAL *) (CONSTANT (GINFO (p)))), A68_LONG_REAL);
1057 return self;
1058 }
1059 // LONG BITS denotation.
1060 if (moid == M_LONG_BITS) {
1061 A68_LONG_BITS z;
1062 NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p);
1063 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1064 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1065 exit_genie (p, A68_RUNTIME_ERROR);
1066 }
1067 UNIT (&self) = genie_constant;
1068 STATUS (&z) = INIT_MASK;
1069 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_LONG_BITS));
1070 SIZE (GINFO (p)) = SIZE_ALIGNED (A68_LONG_BITS);
1071 COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_LONG_BITS));
1072 PUSH_VALUE (p, VALUE ((A68_LONG_BITS *) (CONSTANT (GINFO (p)))), A68_LONG_BITS);
1073 return self;
1074 }
1075 #endif
1076 if (moid == M_LONG_INT || moid == M_LONG_LONG_INT) {
1077 // [LONG] LONG INT denotation.
1078 int digits = DIGITS (moid);
1079 int size = SIZE (moid);
1080 NODE_T *number;
1081 if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
1082 number = NEXT_SUB (p);
1083 } else {
1084 number = SUB (p);
1085 }
1086 MP_T *z = nil_mp (p, digits);
1087 if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
1088 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1089 exit_genie (p, A68_RUNTIME_ERROR);
1090 }
1091 MP_STATUS (z) = (MP_T) INIT_MASK;
1092 UNIT (&self) = genie_constant;
1093 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
1094 SIZE (GINFO (p)) = size;
1095 COPY (CONSTANT (GINFO (p)), z, size);
1096 return self;
1097 }
1098 if (moid == M_LONG_REAL || moid == M_LONG_LONG_REAL) {
1099 // [LONG] LONG REAL denotation.
1100 int digits = DIGITS (moid);
1101 int size = SIZE (moid);
1102 NODE_T *number;
1103 if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
1104 number = NEXT_SUB (p);
1105 } else {
1106 number = SUB (p);
1107 }
1108 MP_T *z = nil_mp (p, digits);
1109 if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
1110 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1111 exit_genie (p, A68_RUNTIME_ERROR);
1112 }
1113 MP_STATUS (z) = (MP_T) INIT_MASK;
1114 UNIT (&self) = genie_constant;
1115 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
1116 SIZE (GINFO (p)) = size;
1117 COPY (CONSTANT (GINFO (p)), z, size);
1118 return self;
1119 }
1120 if (moid == M_BITS) {
1121 // BITS denotation.
1122 A68_BITS z;
1123 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
1124 if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
1125 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1126 exit_genie (p, A68_RUNTIME_ERROR);
1127 }
1128 UNIT (&self) = genie_constant;
1129 STATUS (&z) = INIT_MASK;
1130 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_ALIGNED (A68_BITS));
1131 SIZE (GINFO (p)) = SIZE_ALIGNED (A68_BITS);
1132 COPY (CONSTANT (GINFO (p)), &z, SIZE_ALIGNED (A68_BITS));
1133 PUSH_VALUE (p, VALUE ((A68_BITS *) (CONSTANT (GINFO (p)))), A68_BITS);
1134 }
1135 if (moid == M_LONG_BITS || moid == M_LONG_LONG_BITS) {
1136 // [LONG] LONG BITS denotation.
1137 int digits = DIGITS (moid);
1138 int size = SIZE (moid);
1139 NODE_T *number;
1140 if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) {
1141 number = NEXT_SUB (p);
1142 } else {
1143 number = SUB (p);
1144 }
1145 MP_T *z = nil_mp (p, digits);
1146 if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) {
1147 diagnostic (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid);
1148 exit_genie (p, A68_RUNTIME_ERROR);
1149 }
1150 MP_STATUS (z) = (MP_T) INIT_MASK;
1151 UNIT (&self) = genie_constant;
1152 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
1153 SIZE (GINFO (p)) = size;
1154 COPY (CONSTANT (GINFO (p)), z, size);
1155 return self;
1156 }
1157 if (moid == M_BOOL) {
1158 // BOOL denotation.
1159 A68_BOOL z;
1160 ASSERT (genie_string_to_value_internal (p, M_BOOL, NSYMBOL (p), (BYTE_T *) & z) == A68_TRUE);
1161 PUSH_VALUE (p, VALUE (&z), A68_BOOL);
1162 return self;
1163 } else if (moid == M_CHAR) {
1164 // CHAR denotation.
1165 PUSH_VALUE (p, TO_UCHAR (NSYMBOL (p)[0]), A68_CHAR);
1166 return self;
1167 } else if (moid == M_ROW_CHAR) {
1168 // [] CHAR denotation - permanent string in the heap.
1169 A68_REF z;
1170 A68_ARRAY *arr;
1171 A68_TUPLE *tup;
1172 z = c_to_a_string (p, NSYMBOL (p), DEFAULT_WIDTH);
1173 GET_DESCRIPTOR (arr, tup, &z);
1174 BLOCK_GC_HANDLE (&z);
1175 BLOCK_GC_HANDLE (&(ARRAY (arr)));
1176 UNIT (&self) = genie_constant;
1177 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) A68_REF_SIZE);
1178 SIZE (GINFO (p)) = A68_REF_SIZE;
1179 COPY (CONSTANT (GINFO (p)), &z, A68_REF_SIZE);
1180 PUSH_REF (p, *(A68_REF *) (CONSTANT (GINFO (p))));
1181 (void) tup;
1182 return self;
1183 }
1184 if (moid == M_VOID) {
1185 // VOID denotation: EMPTY.
1186 return self;
1187 }
1188 // ?.
1189 return self;
1190 }
1191
1192 //! @brief Push a local identifier.
1193
1194 PROP_T genie_frame_identifier (NODE_T * p)
1195 {
1196 BYTE_T *z;
1197 FRAME_GET (z, BYTE_T, p);
1198 PUSH (p, z, SIZE (MOID (p)));
1199 return GPROP (p);
1200 }
1201
1202 //! @brief Push standard environ routine as PROC.
1203
1204 PROP_T genie_identifier_standenv_proc (NODE_T * p)
1205 {
1206 A68_PROCEDURE z;
1207 TAG_T *q = TAX (p);
1208 STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | STANDENV_PROC_MASK);
1209 PROCEDURE (&(BODY (&z))) = PROCEDURE (q);
1210 ENVIRON (&z) = 0;
1211 LOCALE (&z) = NO_HANDLE;
1212 MOID (&z) = MOID (p);
1213 PUSH_PROCEDURE (p, z);
1214 return GPROP (p);
1215 }
1216
1217 //! @brief (optimised) push identifier from standard environ
1218
1219 PROP_T genie_identifier_standenv (NODE_T * p)
1220 {
1221 (void) ((*(PROCEDURE (TAX (p)))) (p));
1222 return GPROP (p);
1223 }
1224
1225 //! @brief Push identifier onto the stack.
1226
1227 PROP_T genie_identifier (NODE_T * p)
1228 {
1229 static PROP_T self;
1230 TAG_T *q = TAX (p);
1231 SOURCE (&self) = p;
1232 if (A68_STANDENV_PROC (q)) {
1233 if (IS (MOID (q), PROC_SYMBOL)) {
1234 (void) genie_identifier_standenv_proc (p);
1235 UNIT (&self) = genie_identifier_standenv_proc;
1236 } else {
1237 (void) genie_identifier_standenv (p);
1238 UNIT (&self) = genie_identifier_standenv;
1239 }
1240 } else if (STATUS_TEST (q, CONSTANT_MASK)) {
1241 int size = SIZE (MOID (p));
1242 BYTE_T *sp_0 = STACK_TOP;
1243 (void) genie_frame_identifier (p);
1244 CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size);
1245 SIZE (GINFO (p)) = size;
1246 COPY (CONSTANT (GINFO (p)), (void *) sp_0, size);
1247 UNIT (&self) = genie_constant;
1248 } else {
1249 (void) genie_frame_identifier (p);
1250 UNIT (&self) = genie_frame_identifier;
1251 }
1252 return self;
1253 }
1254
1255 //! @brief Push result of cast (coercions are deeper in the tree).
1256
1257 PROP_T genie_cast (NODE_T * p)
1258 {
1259 PROP_T self;
1260 EXECUTE_UNIT (NEXT_SUB (p));
1261 UNIT (&self) = genie_cast;
1262 SOURCE (&self) = p;
1263 return self;
1264 }
1265
1266 //! @brief Execute assertion.
1267
1268 PROP_T genie_assertion (NODE_T * p)
1269 {
1270 PROP_T self;
1271 if (STATUS_TEST (p, ASSERT_MASK)) {
1272 A68_BOOL z;
1273 EXECUTE_UNIT (NEXT_SUB (p));
1274 POP_OBJECT (p, &z, A68_BOOL);
1275 if (VALUE (&z) == A68_FALSE) {
1276 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FALSE_ASSERTION);
1277 exit_genie (p, A68_RUNTIME_ERROR);
1278 }
1279 }
1280 UNIT (&self) = genie_assertion;
1281 SOURCE (&self) = p;
1282 return self;
1283 }
1284
1285 //! @brief Push format text.
1286
1287 PROP_T genie_format_text (NODE_T * p)
1288 {
1289 static PROP_T self;
1290 A68_FORMAT z = *(A68_FORMAT *) (FRAME_OBJECT (OFFSET (TAX (p))));
1291 PUSH_FORMAT (p, z);
1292 UNIT (&self) = genie_format_text;
1293 SOURCE (&self) = p;
1294 return self;
1295 }
1296
1297 //! @brief Call operator.
1298
1299 void genie_call_operator (NODE_T * p, ADDR_T pop_sp)
1300 {
1301 A68_PROCEDURE *z;
1302 ADDR_T pop_fp = A68_FP;
1303 MOID_T *pr_mode = MOID (TAX (p));
1304 FRAME_GET (z, A68_PROCEDURE, p);
1305 genie_call_procedure (p, pr_mode, MOID (z), pr_mode, z, pop_sp, pop_fp);
1306 STACK_DNS (p, SUB (pr_mode), A68_FP);
1307 }
1308
1309 //! @brief Push result of monadic formula OP "u".
1310
1311 PROP_T genie_monadic (NODE_T * p)
1312 {
1313 NODE_T *op = SUB (p);
1314 NODE_T *u = NEXT (op);
1315 PROP_T self;
1316 ADDR_T sp = A68_SP;
1317 EXECUTE_UNIT (u);
1318 STACK_DNS (u, MOID (u), A68_FP);
1319 if (PROCEDURE (TAX (op)) != NO_GPROC) {
1320 (void) ((*(PROCEDURE (TAX (op)))) (op));
1321 } else {
1322 genie_call_operator (op, sp);
1323 }
1324 UNIT (&self) = genie_monadic;
1325 SOURCE (&self) = p;
1326 return self;
1327 }
1328
1329 //! @brief Push result of formula.
1330
1331 PROP_T genie_dyadic_quick (NODE_T * p)
1332 {
1333 NODE_T *u = SUB (p);
1334 NODE_T *op = NEXT (u);
1335 NODE_T *v = NEXT (op);
1336 EXECUTE_UNIT (u);
1337 STACK_DNS (u, MOID (u), A68_FP);
1338 EXECUTE_UNIT (v);
1339 STACK_DNS (v, MOID (v), A68_FP);
1340 (void) ((*(PROCEDURE (TAX (op)))) (op));
1341 return GPROP (p);
1342 }
1343
1344 //! @brief Push result of formula.
1345
1346 PROP_T genie_dyadic (NODE_T * p)
1347 {
1348 NODE_T *u = SUB (p);
1349 NODE_T *op = NEXT (u);
1350 NODE_T *v = NEXT (op);
1351 ADDR_T pop_sp = A68_SP;
1352 EXECUTE_UNIT (u);
1353 STACK_DNS (u, MOID (u), A68_FP);
1354 EXECUTE_UNIT (v);
1355 STACK_DNS (v, MOID (v), A68_FP);
1356 if (PROCEDURE (TAX (op)) != NO_GPROC) {
1357 (void) ((*(PROCEDURE (TAX (op)))) (op));
1358 } else {
1359 genie_call_operator (op, pop_sp);
1360 }
1361 return GPROP (p);
1362 }
1363
1364 //! @brief Push result of formula.
1365
1366 PROP_T genie_formula (NODE_T * p)
1367 {
1368 PROP_T self, lhs, rhs;
1369 NODE_T *u = SUB (p);
1370 NODE_T *op = NEXT (u);
1371 ADDR_T pop_sp = A68_SP;
1372 UNIT (&self) = genie_formula;
1373 SOURCE (&self) = p;
1374 EXECUTE_UNIT_2 (u, lhs);
1375 STACK_DNS (u, MOID (u), A68_FP);
1376 if (op != NO_NODE) {
1377 NODE_T *v = NEXT (op);
1378 GPROC *proc = PROCEDURE (TAX (op));
1379 EXECUTE_UNIT_2 (v, rhs);
1380 STACK_DNS (v, MOID (v), A68_FP);
1381 UNIT (&self) = genie_dyadic;
1382 if (proc != NO_GPROC) {
1383 (void) ((*(proc)) (op));
1384 UNIT (&self) = genie_dyadic_quick;
1385 } else {
1386 genie_call_operator (op, pop_sp);
1387 }
1388 return self;
1389 } else if (UNIT (&lhs) == genie_monadic) {
1390 return lhs;
1391 }
1392 (void) rhs;
1393 return self;
1394 }
1395
1396 //! @brief Push NIL.
1397
1398 PROP_T genie_nihil (NODE_T * p)
1399 {
1400 PROP_T self;
1401 PUSH_REF (p, nil_ref);
1402 UNIT (&self) = genie_nihil;
1403 SOURCE (&self) = p;
1404 return self;
1405 }
1406
1407 //! @brief Assign a value to a name and voiden.
1408
1409 PROP_T genie_voiding_assignation_constant (NODE_T * p)
1410 {
1411 NODE_T *dst = SUB (p);
1412 NODE_T *src = SOURCE (&PROP (GINFO (NEXT_NEXT (dst))));
1413 ADDR_T pop_sp = A68_SP;
1414 A68_REF *z = (A68_REF *) STACK_TOP;
1415 PROP_T self;
1416 UNIT (&self) = genie_voiding_assignation_constant;
1417 SOURCE (&self) = p;
1418 EXECUTE_UNIT (dst);
1419 CHECK_REF (p, *z, MOID (p));
1420 COPY (ADDRESS (z), CONSTANT (GINFO (src)), SIZE (GINFO (src)));
1421 A68_SP = pop_sp;
1422 return self;
1423 }
1424
1425 //! @brief Assign a value to a name and voiden.
1426
1427 PROP_T genie_voiding_assignation (NODE_T * p)
1428 {
1429 NODE_T *dst = SUB (p);
1430 NODE_T *src = NEXT_NEXT (dst);
1431 MOID_T *src_mode = SUB_MOID (dst);
1432 ADDR_T pop_sp = A68_SP, pop_fp = FRAME_DNS (A68_FP);
1433 A68_REF z;
1434 PROP_T self;
1435 UNIT (&self) = genie_voiding_assignation;
1436 SOURCE (&self) = p;
1437 EXECUTE_UNIT (dst);
1438 POP_OBJECT (p, &z, A68_REF);
1439 CHECK_REF (p, z, MOID (p));
1440 FRAME_DNS (A68_FP) = REF_SCOPE (&z);
1441 EXECUTE_UNIT (src);
1442 STACK_DNS (src, src_mode, REF_SCOPE (&z));
1443 FRAME_DNS (A68_FP) = pop_fp;
1444 A68_SP = pop_sp;
1445 if (HAS_ROWS (src_mode)) {
1446 genie_clone_stack (p, src_mode, &z, &z);
1447 } else {
1448 COPY_ALIGNED (ADDRESS (&z), STACK_TOP, SIZE (src_mode));
1449 }
1450 return self;
1451 }
1452
1453 //! @brief Assign a value to a name and push the name.
1454
1455 PROP_T genie_assignation_constant (NODE_T * p)
1456 {
1457 NODE_T *dst = SUB (p);
1458 NODE_T *src = SOURCE (&PROP (GINFO (NEXT_NEXT (dst))));
1459 A68_REF *z = (A68_REF *) STACK_TOP;
1460 PROP_T self;
1461 UNIT (&self) = genie_assignation_constant;
1462 SOURCE (&self) = p;
1463 EXECUTE_UNIT (dst);
1464 CHECK_REF (p, *z, MOID (p));
1465 COPY (ADDRESS (z), CONSTANT (GINFO (src)), SIZE (GINFO (src)));
1466 return self;
1467 }
1468
1469 //! @brief Assign a value to a name and push the name.
1470
1471 PROP_T genie_assignation_quick (NODE_T * p)
1472 {
1473 PROP_T self;
1474 NODE_T *dst = SUB (p);
1475 NODE_T *src = NEXT_NEXT (dst);
1476 MOID_T *src_mode = SUB_MOID (dst);
1477 int size = SIZE (src_mode);
1478 ADDR_T pop_fp = FRAME_DNS (A68_FP);
1479 A68_REF *z = (A68_REF *) STACK_TOP;
1480 EXECUTE_UNIT (dst);
1481 CHECK_REF (p, *z, MOID (p));
1482 FRAME_DNS (A68_FP) = REF_SCOPE (z);
1483 EXECUTE_UNIT (src);
1484 STACK_DNS (src, src_mode, REF_SCOPE (z));
1485 FRAME_DNS (A68_FP) = pop_fp;
1486 DECREMENT_STACK_POINTER (p, size);
1487 if (HAS_ROWS (src_mode)) {
1488 genie_clone_stack (p, src_mode, z, z);
1489 } else {
1490 COPY (ADDRESS (z), STACK_TOP, size);
1491 }
1492 UNIT (&self) = genie_assignation_quick;
1493 SOURCE (&self) = p;
1494 return self;
1495 }
1496
1497 //! @brief Assign a value to a name and push the name.
1498
1499 PROP_T genie_assignation (NODE_T * p)
1500 {
1501 PROP_T self, srp;
1502 NODE_T *dst = SUB (p);
1503 NODE_T *src = NEXT_NEXT (dst);
1504 MOID_T *src_mode = SUB_MOID (dst);
1505 int size = SIZE (src_mode);
1506 ADDR_T pop_fp = FRAME_DNS (A68_FP);
1507 A68_REF *z = (A68_REF *) STACK_TOP;
1508 EXECUTE_UNIT (dst);
1509 CHECK_REF (p, *z, MOID (p));
1510 FRAME_DNS (A68_FP) = REF_SCOPE (z);
1511 EXECUTE_UNIT_2 (src, srp);
1512 STACK_DNS (src, src_mode, REF_SCOPE (z));
1513 FRAME_DNS (A68_FP) = pop_fp;
1514 DECREMENT_STACK_POINTER (p, size);
1515 if (HAS_ROWS (src_mode)) {
1516 genie_clone_stack (p, src_mode, z, z);
1517 UNIT (&self) = genie_assignation;
1518 } else {
1519 COPY (ADDRESS (z), STACK_TOP, size);
1520 if (UNIT (&srp) == genie_constant) {
1521 UNIT (&self) = genie_assignation_constant;
1522 } else {
1523 UNIT (&self) = genie_assignation_quick;
1524 }
1525 }
1526 SOURCE (&self) = p;
1527 return self;
1528 }
1529
1530 //! @brief Push equality of two REFs.
1531
1532 PROP_T genie_identity_relation (NODE_T * p)
1533 {
1534 PROP_T self;
1535 NODE_T *lhs = SUB (p), *rhs = NEXT_NEXT (lhs);
1536 A68_REF x, y;
1537 UNIT (&self) = genie_identity_relation;
1538 SOURCE (&self) = p;
1539 EXECUTE_UNIT (lhs);
1540 POP_REF (p, &y);
1541 EXECUTE_UNIT (rhs);
1542 POP_REF (p, &x);
1543 if (IS (NEXT_SUB (p), IS_SYMBOL)) {
1544 PUSH_VALUE (p, (BOOL_T) (ADDRESS (&x) == ADDRESS (&y)), A68_BOOL);
1545 } else {
1546 PUSH_VALUE (p, (BOOL_T) (ADDRESS (&x) != ADDRESS (&y)), A68_BOOL);
1547 }
1548 return self;
1549 }
1550
1551 //! @brief Push result of ANDF.
1552
1553 PROP_T genie_and_function (NODE_T * p)
1554 {
1555 PROP_T self;
1556 A68_BOOL x;
1557 EXECUTE_UNIT (SUB (p));
1558 POP_OBJECT (p, &x, A68_BOOL);
1559 if (VALUE (&x) == A68_TRUE) {
1560 EXECUTE_UNIT (NEXT_NEXT (SUB (p)));
1561 } else {
1562 PUSH_VALUE (p, A68_FALSE, A68_BOOL);
1563 }
1564 UNIT (&self) = genie_and_function;
1565 SOURCE (&self) = p;
1566 return self;
1567 }
1568
1569 //! @brief Push result of ORF.
1570
1571 PROP_T genie_or_function (NODE_T * p)
1572 {
1573 PROP_T self;
1574 A68_BOOL x;
1575 EXECUTE_UNIT (SUB (p));
1576 POP_OBJECT (p, &x, A68_BOOL);
1577 if (VALUE (&x) == A68_FALSE) {
1578 EXECUTE_UNIT (NEXT_NEXT (SUB (p)));
1579 } else {
1580 PUSH_VALUE (p, A68_TRUE, A68_BOOL);
1581 }
1582 UNIT (&self) = genie_or_function;
1583 SOURCE (&self) = p;
1584 return self;
1585 }
1586
1587 //! @brief Push routine text.
1588
1589 PROP_T genie_routine_text (NODE_T * p)
1590 {
1591 static PROP_T self;
1592 A68_PROCEDURE z = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p))));
1593 PUSH_PROCEDURE (p, z);
1594 UNIT (&self) = genie_routine_text;
1595 SOURCE (&self) = p;
1596 return self;
1597 }
1598
1599 //! @brief Push an undefined value of the required mode.
1600
1601 void genie_push_undefined (NODE_T * p, MOID_T * u)
1602 {
1603 // For primitive modes we push an initialised value.
1604 if (u == M_VOID) {
1605 ;
1606 } else if (u == M_INT) {
1607 PUSH_VALUE (p, 1, A68_INT); // Because users write [~] INT !
1608 } else if (u == M_REAL) {
1609 PUSH_VALUE (p, (a68_unif_rand ()), A68_REAL);
1610 } else if (u == M_BOOL) {
1611 PUSH_VALUE (p, (BOOL_T) (a68_unif_rand () < 0.5), A68_BOOL);
1612 } else if (u == M_CHAR) {
1613 PUSH_VALUE (p, (char) (32 + 96 * a68_unif_rand ()), A68_CHAR);
1614 } else if (u == M_BITS) {
1615 PUSH_VALUE (p, (UNSIGNED_T) (a68_unif_rand () * A68_MAX_BITS), A68_BITS);
1616 } else if (u == M_COMPLEX) {
1617 PUSH_COMPLEX (p, a68_unif_rand (), a68_unif_rand ());
1618 } else if (u == M_BYTES) {
1619 PUSH_BYTES (p, "SKIP");
1620 } else if (u == M_LONG_BYTES) {
1621 PUSH_LONG_BYTES (p, "SKIP");
1622 } else if (u == M_STRING) {
1623 PUSH_REF (p, empty_string (p));
1624 } else if (u == M_LONG_INT) {
1625 #if (A68_LEVEL >= 3)
1626 DOUBLE_NUM_T w;
1627 set_lw (w, 1);
1628 PUSH_VALUE (p, w, A68_LONG_INT); // Because users write [~] INT !
1629 #else
1630 (void) nil_mp (p, DIGITS (u));
1631 #endif
1632 } else if (u == M_LONG_REAL) {
1633 #if (A68_LEVEL >= 3)
1634 genie_next_random_double_real (p);
1635 #else
1636 (void) nil_mp (p, DIGITS (u));
1637 #endif
1638 } else if (u == M_LONG_BITS) {
1639 #if (A68_LEVEL >= 3)
1640 DOUBLE_NUM_T w;
1641 set_lw (w, 1);
1642 PUSH_VALUE (p, w, A68_LONG_BITS); // Because users write [~] INT !
1643 #else
1644 (void) nil_mp (p, DIGITS (u));
1645 #endif
1646 } else if (u == M_LONG_LONG_INT) {
1647 (void) nil_mp (p, DIGITS (u));
1648 } else if (u == M_LONG_LONG_REAL) {
1649 (void) nil_mp (p, DIGITS (u));
1650 } else if (u == M_LONG_LONG_BITS) {
1651 (void) nil_mp (p, DIGITS (u));
1652 } else if (u == M_LONG_COMPLEX) {
1653 #if (A68_LEVEL >= 3)
1654 genie_next_random_double_real (p);
1655 genie_next_random_double_real (p);
1656 #else
1657 (void) nil_mp (p, DIGITSC (u));
1658 (void) nil_mp (p, DIGITSC (u));
1659 #endif
1660 } else if (u == M_LONG_LONG_COMPLEX) {
1661 (void) nil_mp (p, DIGITSC (u));
1662 (void) nil_mp (p, DIGITSC (u));
1663 } else if (IS_REF (u)) {
1664 // All REFs are NIL.
1665 PUSH_REF (p, nil_ref);
1666 } else if (IS_ROW (u) || IS_FLEX (u)) {
1667 // [] AMODE or FLEX [] AMODE.
1668 A68_REF er = empty_row (p, u);
1669 STATUS (&er) |= SKIP_ROW_MASK;
1670 PUSH_REF (p, er);
1671 } else if (IS_STRUCT (u)) {
1672 // STRUCT.
1673 PACK_T *v;
1674 for (v = PACK (u); v != NO_PACK; FORWARD (v)) {
1675 genie_push_undefined (p, MOID (v));
1676 }
1677 } else if (IS_UNION (u)) {
1678 // UNION.
1679 ADDR_T sp = A68_SP;
1680 PUSH_UNION (p, MOID (PACK (u)));
1681 genie_push_undefined (p, MOID (PACK (u)));
1682 A68_SP = sp + SIZE (u);
1683 } else if (IS (u, PROC_SYMBOL)) {
1684 // PROC.
1685 A68_PROCEDURE z;
1686 STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | SKIP_PROCEDURE_MASK);
1687 (NODE (&BODY (&z))) = NO_NODE;
1688 ENVIRON (&z) = 0;
1689 LOCALE (&z) = NO_HANDLE;
1690 MOID (&z) = u;
1691 PUSH_PROCEDURE (p, z);
1692 } else if (u == M_FORMAT) {
1693 // FORMAT etc. - what arbitrary FORMAT could mean anything at all?.
1694 A68_FORMAT z;
1695 STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | SKIP_FORMAT_MASK);
1696 BODY (&z) = NO_NODE;
1697 ENVIRON (&z) = 0;
1698 PUSH_FORMAT (p, z);
1699 } else if (u == M_SIMPLOUT) {
1700 ADDR_T sp = A68_SP;
1701 PUSH_UNION (p, M_STRING);
1702 PUSH_REF (p, c_to_a_string (p, "SKIP", DEFAULT_WIDTH));
1703 A68_SP = sp + SIZE (u);
1704 } else if (u == M_SIMPLIN) {
1705 ADDR_T sp = A68_SP;
1706 PUSH_UNION (p, M_REF_STRING);
1707 genie_push_undefined (p, M_REF_STRING);
1708 A68_SP = sp + SIZE (u);
1709 } else if (u == M_REF_FILE) {
1710 PUSH_REF (p, A68 (skip_file));
1711 } else if (u == M_FILE) {
1712 A68_REF *z = (A68_REF *) STACK_TOP;
1713 int size = SIZE (M_FILE);
1714 ADDR_T pop_sp = A68_SP;
1715 PUSH_REF (p, A68 (skip_file));
1716 A68_SP = pop_sp;
1717 PUSH (p, ADDRESS (z), size);
1718 } else if (u == M_CHANNEL) {
1719 PUSH_OBJECT (p, A68 (skip_channel), A68_CHANNEL);
1720 } else if (u == M_PIPE) {
1721 genie_push_undefined (p, M_REF_FILE);
1722 genie_push_undefined (p, M_REF_FILE);
1723 genie_push_undefined (p, M_INT);
1724 } else if (u == M_SOUND) {
1725 A68_SOUND *z = (A68_SOUND *) STACK_TOP;
1726 int size = SIZE (M_SOUND);
1727 INCREMENT_STACK_POINTER (p, size);
1728 FILL (z, 0, size);
1729 STATUS (z) = INIT_MASK;
1730 } else {
1731 BYTE_T *_sp_ = STACK_TOP;
1732 int size = SIZE_ALIGNED (u);
1733 INCREMENT_STACK_POINTER (p, size);
1734 FILL (_sp_, 0, size);
1735 }
1736 }
1737
1738 //! @brief Push an undefined value of the required mode.
1739
1740 PROP_T genie_skip (NODE_T * p)
1741 {
1742 PROP_T self;
1743 if (MOID (p) != M_VOID) {
1744 genie_push_undefined (p, MOID (p));
1745 }
1746 UNIT (&self) = genie_skip;
1747 SOURCE (&self) = p;
1748 return self;
1749 }
1750
1751 //! @brief Jump to the serial clause where the label is at.
1752
1753 void genie_jump (NODE_T * p)
1754 {
1755 // Stack pointer and frame pointer were saved at target serial clause.
1756 NODE_T *jump = SUB (p);
1757 NODE_T *label = (IS (jump, GOTO_SYMBOL)) ? NEXT (jump) : jump;
1758 ADDR_T target_frame_pointer = A68_FP;
1759 jmp_buf *jump_stat = NO_JMP_BUF;
1760 // Find the stack frame this jump points to.
1761 BOOL_T found = A68_FALSE;
1762 while (target_frame_pointer > 0 && !found) {
1763 found = (BOOL_T) ((TAG_TABLE (TAX (label)) == TABLE (FRAME_TREE (target_frame_pointer))) && FRAME_JUMP_STAT (target_frame_pointer) != NO_JMP_BUF);
1764 if (!found) {
1765 target_frame_pointer = FRAME_STATIC_LINK (target_frame_pointer);
1766 }
1767 }
1768 // Beam us up, Scotty!.
1769 #if defined (BUILD_PARALLEL_CLAUSE)
1770 {
1771 pthread_t target_id = FRAME_THREAD_ID (target_frame_pointer);
1772 if (SAME_THREAD (target_id, pthread_self ())) {
1773 jump_stat = FRAME_JUMP_STAT (target_frame_pointer);
1774 JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label));
1775 longjmp (*(jump_stat), 1);
1776 } else if (SAME_THREAD (target_id, A68_PAR (main_thread_id))) {
1777 // A jump out of all parallel clauses back into the main program.
1778 genie_abend_all_threads (p, FRAME_JUMP_STAT (target_frame_pointer), label);
1779 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1780 } else {
1781 diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_JUMP);
1782 exit_genie (p, A68_RUNTIME_ERROR);
1783 }
1784 }
1785 #else
1786 jump_stat = FRAME_JUMP_STAT (target_frame_pointer);
1787 JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label));
1788 longjmp (*(jump_stat), 1);
1789 #endif
1790 }
1791
1792 //! @brief Execute a unit, tertiary, secondary or primary.
1793
1794 PROP_T genie_unit (NODE_T * p)
1795 {
1796 if (IS_COERCION (GINFO (p))) {
1797 GLOBAL_PROP (&A68_JOB) = genie_coercion (p);
1798 } else {
1799 switch (ATTRIBUTE (p)) {
1800 case DECLARATION_LIST:
1801 {
1802 genie_declaration (SUB (p));
1803 UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit;
1804 SOURCE (&GLOBAL_PROP (&A68_JOB)) = p;
1805 break;
1806 }
1807 case UNIT:
1808 {
1809 EXECUTE_UNIT_2 (SUB (p), GLOBAL_PROP (&A68_JOB));
1810 break;
1811 }
1812 case TERTIARY:
1813 case SECONDARY:
1814 case PRIMARY:
1815 {
1816 GLOBAL_PROP (&A68_JOB) = genie_unit (SUB (p));
1817 break;
1818 }
1819 // Ex primary.
1820 case ENCLOSED_CLAUSE:
1821 {
1822 GLOBAL_PROP (&A68_JOB) = genie_enclosed ((volatile NODE_T *) p);
1823 break;
1824 }
1825 case IDENTIFIER:
1826 {
1827 GLOBAL_PROP (&A68_JOB) = genie_identifier (p);
1828 break;
1829 }
1830 case CALL:
1831 {
1832 GLOBAL_PROP (&A68_JOB) = genie_call (p);
1833 break;
1834 }
1835 case SLICE:
1836 {
1837 GLOBAL_PROP (&A68_JOB) = genie_slice (p);
1838 break;
1839 }
1840 case DENOTATION:
1841 {
1842 GLOBAL_PROP (&A68_JOB) = genie_denotation (p);
1843 break;
1844 }
1845 case CAST:
1846 {
1847 GLOBAL_PROP (&A68_JOB) = genie_cast (p);
1848 break;
1849 }
1850 case FORMAT_TEXT:
1851 {
1852 GLOBAL_PROP (&A68_JOB) = genie_format_text (p);
1853 break;
1854 }
1855 // Ex secondary.
1856 case GENERATOR:
1857 {
1858 GLOBAL_PROP (&A68_JOB) = genie_generator (p);
1859 break;
1860 }
1861 case SELECTION:
1862 {
1863 GLOBAL_PROP (&A68_JOB) = genie_selection (p);
1864 break;
1865 }
1866 // Ex tertiary.
1867 case FORMULA:
1868 {
1869 GLOBAL_PROP (&A68_JOB) = genie_formula (p);
1870 break;
1871 }
1872 case MONADIC_FORMULA:
1873 {
1874 GLOBAL_PROP (&A68_JOB) = genie_monadic (p);
1875 break;
1876 }
1877 case NIHIL:
1878 {
1879 GLOBAL_PROP (&A68_JOB) = genie_nihil (p);
1880 break;
1881 }
1882 case DIAGONAL_FUNCTION:
1883 {
1884 GLOBAL_PROP (&A68_JOB) = genie_diagonal_function (p);
1885 break;
1886 }
1887 case TRANSPOSE_FUNCTION:
1888 {
1889 GLOBAL_PROP (&A68_JOB) = genie_transpose_function (p);
1890 break;
1891 }
1892 case ROW_FUNCTION:
1893 {
1894 GLOBAL_PROP (&A68_JOB) = genie_row_function (p);
1895 break;
1896 }
1897 case COLUMN_FUNCTION:
1898 {
1899 GLOBAL_PROP (&A68_JOB) = genie_column_function (p);
1900 break;
1901 }
1902 // Ex unit.
1903 case ASSIGNATION:
1904 {
1905 GLOBAL_PROP (&A68_JOB) = genie_assignation (p);
1906 break;
1907 }
1908 case IDENTITY_RELATION:
1909 {
1910 GLOBAL_PROP (&A68_JOB) = genie_identity_relation (p);
1911 break;
1912 }
1913 case ROUTINE_TEXT:
1914 {
1915 GLOBAL_PROP (&A68_JOB) = genie_routine_text (p);
1916 break;
1917 }
1918 case SKIP:
1919 {
1920 GLOBAL_PROP (&A68_JOB) = genie_skip (p);
1921 break;
1922 }
1923 case JUMP:
1924 {
1925 UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit;
1926 SOURCE (&GLOBAL_PROP (&A68_JOB)) = p;
1927 genie_jump (p);
1928 break;
1929 }
1930 case AND_FUNCTION:
1931 {
1932 GLOBAL_PROP (&A68_JOB) = genie_and_function (p);
1933 break;
1934 }
1935 case OR_FUNCTION:
1936 {
1937 GLOBAL_PROP (&A68_JOB) = genie_or_function (p);
1938 break;
1939 }
1940 case ASSERTION:
1941 {
1942 GLOBAL_PROP (&A68_JOB) = genie_assertion (p);
1943 break;
1944 }
1945 case CODE_CLAUSE:
1946 {
1947 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CODE);
1948 exit_genie (p, A68_RUNTIME_ERROR);
1949 break;
1950 }
1951 }
1952 }
1953 return GPROP (p) = GLOBAL_PROP (&A68_JOB);
1954 }
1955
1956 //! @brief Execution of serial clause without labels.
1957
1958 void genie_serial_units_no_label (NODE_T * p, ADDR_T pop_sp, NODE_T ** seq)
1959 {
1960 for (; p != NO_NODE; FORWARD (p)) {
1961 switch (ATTRIBUTE (p)) {
1962 case DECLARATION_LIST:
1963 case UNIT:
1964 {
1965 EXECUTE_UNIT_TRACE (p);
1966 SEQUENCE (*seq) = p;
1967 (*seq) = p;
1968 return;
1969 }
1970 case SEMI_SYMBOL:
1971 {
1972 // Voiden the expression stack.
1973 A68_SP = pop_sp;
1974 SEQUENCE (*seq) = p;
1975 (*seq) = p;
1976 break;
1977 }
1978 default:
1979 {
1980 genie_serial_units_no_label (SUB (p), pop_sp, seq);
1981 break;
1982 }
1983 }
1984 }
1985 }
1986
1987 //! @brief Execution of serial clause with labels.
1988
1989 void genie_serial_units (NODE_T * p, NODE_T ** jump_to, jmp_buf * exit_buf, ADDR_T pop_sp)
1990 {
1991 LOW_STACK_ALERT (p);
1992 for (; p != NO_NODE; FORWARD (p)) {
1993 switch (ATTRIBUTE (p)) {
1994 case DECLARATION_LIST:
1995 case UNIT:
1996 {
1997 if (*jump_to == NO_NODE) {
1998 EXECUTE_UNIT_TRACE (p);
1999 } else if (p == *jump_to) {
2000 // If we dropped in this clause from a jump then this unit is the target.
2001 *jump_to = NO_NODE;
2002 EXECUTE_UNIT_TRACE (p);
2003 }
2004 return;
2005 }
2006 case EXIT_SYMBOL:
2007 {
2008 if (*jump_to == NO_NODE) {
2009 longjmp (*exit_buf, 1);
2010 }
2011 break;
2012 }
2013 case SEMI_SYMBOL:
2014 {
2015 if (*jump_to == NO_NODE) {
2016 // Voiden the expression stack.
2017 A68_SP = pop_sp;
2018 }
2019 break;
2020 }
2021 default:
2022 {
2023 genie_serial_units (SUB (p), jump_to, exit_buf, pop_sp);
2024 break;
2025 }
2026 }
2027 }
2028 }
2029
2030 //! @brief Execute serial clause.
2031
2032 void genie_serial_clause (NODE_T * p, jmp_buf * exit_buf)
2033 {
2034 if (LABELS (TABLE (p)) == NO_TAG) {
2035 // No labels in this clause.
2036 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
2037 NODE_T top_seq;
2038 NODE_T *seq = &top_seq;
2039 GINFO_T g;
2040 GINFO (&top_seq) = &g;
2041 genie_serial_units_no_label (SUB (p), A68_SP, &seq);
2042 SEQUENCE (p) = SEQUENCE (&top_seq);
2043 STATUS_SET (p, SEQUENCE_MASK);
2044 STATUS_SET (p, SERIAL_MASK);
2045 if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) {
2046 STATUS_SET (p, OPTIMAL_MASK);
2047 }
2048 } else {
2049 // A linear list without labels.
2050 NODE_T *q;
2051 ADDR_T pop_sp = A68_SP;
2052 STATUS_SET (p, SERIAL_CLAUSE);
2053 for (q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
2054 switch (ATTRIBUTE (q)) {
2055 case DECLARATION_LIST:
2056 case UNIT:
2057 {
2058 EXECUTE_UNIT_TRACE (q);
2059 break;
2060 }
2061 case SEMI_SYMBOL:
2062 {
2063 A68_SP = pop_sp;
2064 break;
2065 }
2066 }
2067 }
2068 }
2069 } else {
2070 // Labels in this clause.
2071 jmp_buf jump_stat;
2072 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
2073 ADDR_T pop_dns = FRAME_DNS (A68_FP);
2074 FRAME_JUMP_STAT (A68_FP) = &jump_stat;
2075 if (!setjmp (jump_stat)) {
2076 NODE_T *jump_to = NO_NODE;
2077 genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP);
2078 } else {
2079 // HIjol! Restore state and look for indicated unit.
2080 NODE_T *jump_to = JUMP_TO (TABLE (p));
2081 A68_SP = pop_sp;
2082 A68_FP = pop_fp;
2083 FRAME_DNS (A68_FP) = pop_dns;
2084 genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP);
2085 }
2086 }
2087 }
2088
2089 //! @brief Execute enquiry clause.
2090
2091 void genie_enquiry_clause (NODE_T * p)
2092 {
2093 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
2094 NODE_T top_seq;
2095 NODE_T *seq = &top_seq;
2096 GINFO_T g;
2097 GINFO (&top_seq) = &g;
2098 genie_serial_units_no_label (SUB (p), A68_SP, &seq);
2099 SEQUENCE (p) = SEQUENCE (&top_seq);
2100 STATUS_SET (p, SEQUENCE_MASK);
2101 if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) {
2102 STATUS_SET (p, OPTIMAL_MASK);
2103 }
2104 } else {
2105 // A linear list without labels (of course, it's an enquiry clause).
2106 NODE_T *q;
2107 ADDR_T pop_sp = A68_SP;
2108 STATUS_SET (p, SERIAL_MASK);
2109 for (q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
2110 switch (ATTRIBUTE (q)) {
2111 case DECLARATION_LIST:
2112 case UNIT:
2113 {
2114 EXECUTE_UNIT_TRACE (q);
2115 break;
2116 }
2117 case SEMI_SYMBOL:
2118 {
2119 A68_SP = pop_sp;
2120 break;
2121 }
2122 }
2123 }
2124 }
2125 }
2126
2127 //! @brief Execute collateral units.
2128
2129 void genie_collateral_units (NODE_T * p, int *count)
2130 {
2131 for (; p != NO_NODE; FORWARD (p)) {
2132 if (IS (p, UNIT)) {
2133 EXECUTE_UNIT_TRACE (p);
2134 STACK_DNS (p, MOID (p), FRAME_DNS (A68_FP));
2135 (*count)++;
2136 return;
2137 } else {
2138 genie_collateral_units (SUB (p), count);
2139 }
2140 }
2141 }
2142
2143 //! @brief Execute collateral clause.
2144
2145 PROP_T genie_collateral (NODE_T * p)
2146 {
2147 PROP_T self;
2148 // VOID clause and STRUCT display.
2149 if (MOID (p) == M_VOID || IS_STRUCT (MOID (p))) {
2150 int count = 0;
2151 genie_collateral_units (SUB (p), &count);
2152 } else {
2153 // Row display.
2154 A68_REF new_display;
2155 int count = 0;
2156 ADDR_T sp = A68_SP;
2157 MOID_T *m = MOID (p);
2158 genie_collateral_units (SUB (p), &count);
2159 // [] AMODE vacuum.
2160 if (count == 0) {
2161 A68_SP = sp;
2162 INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
2163 *(A68_REF *) STACK_ADDRESS (sp) = empty_row (p, m);
2164 } else if (DIM (DEFLEX (m)) == 1) {
2165 // [] AMODE display.
2166 new_display = genie_make_row (p, SLICE (DEFLEX (m)), count, sp);
2167 A68_SP = sp;
2168 INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
2169 *(A68_REF *) STACK_ADDRESS (sp) = new_display;
2170 } else {
2171 // [,,] AMODE display, we concatenate 1 + (n-1) to n dimensions.
2172 new_display = genie_make_rowrow (p, m, count, sp);
2173 A68_SP = sp;
2174 INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
2175 *(A68_REF *) STACK_ADDRESS (sp) = new_display;
2176 }
2177 }
2178 UNIT (&self) = genie_collateral;
2179 SOURCE (&self) = p;
2180 return self;
2181 }
2182
2183 //! @brief Execute unit from integral-case in-part.
2184
2185 BOOL_T genie_int_case_unit (NODE_T * p, int k, int *count)
2186 {
2187 if (p == NO_NODE) {
2188 return A68_FALSE;
2189 } else {
2190 if (IS (p, UNIT)) {
2191 if (k == *count) {
2192 EXECUTE_UNIT_TRACE (p);
2193 return A68_TRUE;
2194 } else {
2195 (*count)++;
2196 return A68_FALSE;
2197 }
2198 } else {
2199 if (genie_int_case_unit (SUB (p), k, count)) {
2200 return A68_TRUE;
2201 } else {
2202 return genie_int_case_unit (NEXT (p), k, count);
2203 }
2204 }
2205 }
2206 }
2207
2208 //! @brief Execute unit from united-case in-part.
2209
2210 BOOL_T genie_united_case_unit (NODE_T * p, MOID_T * m)
2211 {
2212 if (p == NO_NODE) {
2213 return A68_FALSE;
2214 } else {
2215 if (IS (p, SPECIFIER)) {
2216 MOID_T *spec_moid = MOID (NEXT_SUB (p));
2217 BOOL_T equal_modes;
2218 if (m != NO_MOID) {
2219 if (IS_UNION (spec_moid)) {
2220 equal_modes = is_unitable (m, spec_moid, SAFE_DEFLEXING);
2221 } else {
2222 equal_modes = (BOOL_T) (m == spec_moid);
2223 }
2224 } else {
2225 equal_modes = A68_FALSE;
2226 }
2227 if (equal_modes) {
2228 NODE_T *q = NEXT_NEXT (SUB (p));
2229 OPEN_STATIC_FRAME (p);
2230 INIT_STATIC_FRAME (p);
2231 if (IS (q, IDENTIFIER)) {
2232 if (IS_UNION (spec_moid)) {
2233 COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_TOP, SIZE (spec_moid));
2234 } else {
2235 COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_OFFSET (A68_UNION_SIZE), SIZE (spec_moid));
2236 }
2237 }
2238 EXECUTE_UNIT_TRACE (NEXT_NEXT (p));
2239 CLOSE_FRAME;
2240 return A68_TRUE;
2241 } else {
2242 return A68_FALSE;
2243 }
2244 } else {
2245 if (genie_united_case_unit (SUB (p), m)) {
2246 return A68_TRUE;
2247 } else {
2248 return genie_united_case_unit (NEXT (p), m);
2249 }
2250 }
2251 }
2252 }
2253
2254 //! @brief Execute identity declaration.
2255
2256 void genie_identity_dec (NODE_T * p)
2257 {
2258 for (; p != NO_NODE; FORWARD (p)) {
2259 if (ISNT (p, DEFINING_IDENTIFIER)) {
2260 genie_identity_dec (SUB (p));
2261 } else {
2262 A68_REF loc;
2263 NODE_T *src = NEXT_NEXT (p);
2264 MOID_T *src_mode = MOID (p);
2265 unt size = (unt) SIZE (src_mode);
2266 BYTE_T *stack_top = STACK_TOP;
2267 ADDR_T pop_sp = A68_SP;
2268 ADDR_T pop_dns = FRAME_DNS (A68_FP);
2269 FRAME_DNS (A68_FP) = A68_FP;
2270 EXECUTE_UNIT_TRACE (src);
2271 genie_check_initialisation (src, stack_top, src_mode);
2272 STACK_DNS (src, src_mode, A68_FP);
2273 FRAME_DNS (A68_FP) = pop_dns;
2274 // Make a temporary REF to the object in the frame.
2275 STATUS (&loc) = (STATUS_MASK_T) (INIT_MASK | IN_FRAME_MASK);
2276 REF_HANDLE (&loc) = (A68_HANDLE *) & nil_handle;
2277 OFFSET (&loc) = A68_FP + FRAME_INFO_SIZE + OFFSET (TAX (p));
2278 REF_SCOPE (&loc) = A68_FP;
2279 ABEND (ADDRESS (&loc) != FRAME_OBJECT (OFFSET (TAX (p))), ERROR_INTERNAL_CONSISTENCY, __func__);
2280 // Initialise the tag, value is in the stack.
2281 if (HAS_ROWS (src_mode)) {
2282 A68_SP = pop_sp;
2283 genie_clone_stack (p, src_mode, &loc, (A68_REF *) & nil_ref);
2284 } else if (UNIT (&GPROP (src)) == genie_constant) {
2285 STATUS_SET (TAX (p), CONSTANT_MASK);
2286 POP_ALIGNED (p, ADDRESS (&loc), size);
2287 } else {
2288 POP_ALIGNED (p, ADDRESS (&loc), size);
2289 }
2290 return;
2291 }
2292 }
2293 }
2294
2295 //! @brief Execute variable declaration.
2296
2297 void genie_variable_dec (NODE_T * p, NODE_T ** declarer, ADDR_T sp)
2298 {
2299 for (; p != NO_NODE; FORWARD (p)) {
2300 if (IS (p, VARIABLE_DECLARATION)) {
2301 genie_variable_dec (SUB (p), declarer, sp);
2302 } else {
2303 if (IS (p, DECLARER)) {
2304 (*declarer) = SUB (p);
2305 genie_generator_bounds (*declarer);
2306 FORWARD (p);
2307 }
2308 if (IS (p, DEFINING_IDENTIFIER)) {
2309 MOID_T *ref_mode = MOID (p);
2310 TAG_T *tag = TAX (p);
2311 LEAP_T leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL);
2312 A68_REF *z;
2313 MOID_T *src_mode = SUB_MOID (p);
2314 z = (A68_REF *) (FRAME_OBJECT (OFFSET (TAX (p))));
2315 genie_generator_internal (*declarer, ref_mode, BODY (tag), leap, sp);
2316 POP_REF (p, z);
2317 if (NEXT (p) != NO_NODE && IS (NEXT (p), ASSIGN_SYMBOL)) {
2318 NODE_T *src = NEXT_NEXT (p);
2319 ADDR_T pop_sp = A68_SP;
2320 ADDR_T pop_dns = FRAME_DNS (A68_FP);
2321 FRAME_DNS (A68_FP) = A68_FP;
2322 EXECUTE_UNIT_TRACE (src);
2323 STACK_DNS (src, src_mode, A68_FP);
2324 FRAME_DNS (A68_FP) = pop_dns;
2325 A68_SP = pop_sp;
2326 if (HAS_ROWS (src_mode)) {
2327 genie_clone_stack (p, src_mode, z, z);
2328 } else {
2329 MOVE (ADDRESS (z), STACK_TOP, (unt) SIZE (src_mode));
2330 }
2331 }
2332 }
2333 }
2334 }
2335 }
2336
2337 //! @brief Execute PROC variable declaration.
2338
2339 void genie_proc_variable_dec (NODE_T * p)
2340 {
2341 for (; p != NO_NODE; FORWARD (p)) {
2342 switch (ATTRIBUTE (p)) {
2343 case DEFINING_IDENTIFIER:
2344 {
2345 ADDR_T sp_for_voiding = A68_SP;
2346 MOID_T *ref_mode = MOID (p);
2347 TAG_T *tag = TAX (p);
2348 LEAP_T leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL);
2349 A68_REF *z = (A68_REF *) (FRAME_OBJECT (OFFSET (TAX (p))));
2350 genie_generator_internal (p, ref_mode, BODY (tag), leap, A68_SP);
2351 POP_REF (p, z);
2352 if (NEXT (p) != NO_NODE && IS (NEXT (p), ASSIGN_SYMBOL)) {
2353 MOID_T *src_mode = SUB_MOID (p);
2354 ADDR_T pop_sp = A68_SP;
2355 ADDR_T pop_dns = FRAME_DNS (A68_FP);
2356 FRAME_DNS (A68_FP) = A68_FP;
2357 EXECUTE_UNIT_TRACE (NEXT_NEXT (p));
2358 STACK_DNS (p, SUB (ref_mode), A68_FP);
2359 FRAME_DNS (A68_FP) = pop_dns;
2360 A68_SP = pop_sp;
2361 MOVE (ADDRESS (z), STACK_TOP, (unt) SIZE (src_mode));
2362 }
2363 A68_SP = sp_for_voiding; // Voiding
2364 return;
2365 }
2366 default:
2367 {
2368 genie_proc_variable_dec (SUB (p));
2369 break;
2370 }
2371 }
2372 }
2373 }
2374
2375 //! @brief Execute operator declaration.
2376
2377 void genie_operator_dec (NODE_T * p)
2378 {
2379 for (; p != NO_NODE; FORWARD (p)) {
2380 switch (ATTRIBUTE (p)) {
2381 case DEFINING_OPERATOR:
2382 {
2383 A68_PROCEDURE *z = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p))));
2384 ADDR_T pop_dns = FRAME_DNS (A68_FP);
2385 FRAME_DNS (A68_FP) = A68_FP;
2386 EXECUTE_UNIT_TRACE (NEXT_NEXT (p));
2387 STACK_DNS (p, MOID (p), A68_FP);
2388 FRAME_DNS (A68_FP) = pop_dns;
2389 POP_PROCEDURE (p, z);
2390 return;
2391 }
2392 default:
2393 {
2394 genie_operator_dec (SUB (p));
2395 break;
2396 }
2397 }
2398 }
2399 }
2400
2401 //! @brief Execute declaration.
2402
2403 void genie_declaration (NODE_T * p)
2404 {
2405 for (; p != NO_NODE; FORWARD (p)) {
2406 switch (ATTRIBUTE (p)) {
2407 case MODE_DECLARATION:
2408 case PROCEDURE_DECLARATION:
2409 case BRIEF_OPERATOR_DECLARATION:
2410 case PRIORITY_DECLARATION:
2411 {
2412 // Already resolved.
2413 return;
2414 }
2415 case IDENTITY_DECLARATION:
2416 {
2417 genie_identity_dec (SUB (p));
2418 break;
2419 }
2420 case OPERATOR_DECLARATION:
2421 {
2422 genie_operator_dec (SUB (p));
2423 break;
2424 }
2425 case VARIABLE_DECLARATION:
2426 {
2427 NODE_T *declarer = NO_NODE;
2428 ADDR_T pop_sp = A68_SP;
2429 genie_variable_dec (SUB (p), &declarer, A68_SP);
2430 // Voiding to remove garbage from declarers.
2431 A68_SP = pop_sp;
2432 break;
2433 }
2434 case PROCEDURE_VARIABLE_DECLARATION:
2435 {
2436 ADDR_T pop_sp = A68_SP;
2437 genie_proc_variable_dec (SUB (p));
2438 A68_SP = pop_sp;
2439 break;
2440 }
2441 default:
2442 {
2443 genie_declaration (SUB (p));
2444 break;
2445 }
2446 }
2447 }
2448 }
2449
2450 #define LABEL_FREE(_p_) {\
2451 NODE_T *_m_q; ADDR_T pop_sp_lf = A68_SP;\
2452 for (_m_q = SEQUENCE (_p_); _m_q != NO_NODE; _m_q = SEQUENCE (_m_q)) {\
2453 if (IS (_m_q, UNIT) || IS (_m_q, DECLARATION_LIST)) {\
2454 EXECUTE_UNIT_TRACE (_m_q);\
2455 }\
2456 if (SEQUENCE (_m_q) != NO_NODE) {\
2457 A68_SP = pop_sp_lf;\
2458 _m_q = SEQUENCE (_m_q);\
2459 }\
2460 }}
2461
2462 #define SERIAL_CLAUSE(_p_)\
2463 genie_preemptive_gc_heap ((NODE_T *) (_p_));\
2464 if (STATUS_TEST ((_p_), OPTIMAL_MASK)) {\
2465 EXECUTE_UNIT_TRACE (SEQUENCE (_p_));\
2466 } else if (STATUS_TEST ((_p_), SERIAL_MASK)) {\
2467 LABEL_FREE (_p_);\
2468 } else {\
2469 if (!setjmp (exit_buf)) {\
2470 genie_serial_clause ((NODE_T *) (_p_), (jmp_buf *) exit_buf);\
2471 }}
2472
2473 #define ENQUIRY_CLAUSE(_p_)\
2474 genie_preemptive_gc_heap ((NODE_T *) (_p_));\
2475 if (STATUS_TEST ((_p_), OPTIMAL_MASK)) {\
2476 EXECUTE_UNIT (SEQUENCE (_p_));\
2477 } else if (STATUS_TEST ((_p_), SERIAL_MASK)) {\
2478 LABEL_FREE (_p_);\
2479 } else {\
2480 genie_enquiry_clause ((NODE_T *) (_p_));\
2481 }
2482
2483 //! @brief Execute integral-case-clause.
2484
2485 PROP_T genie_int_case (volatile NODE_T * p)
2486 {
2487 volatile int unit_count;
2488 volatile BOOL_T found_unit;
2489 jmp_buf exit_buf;
2490 A68_INT k;
2491 volatile NODE_T *q = SUB (p);
2492 volatile MOID_T *yield = MOID (q);
2493 // CASE or OUSE.
2494 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2495 INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
2496 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2497 ENQUIRY_CLAUSE (NEXT_SUB (q));
2498 POP_OBJECT (q, &k, A68_INT);
2499 // IN.
2500 FORWARD (q);
2501 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2502 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2503 unit_count = 1;
2504 found_unit = genie_int_case_unit (NEXT_SUB ((NODE_T *) q), (int) VALUE (&k), (int *) &unit_count);
2505 CLOSE_FRAME;
2506 // OUT.
2507 if (!found_unit) {
2508 FORWARD (q);
2509 switch (ATTRIBUTE (q)) {
2510 case CHOICE:
2511 case OUT_PART:
2512 {
2513 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2514 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2515 SERIAL_CLAUSE (NEXT_SUB (q));
2516 CLOSE_FRAME;
2517 break;
2518 }
2519 case CLOSE_SYMBOL:
2520 case ESAC_SYMBOL:
2521 {
2522 if (yield != M_VOID) {
2523 genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
2524 }
2525 break;
2526 }
2527 default:
2528 {
2529 MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
2530 (void) genie_int_case (q);
2531 break;
2532 }
2533 }
2534 }
2535 // ESAC.
2536 CLOSE_FRAME;
2537 return GPROP (p);
2538 }
2539
2540 //! @brief Execute united-case-clause.
2541
2542 PROP_T genie_united_case (volatile NODE_T * p)
2543 {
2544 volatile BOOL_T found_unit = A68_FALSE;
2545 volatile MOID_T *um;
2546 volatile ADDR_T pop_sp;
2547 jmp_buf exit_buf;
2548 volatile NODE_T *q = SUB (p);
2549 volatile MOID_T *yield = MOID (q);
2550 // CASE or OUSE.
2551 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2552 INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
2553 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2554 pop_sp = A68_SP;
2555 ENQUIRY_CLAUSE (NEXT_SUB (q));
2556 A68_SP = pop_sp;
2557 um = (volatile MOID_T *) VALUE ((A68_UNION *) STACK_TOP);
2558 // IN.
2559 FORWARD (q);
2560 if (um != NO_MOID) {
2561 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2562 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2563 found_unit = genie_united_case_unit (NEXT_SUB ((NODE_T *) q), (MOID_T *) um);
2564 CLOSE_FRAME;
2565 } else {
2566 found_unit = A68_FALSE;
2567 }
2568 // OUT.
2569 if (!found_unit) {
2570 FORWARD (q);
2571 switch (ATTRIBUTE (q)) {
2572 case CHOICE:
2573 case OUT_PART:
2574 {
2575 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2576 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2577 SERIAL_CLAUSE (NEXT_SUB (q));
2578 CLOSE_FRAME;
2579 break;
2580 }
2581 case CLOSE_SYMBOL:
2582 case ESAC_SYMBOL:
2583 {
2584 if (yield != M_VOID) {
2585 genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
2586 }
2587 break;
2588 }
2589 default:
2590 {
2591 MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
2592 (void) genie_united_case (q);
2593 break;
2594 }
2595 }
2596 }
2597 // ESAC.
2598 CLOSE_FRAME;
2599 return GPROP (p);
2600 }
2601
2602 //! @brief Execute conditional-clause.
2603
2604 PROP_T genie_conditional (volatile NODE_T * p)
2605 {
2606 volatile ADDR_T pop_sp = A68_SP;
2607 jmp_buf exit_buf;
2608 volatile NODE_T *q = SUB (p);
2609 volatile MOID_T *yield = MOID (q);
2610 // IF or ELIF.
2611 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2612 INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
2613 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2614 ENQUIRY_CLAUSE (NEXT_SUB (q));
2615 A68_SP = pop_sp;
2616 FORWARD (q);
2617 if (VALUE ((A68_BOOL *) STACK_TOP) == A68_TRUE) {
2618 // THEN.
2619 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2620 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2621 SERIAL_CLAUSE (NEXT_SUB (q));
2622 CLOSE_FRAME;
2623 } else {
2624 // ELSE.
2625 FORWARD (q);
2626 switch (ATTRIBUTE (q)) {
2627 case CHOICE:
2628 case ELSE_PART:
2629 {
2630 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
2631 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
2632 SERIAL_CLAUSE (NEXT_SUB (q));
2633 CLOSE_FRAME;
2634 break;
2635 }
2636 case CLOSE_SYMBOL:
2637 case FI_SYMBOL:
2638 {
2639 if (yield != M_VOID) {
2640 genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
2641 }
2642 break;
2643 }
2644 default:
2645 {
2646 MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
2647 (void) genie_conditional (q);
2648 break;
2649 }
2650 }
2651 }
2652 // FI.
2653 CLOSE_FRAME;
2654 return GPROP (p);
2655 }
2656
2657 // INCREMENT_COUNTER procures that the counter only increments if there is
2658 // a for-part or a to-part. Otherwise an infinite loop would trigger overflow
2659 // when the anonymous counter reaches max int, which is strange behaviour.
2660 // This is less relevant using 64-bit integers.
2661
2662 #define INCREMENT_COUNTER\
2663 if (!(for_part == NO_NODE && to_part == NO_NODE)) {\
2664 CHECK_INT_ADDITION ((NODE_T *) p, counter, by);\
2665 counter += by;\
2666 }
2667
2668 //! @brief Execute loop-clause.
2669
2670 PROP_T genie_loop (volatile NODE_T * p)
2671 {
2672 volatile ADDR_T pop_sp = A68_SP;
2673 volatile INT_T from, by, to, counter;
2674 volatile BOOL_T siga, conditional;
2675 volatile NODE_T *for_part = NO_NODE, *to_part = NO_NODE, *q = NO_NODE;
2676 jmp_buf exit_buf;
2677 // FOR identifier.
2678 if (IS (p, FOR_PART)) {
2679 for_part = NEXT_SUB (p);
2680 FORWARD (p);
2681 }
2682 // FROM unit.
2683 if (IS (p, FROM_PART)) {
2684 EXECUTE_UNIT (NEXT_SUB (p));
2685 A68_SP = pop_sp;
2686 from = VALUE ((A68_INT *) STACK_TOP);
2687 FORWARD (p);
2688 } else {
2689 from = 1;
2690 }
2691 // BY unit.
2692 if (IS (p, BY_PART)) {
2693 EXECUTE_UNIT (NEXT_SUB (p));
2694 A68_SP = pop_sp;
2695 by = VALUE ((A68_INT *) STACK_TOP);
2696 FORWARD (p);
2697 } else {
2698 by = 1;
2699 }
2700 // TO unit, DOWNTO unit.
2701 if (IS (p, TO_PART)) {
2702 if (IS (SUB (p), DOWNTO_SYMBOL)) {
2703 by = -by;
2704 }
2705 EXECUTE_UNIT (NEXT_SUB (p));
2706 A68_SP = pop_sp;
2707 to = VALUE ((A68_INT *) STACK_TOP);
2708 to_part = p;
2709 FORWARD (p);
2710 } else {
2711 to = (by >= 0 ? A68_MAX_INT : -A68_MAX_INT);
2712 }
2713 q = NEXT_SUB (p);
2714 // Here the loop part starts.
2715 // We open the frame only once and reinitialise if necessary
2716 OPEN_STATIC_FRAME ((NODE_T *) q);
2717 INIT_GLOBAL_POINTER ((NODE_T *) q);
2718 INIT_STATIC_FRAME ((NODE_T *) q);
2719 counter = from;
2720 // Does the loop contain conditionals?.
2721 if (IS (p, WHILE_PART)) {
2722 conditional = A68_TRUE;
2723 } else if (IS (p, DO_PART) || IS (p, ALT_DO_PART)) {
2724 NODE_T *until_part = NEXT_SUB (p);
2725 if (IS (until_part, SERIAL_CLAUSE)) {
2726 until_part = NEXT (until_part);
2727 }
2728 conditional = (BOOL_T) (until_part != NO_NODE && IS (until_part, UNTIL_PART));
2729 } else {
2730 conditional = A68_FALSE;
2731 }
2732 if (conditional) {
2733 // [FOR ...] [WHILE ...] DO [...] [UNTIL ...] OD.
2734 siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
2735 while (siga) {
2736 if (for_part != NO_NODE) {
2737 A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part))));
2738 STATUS (z) = INIT_MASK;
2739 VALUE (z) = counter;
2740 }
2741 A68_SP = pop_sp;
2742 if (IS (p, WHILE_PART)) {
2743 ENQUIRY_CLAUSE (q);
2744 A68_SP = pop_sp;
2745 siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) != A68_FALSE);
2746 }
2747 if (siga) {
2748 volatile NODE_T *do_part = p, *until_part;
2749 if (IS (p, WHILE_PART)) {
2750 do_part = NEXT_SUB (NEXT (p));
2751 OPEN_STATIC_FRAME ((NODE_T *) do_part);
2752 INIT_STATIC_FRAME ((NODE_T *) do_part);
2753 } else {
2754 do_part = NEXT_SUB (p);
2755 }
2756 if (IS (do_part, SERIAL_CLAUSE)) {
2757 SERIAL_CLAUSE (do_part);
2758 until_part = NEXT (do_part);
2759 } else {
2760 until_part = do_part;
2761 }
2762 // UNTIL part.
2763 if (until_part != NO_NODE && IS (until_part, UNTIL_PART)) {
2764 NODE_T *v = NEXT_SUB (until_part);
2765 OPEN_STATIC_FRAME ((NODE_T *) v);
2766 INIT_STATIC_FRAME ((NODE_T *) v);
2767 A68_SP = pop_sp;
2768 ENQUIRY_CLAUSE (v);
2769 A68_SP = pop_sp;
2770 siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) == A68_FALSE);
2771 CLOSE_FRAME;
2772 }
2773 if (IS (p, WHILE_PART)) {
2774 CLOSE_FRAME;
2775 }
2776 // Increment counter.
2777 if (siga) {
2778 INCREMENT_COUNTER;
2779 siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
2780 }
2781 // The genie cannot take things to next iteration: re-initialise stack frame.
2782 if (siga) {
2783 FRAME_CLEAR (AP_INCREMENT (TABLE (q)));
2784 if (INITIALISE_FRAME (TABLE (q))) {
2785 initialise_frame ((NODE_T *) q);
2786 }
2787 }
2788 }
2789 }
2790 } else {
2791 // [FOR ...] DO ... OD.
2792 siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
2793 while (siga) {
2794 if (for_part != NO_NODE) {
2795 A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part))));
2796 STATUS (z) = INIT_MASK;
2797 VALUE (z) = counter;
2798 }
2799 A68_SP = pop_sp;
2800 SERIAL_CLAUSE (q);
2801 INCREMENT_COUNTER;
2802 siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
2803 // The genie cannot take things to next iteration: re-initialise stack frame.
2804 if (siga) {
2805 FRAME_CLEAR (AP_INCREMENT (TABLE (q)));
2806 if (INITIALISE_FRAME (TABLE (q))) {
2807 initialise_frame ((NODE_T *) q);
2808 }
2809 }
2810 }
2811 }
2812 // OD.
2813 CLOSE_FRAME;
2814 A68_SP = pop_sp;
2815 return GPROP (p);
2816 }
2817
2818 #undef INCREMENT_COUNTER
2819 #undef LOOP_OVERFLOW
2820
2821 //! @brief Execute closed clause.
2822
2823 PROP_T genie_closed (volatile NODE_T * p)
2824 {
2825 jmp_buf exit_buf;
2826 volatile NODE_T *q = NEXT_SUB (p);
2827 OPEN_STATIC_FRAME ((NODE_T *) q);
2828 INIT_GLOBAL_POINTER ((NODE_T *) q);
2829 INIT_STATIC_FRAME ((NODE_T *) q);
2830 SERIAL_CLAUSE (q);
2831 CLOSE_FRAME;
2832 return GPROP (p);
2833 }
2834
2835 //! @brief Execute enclosed clause.
2836
2837 PROP_T genie_enclosed (volatile NODE_T * p)
2838 {
2839 PROP_T self;
2840 UNIT (&self) = (PROP_PROC *) genie_enclosed;
2841 SOURCE (&self) = (NODE_T *) p;
2842 switch (ATTRIBUTE (p)) {
2843 case PARTICULAR_PROGRAM:
2844 {
2845 self = genie_enclosed (SUB (p));
2846 break;
2847 }
2848 case ENCLOSED_CLAUSE:
2849 {
2850 self = genie_enclosed (SUB (p));
2851 break;
2852 }
2853 case CLOSED_CLAUSE:
2854 {
2855 self = genie_closed ((NODE_T *) p);
2856 if (UNIT (&self) == genie_unit) {
2857 UNIT (&self) = (PROP_PROC *) genie_closed;
2858 SOURCE (&self) = (NODE_T *) p;
2859 }
2860 break;
2861 }
2862 #if defined (BUILD_PARALLEL_CLAUSE)
2863 case PARALLEL_CLAUSE:
2864 {
2865 (void) genie_parallel ((NODE_T *) NEXT_SUB (p));
2866 break;
2867 }
2868 #endif
2869 case COLLATERAL_CLAUSE:
2870 {
2871 (void) genie_collateral ((NODE_T *) p);
2872 break;
2873 }
2874 case CONDITIONAL_CLAUSE:
2875 {
2876 MOID (SUB ((NODE_T *) p)) = MOID (p);
2877 (void) genie_conditional (p);
2878 UNIT (&self) = (PROP_PROC *) genie_conditional;
2879 SOURCE (&self) = (NODE_T *) p;
2880 break;
2881 }
2882 case CASE_CLAUSE:
2883 {
2884 MOID (SUB ((NODE_T *) p)) = MOID (p);
2885 (void) genie_int_case (p);
2886 UNIT (&self) = (PROP_PROC *) genie_int_case;
2887 SOURCE (&self) = (NODE_T *) p;
2888 break;
2889 }
2890 case CONFORMITY_CLAUSE:
2891 {
2892 MOID (SUB ((NODE_T *) p)) = MOID (p);
2893 (void) genie_united_case (p);
2894 UNIT (&self) = (PROP_PROC *) genie_united_case;
2895 SOURCE (&self) = (NODE_T *) p;
2896 break;
2897 }
2898 case LOOP_CLAUSE:
2899 {
2900 (void) genie_loop (SUB ((NODE_T *) p));
2901 UNIT (&self) = (PROP_PROC *) genie_loop;
2902 SOURCE (&self) = SUB ((NODE_T *) p);
2903 break;
2904 }
2905 }
2906 GPROP (p) = self;
2907 return self;
2908 }
2909
2910 //! @brief Propagator_name.
2911
2912 char *propagator_name (PROP_PROC * p)
2913 {
2914 if (p == genie_and_function) {
2915 return "genie_and_function";
2916 }
2917 if (p == genie_assertion) {
2918 return "genie_assertion";
2919 }
2920 if (p == genie_assignation) {
2921 return "genie_assignation";
2922 }
2923 if (p == genie_assignation_constant) {
2924 return "genie_assignation_constant";
2925 }
2926 if (p == genie_call) {
2927 return "genie_call";
2928 }
2929 if (p == genie_cast) {
2930 return "genie_cast";
2931 }
2932 if (p == (PROP_PROC *) genie_closed) {
2933 return "genie_closed";
2934 }
2935 if (p == genie_coercion) {
2936 return "genie_coercion";
2937 }
2938 if (p == genie_collateral) {
2939 return "genie_collateral";
2940 }
2941 if (p == genie_column_function) {
2942 return "genie_column_function";
2943 }
2944 if (p == (PROP_PROC *) genie_conditional) {
2945 return "genie_conditional";
2946 }
2947 if (p == genie_constant) {
2948 return "genie_constant";
2949 }
2950 if (p == genie_denotation) {
2951 return "genie_denotation";
2952 }
2953 if (p == genie_deproceduring) {
2954 return "genie_deproceduring";
2955 }
2956 if (p == genie_dereference_frame_identifier) {
2957 return "genie_dereference_frame_identifier";
2958 }
2959 if (p == genie_dereference_selection_name_quick) {
2960 return "genie_dereference_selection_name_quick";
2961 }
2962 if (p == genie_dereference_slice_name_quick) {
2963 return "genie_dereference_slice_name_quick";
2964 }
2965 if (p == genie_dereferencing) {
2966 return "genie_dereferencing";
2967 }
2968 if (p == genie_dereferencing_quick) {
2969 return "genie_dereferencing_quick";
2970 }
2971 if (p == genie_diagonal_function) {
2972 return "genie_diagonal_function";
2973 }
2974 if (p == genie_dyadic) {
2975 return "genie_dyadic";
2976 }
2977 if (p == genie_dyadic_quick) {
2978 return "genie_dyadic_quick";
2979 }
2980 if (p == (PROP_PROC *) genie_enclosed) {
2981 return "genie_enclosed";
2982 }
2983 if (p == genie_format_text) {
2984 return "genie_format_text";
2985 }
2986 if (p == genie_formula) {
2987 return "genie_formula";
2988 }
2989 if (p == genie_generator) {
2990 return "genie_generator";
2991 }
2992 if (p == genie_identifier) {
2993 return "genie_identifier";
2994 }
2995 if (p == genie_identifier_standenv) {
2996 return "genie_identifier_standenv";
2997 }
2998 if (p == genie_identifier_standenv_proc) {
2999 return "genie_identifier_standenv_proc";
3000 }
3001 if (p == genie_identity_relation) {
3002 return "genie_identity_relation";
3003 }
3004 if (p == (PROP_PROC *) genie_int_case) {
3005 return "genie_int_case";
3006 }
3007 if (p == genie_field_selection) {
3008 return "genie_field_selection";
3009 }
3010 if (p == genie_frame_identifier) {
3011 return "genie_frame_identifier";
3012 }
3013 if (p == (PROP_PROC *) genie_loop) {
3014 return "genie_loop";
3015 }
3016 if (p == genie_monadic) {
3017 return "genie_monadic";
3018 }
3019 if (p == genie_nihil) {
3020 return "genie_nihil";
3021 }
3022 if (p == genie_or_function) {
3023 return "genie_or_function";
3024 }
3025 #if defined (BUILD_PARALLEL_CLAUSE)
3026 if (p == genie_parallel) {
3027 return "genie_parallel";
3028 }
3029 #endif
3030 if (p == genie_routine_text) {
3031 return "genie_routine_text";
3032 }
3033 if (p == genie_row_function) {
3034 return "genie_row_function";
3035 }
3036 if (p == genie_rowing) {
3037 return "genie_rowing";
3038 }
3039 if (p == genie_rowing_ref_row_of_row) {
3040 return "genie_rowing_ref_row_of_row";
3041 }
3042 if (p == genie_rowing_ref_row_row) {
3043 return "genie_rowing_ref_row_row";
3044 }
3045 if (p == genie_rowing_row_of_row) {
3046 return "genie_rowing_row_of_row";
3047 }
3048 if (p == genie_rowing_row_row) {
3049 return "genie_rowing_row_row";
3050 }
3051 if (p == genie_selection) {
3052 return "genie_selection";
3053 }
3054 if (p == genie_selection_name_quick) {
3055 return "genie_selection_name_quick";
3056 }
3057 if (p == genie_selection_value_quick) {
3058 return "genie_selection_value_quick";
3059 }
3060 if (p == genie_skip) {
3061 return "genie_skip";
3062 }
3063 if (p == genie_slice) {
3064 return "genie_slice";
3065 }
3066 if (p == genie_slice_name_quick) {
3067 return "genie_slice_name_quick";
3068 }
3069 if (p == genie_transpose_function) {
3070 return "genie_transpose_function";
3071 }
3072 if (p == genie_unit) {
3073 return "genie_unit";
3074 }
3075 if (p == (PROP_PROC *) genie_united_case) {
3076 return "genie_united_case";
3077 }
3078 if (p == genie_uniting) {
3079 return "genie_uniting";
3080 }
3081 if (p == genie_voiding) {
3082 return "genie_voiding";
3083 }
3084 if (p == genie_voiding_assignation) {
3085 return "genie_voiding_assignation";
3086 }
3087 if (p == genie_voiding_assignation_constant) {
3088 return "genie_voiding_assignation_constant";
3089 }
3090 if (p == genie_widen) {
3091 return "genie_widen";
3092 }
3093 if (p == genie_widen_int_to_real) {
3094 return "genie_widen_int_to_real";
3095 }
3096 return NO_TEXT;
3097 }