genie-enclosed.c
1 //! @file genie-enclosed.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-2024 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 routines for enclosed clauses.
25
26 #include "a68g.h"
27 #include "a68g-genie.h"
28 #include "a68g-frames.h"
29 #include "a68g-prelude.h"
30 #include "a68g-parser.h"
31
32 #define LABEL_FREE(_p_) {\
33 NODE_T *_m_q; ADDR_T pop_sp_lf = A68_SP;\
34 for (_m_q = SEQUENCE (_p_); _m_q != NO_NODE; _m_q = SEQUENCE (_m_q)) {\
35 if (IS (_m_q, UNIT) || IS (_m_q, DECLARATION_LIST)) {\
36 GENIE_UNIT_TRACE (_m_q);\
37 }\
38 if (SEQUENCE (_m_q) != NO_NODE) {\
39 A68_SP = pop_sp_lf;\
40 _m_q = SEQUENCE (_m_q);\
41 }\
42 }}
43
44 #define SERIAL_CLAUSE(_p_)\
45 genie_preemptive_gc_heap ((NODE_T *) (_p_));\
46 if (STATUS_TEST ((_p_), OPTIMAL_MASK)) {\
47 GENIE_UNIT_TRACE (SEQUENCE (_p_));\
48 } else if (STATUS_TEST ((_p_), SERIAL_MASK)) {\
49 LABEL_FREE (_p_);\
50 } else {\
51 if (!setjmp (exit_buf)) {\
52 genie_serial_clause ((NODE_T *) (_p_), (jmp_buf *) exit_buf);\
53 }}
54
55 #define ENQUIRY_CLAUSE(_p_)\
56 genie_preemptive_gc_heap ((NODE_T *) (_p_));\
57 if (STATUS_TEST ((_p_), OPTIMAL_MASK)) {\
58 GENIE_UNIT (SEQUENCE (_p_));\
59 } else if (STATUS_TEST ((_p_), SERIAL_MASK)) {\
60 LABEL_FREE (_p_);\
61 } else {\
62 genie_enquiry_clause ((NODE_T *) (_p_));\
63 }
64
65 //! @brief Execute assertion.
66
67 PROP_T genie_assertion (NODE_T * p)
68 {
69 PROP_T self;
70 if (STATUS_TEST (p, ASSERT_MASK)) {
71 A68_BOOL z;
72 GENIE_UNIT (NEXT_SUB (p));
73 POP_OBJECT (p, &z, A68_BOOL);
74 if (VALUE (&z) == A68_FALSE) {
75 diagnostic (A68_RUNTIME_ERROR, p, ERROR_FALSE_ASSERTION);
76 exit_genie (p, A68_RUNTIME_ERROR);
77 }
78 }
79 UNIT (&self) = genie_assertion;
80 SOURCE (&self) = p;
81 return self;
82 }
83
84 //! @brief Execute a unit, tertiary, secondary or primary.
85
86 PROP_T genie_unit (NODE_T * p)
87 {
88 if (IS_COERCION (GINFO (p))) {
89 GLOBAL_PROP (&A68_JOB) = genie_coercion (p);
90 } else {
91 switch (ATTRIBUTE (p)) {
92 case DECLARATION_LIST: {
93 genie_declaration (SUB (p));
94 UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit;
95 SOURCE (&GLOBAL_PROP (&A68_JOB)) = p;
96 break;
97 }
98 case UNIT: {
99 GENIE_UNIT_2 (SUB (p), GLOBAL_PROP (&A68_JOB));
100 break;
101 }
102 case TERTIARY:
103 case SECONDARY:
104 case PRIMARY: {
105 GLOBAL_PROP (&A68_JOB) = genie_unit (SUB (p));
106 break;
107 }
108 // Ex primary.
109 case ENCLOSED_CLAUSE: {
110 GLOBAL_PROP (&A68_JOB) = genie_enclosed ((volatile NODE_T *) p);
111 break;
112 }
113 case IDENTIFIER: {
114 GLOBAL_PROP (&A68_JOB) = genie_identifier (p);
115 break;
116 }
117 case CALL: {
118 GLOBAL_PROP (&A68_JOB) = genie_call (p);
119 break;
120 }
121 case SLICE: {
122 GLOBAL_PROP (&A68_JOB) = genie_slice (p);
123 break;
124 }
125 case DENOTATION: {
126 GLOBAL_PROP (&A68_JOB) = genie_denotation (p);
127 break;
128 }
129 case CAST: {
130 GLOBAL_PROP (&A68_JOB) = genie_cast (p);
131 break;
132 }
133 case FORMAT_TEXT: {
134 GLOBAL_PROP (&A68_JOB) = genie_format_text (p);
135 break;
136 }
137 // Ex secondary.
138 case GENERATOR: {
139 GLOBAL_PROP (&A68_JOB) = genie_generator (p);
140 break;
141 }
142 case SELECTION: {
143 GLOBAL_PROP (&A68_JOB) = genie_selection (p);
144 break;
145 }
146 // Ex tertiary.
147 case FORMULA: {
148 GLOBAL_PROP (&A68_JOB) = genie_formula (p);
149 break;
150 }
151 case MONADIC_FORMULA: {
152 GLOBAL_PROP (&A68_JOB) = genie_monadic (p);
153 break;
154 }
155 case NIHIL: {
156 GLOBAL_PROP (&A68_JOB) = genie_nihil (p);
157 break;
158 }
159 case DIAGONAL_FUNCTION: {
160 GLOBAL_PROP (&A68_JOB) = genie_diagonal_function (p);
161 break;
162 }
163 case TRANSPOSE_FUNCTION: {
164 GLOBAL_PROP (&A68_JOB) = genie_transpose_function (p);
165 break;
166 }
167 case ROW_FUNCTION: {
168 GLOBAL_PROP (&A68_JOB) = genie_row_function (p);
169 break;
170 }
171 case COLUMN_FUNCTION: {
172 GLOBAL_PROP (&A68_JOB) = genie_column_function (p);
173 break;
174 }
175 // Ex unit.
176 case ASSIGNATION: {
177 GLOBAL_PROP (&A68_JOB) = genie_assignation (p);
178 break;
179 }
180 case IDENTITY_RELATION: {
181 GLOBAL_PROP (&A68_JOB) = genie_identity_relation (p);
182 break;
183 }
184 case ROUTINE_TEXT: {
185 GLOBAL_PROP (&A68_JOB) = genie_routine_text (p);
186 break;
187 }
188 case SKIP: {
189 GLOBAL_PROP (&A68_JOB) = genie_skip (p);
190 break;
191 }
192 case JUMP: {
193 UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit;
194 SOURCE (&GLOBAL_PROP (&A68_JOB)) = p;
195 genie_jump (p);
196 break;
197 }
198 case AND_FUNCTION: {
199 GLOBAL_PROP (&A68_JOB) = genie_and_function (p);
200 break;
201 }
202 case OR_FUNCTION: {
203 GLOBAL_PROP (&A68_JOB) = genie_or_function (p);
204 break;
205 }
206 case ASSERTION: {
207 GLOBAL_PROP (&A68_JOB) = genie_assertion (p);
208 break;
209 }
210 case CODE_CLAUSE: {
211 diagnostic (A68_RUNTIME_ERROR, p, ERROR_CODE);
212 exit_genie (p, A68_RUNTIME_ERROR);
213 break;
214 }
215 }
216 }
217 return GPROP (p) = GLOBAL_PROP (&A68_JOB);
218 }
219
220 //! @brief Execution of serial clause without labels.
221
222 void genie_serial_units_no_label (NODE_T * p, ADDR_T pop_sp, NODE_T ** seq)
223 {
224 for (; p != NO_NODE; FORWARD (p)) {
225 switch (ATTRIBUTE (p)) {
226 case DECLARATION_LIST:
227 case UNIT: {
228 GENIE_UNIT_TRACE (p);
229 SEQUENCE (*seq) = p;
230 (*seq) = p;
231 return;
232 }
233 case SEMI_SYMBOL: {
234 // Voiden the expression stack.
235 A68_SP = pop_sp;
236 SEQUENCE (*seq) = p;
237 (*seq) = p;
238 break;
239 }
240 default: {
241 genie_serial_units_no_label (SUB (p), pop_sp, seq);
242 break;
243 }
244 }
245 }
246 }
247
248 //! @brief Execution of serial clause with labels.
249
250 void genie_serial_units (NODE_T * p, NODE_T ** jump_to, jmp_buf * exit_buf, ADDR_T pop_sp)
251 {
252 LOW_STACK_ALERT (p);
253 for (; p != NO_NODE; FORWARD (p)) {
254 switch (ATTRIBUTE (p)) {
255 case DECLARATION_LIST:
256 case UNIT: {
257 if (*jump_to == NO_NODE) {
258 GENIE_UNIT_TRACE (p);
259 } else if (p == *jump_to) {
260 // If we dropped in this clause from a jump then this unit is the target.
261 *jump_to = NO_NODE;
262 GENIE_UNIT_TRACE (p);
263 }
264 return;
265 }
266 case EXIT_SYMBOL: {
267 if (*jump_to == NO_NODE) {
268 longjmp (*exit_buf, 1);
269 }
270 break;
271 }
272 case SEMI_SYMBOL: {
273 if (*jump_to == NO_NODE) {
274 // Voiden the expression stack.
275 A68_SP = pop_sp;
276 }
277 break;
278 }
279 default: {
280 genie_serial_units (SUB (p), jump_to, exit_buf, pop_sp);
281 break;
282 }
283 }
284 }
285 }
286
287 //! @brief Execute serial clause.
288
289 void genie_serial_clause (NODE_T * p, jmp_buf * exit_buf)
290 {
291 if (LABELS (TABLE (p)) == NO_TAG) {
292 // No labels in this clause.
293 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
294 NODE_T top_seq; GINFO_T g; NODE_T *seq = &top_seq;
295 GINFO (seq) = &g;
296 SEQUENCE (seq) = NO_NODE;
297 genie_serial_units_no_label (SUB (p), A68_SP, &seq);
298 SEQUENCE (p) = SEQUENCE (&top_seq);
299 STATUS_SET (p, SEQUENCE_MASK);
300 STATUS_SET (p, SERIAL_MASK);
301 if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) {
302 STATUS_SET (p, OPTIMAL_MASK);
303 }
304 } else {
305 // A linear list without labels.
306 ADDR_T pop_sp = A68_SP;
307 STATUS_SET (p, SERIAL_CLAUSE);
308 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
309 switch (ATTRIBUTE (q)) {
310 case DECLARATION_LIST:
311 case UNIT: {
312 GENIE_UNIT_TRACE (q);
313 break;
314 }
315 case SEMI_SYMBOL: {
316 A68_SP = pop_sp;
317 break;
318 }
319 }
320 }
321 }
322 } else {
323 // Labels in this clause.
324 jmp_buf jump_stat;
325 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
326 ADDR_T pop_dns = FRAME_DNS (A68_FP);
327 FRAME_JUMP_STAT (A68_FP) = &jump_stat;
328 if (!setjmp (jump_stat)) {
329 NODE_T *jump_to = NO_NODE;
330 genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP);
331 } else {
332 // HIjol! Restore state and look for indicated unit.
333 NODE_T *jump_to = JUMP_TO (TABLE (p));
334 A68_SP = pop_sp;
335 A68_FP = pop_fp;
336 FRAME_DNS (A68_FP) = pop_dns;
337 genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP);
338 }
339 }
340 }
341
342 //! @brief Execute enquiry clause.
343
344 void genie_enquiry_clause (NODE_T * p)
345 {
346 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
347 NODE_T top_seq;
348 GINFO_T g;
349 NODE_T *seq = &top_seq;
350 GINFO (seq) = &g;
351 SEQUENCE (seq) = NO_NODE;
352 genie_serial_units_no_label (SUB (p), A68_SP, &seq);
353 SEQUENCE (p) = SEQUENCE (&top_seq);
354 STATUS_SET (p, SEQUENCE_MASK);
355 if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) {
356 STATUS_SET (p, OPTIMAL_MASK);
357 }
358 } else {
359 // A linear list without labels (enquiry clause).
360 ADDR_T pop_sp = A68_SP;
361 STATUS_SET (p, SERIAL_MASK);
362 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
363 switch (ATTRIBUTE (q)) {
364 case DECLARATION_LIST:
365 case UNIT: {
366 GENIE_UNIT_TRACE (q);
367 break;
368 }
369 case SEMI_SYMBOL: {
370 A68_SP = pop_sp;
371 break;
372 }
373 }
374 }
375 }
376 }
377
378 //! @brief Execute collateral units.
379
380 void genie_collateral_units (NODE_T * p, int *count)
381 {
382 for (; p != NO_NODE; FORWARD (p)) {
383 if (IS (p, UNIT)) {
384 GENIE_UNIT_TRACE (p);
385 STACK_DNS (p, MOID (p), FRAME_DNS (A68_FP));
386 (*count)++;
387 return;
388 } else {
389 genie_collateral_units (SUB (p), count);
390 }
391 }
392 }
393
394 //! @brief Execute collateral clause.
395
396 PROP_T genie_collateral (NODE_T * p)
397 {
398 PROP_T self;
399 // VOID clause and STRUCT display.
400 if (MOID (p) == M_VOID || IS_STRUCT (MOID (p))) {
401 int count = 0;
402 genie_collateral_units (SUB (p), &count);
403 } else {
404 // Row display.
405 A68_REF new_display;
406 int count = 0;
407 ADDR_T pop_sp = A68_SP;
408 MOID_T *m = MOID (p);
409 genie_collateral_units (SUB (p), &count);
410 // [] AMODE vacuum.
411 if (count == 0) {
412 A68_SP = pop_sp;
413 INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
414 *(A68_REF *) STACK_ADDRESS (pop_sp) = empty_row (p, m);
415 } else if (DIM (DEFLEX (m)) == 1) {
416 // [] AMODE display.
417 new_display = genie_make_row (p, SLICE (DEFLEX (m)), count, pop_sp);
418 A68_SP = pop_sp;
419 INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
420 *(A68_REF *) STACK_ADDRESS (pop_sp) = new_display;
421 } else {
422 // [,,] AMODE display, we concatenate 1 + (n-1) to n dimensions.
423 new_display = genie_make_rowrow (p, m, count, pop_sp);
424 A68_SP = pop_sp;
425 INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
426 *(A68_REF *) STACK_ADDRESS (pop_sp) = new_display;
427 }
428 }
429 UNIT (&self) = genie_collateral;
430 SOURCE (&self) = p;
431 return self;
432 }
433
434 //! @brief Execute unit from integral-case in-part.
435
436 BOOL_T genie_int_case_unit (NODE_T * p, int k, int *count)
437 {
438 if (p == NO_NODE) {
439 return A68_FALSE;
440 } else {
441 if (IS (p, UNIT)) {
442 if (k == *count) {
443 GENIE_UNIT_TRACE (p);
444 return A68_TRUE;
445 } else {
446 (*count)++;
447 return A68_FALSE;
448 }
449 } else {
450 if (genie_int_case_unit (SUB (p), k, count)) {
451 return A68_TRUE;
452 } else {
453 return genie_int_case_unit (NEXT (p), k, count);
454 }
455 }
456 }
457 }
458
459 //! @brief Execute unit from united-case in-part.
460
461 BOOL_T genie_united_case_unit (NODE_T * p, MOID_T * m)
462 {
463 if (p == NO_NODE) {
464 return A68_FALSE;
465 } else {
466 if (IS (p, SPECIFIER)) {
467 MOID_T *spec_moid = MOID (NEXT_SUB (p));
468 BOOL_T equal_modes;
469 if (m != NO_MOID) {
470 if (IS_UNION (spec_moid)) {
471 equal_modes = is_unitable (m, spec_moid, SAFE_DEFLEXING);
472 } else {
473 equal_modes = (BOOL_T) (m == spec_moid);
474 }
475 } else {
476 equal_modes = A68_FALSE;
477 }
478 if (equal_modes) {
479 NODE_T *q = NEXT_NEXT (SUB (p));
480 OPEN_STATIC_FRAME (p);
481 INIT_STATIC_FRAME (p);
482 if (IS (q, IDENTIFIER)) {
483 if (IS_UNION (spec_moid)) {
484 COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_TOP, SIZE (spec_moid));
485 } else {
486 COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_OFFSET (A68_UNION_SIZE), SIZE (spec_moid));
487 }
488 }
489 GENIE_UNIT_TRACE (NEXT_NEXT (p));
490 CLOSE_FRAME;
491 return A68_TRUE;
492 } else {
493 return A68_FALSE;
494 }
495 } else {
496 if (genie_united_case_unit (SUB (p), m)) {
497 return A68_TRUE;
498 } else {
499 return genie_united_case_unit (NEXT (p), m);
500 }
501 }
502 }
503 }
504
505 //! @brief Execute integral-case-clause.
506
507 PROP_T genie_int_case (volatile NODE_T * p)
508 {
509 volatile int unit_count;
510 volatile BOOL_T found_unit;
511 jmp_buf exit_buf;
512 A68_INT k;
513 volatile NODE_T *q = SUB (p);
514 volatile MOID_T *yield = MOID (q);
515 // CASE or OUSE.
516 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
517 INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
518 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
519 ENQUIRY_CLAUSE (NEXT_SUB (q));
520 POP_OBJECT (q, &k, A68_INT);
521 // IN.
522 FORWARD (q);
523 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
524 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
525 unit_count = 1;
526 found_unit = genie_int_case_unit (NEXT_SUB ((NODE_T *) q), (int) VALUE (&k), (int *) &unit_count);
527 CLOSE_FRAME;
528 // OUT.
529 if (!found_unit) {
530 FORWARD (q);
531 switch (ATTRIBUTE (q)) {
532 case CHOICE:
533 case OUT_PART: {
534 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
535 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
536 SERIAL_CLAUSE (NEXT_SUB (q));
537 CLOSE_FRAME;
538 break;
539 }
540 case CLOSE_SYMBOL:
541 case ESAC_SYMBOL: {
542 if (yield != M_VOID) {
543 genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
544 }
545 break;
546 }
547 default: {
548 MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
549 (void) genie_int_case (q);
550 break;
551 }
552 }
553 }
554 // ESAC.
555 CLOSE_FRAME;
556 return GPROP (p);
557 }
558
559 //! @brief Execute united-case-clause.
560
561 PROP_T genie_united_case (volatile NODE_T * p)
562 {
563 volatile BOOL_T found_unit = A68_FALSE;
564 volatile MOID_T *um;
565 volatile ADDR_T pop_sp;
566 jmp_buf exit_buf;
567 volatile NODE_T *q = SUB (p);
568 volatile MOID_T *yield = MOID (q);
569 // CASE or OUSE.
570 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
571 INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
572 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
573 pop_sp = A68_SP;
574 ENQUIRY_CLAUSE (NEXT_SUB (q));
575 A68_SP = pop_sp;
576 um = (volatile MOID_T *) VALUE ((A68_UNION *) STACK_TOP);
577 // IN.
578 FORWARD (q);
579 if (um != NO_MOID) {
580 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
581 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
582 found_unit = genie_united_case_unit (NEXT_SUB ((NODE_T *) q), (MOID_T *) um);
583 CLOSE_FRAME;
584 } else {
585 found_unit = A68_FALSE;
586 }
587 // OUT.
588 if (!found_unit) {
589 FORWARD (q);
590 switch (ATTRIBUTE (q)) {
591 case CHOICE:
592 case OUT_PART: {
593 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
594 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
595 SERIAL_CLAUSE (NEXT_SUB (q));
596 CLOSE_FRAME;
597 break;
598 }
599 case CLOSE_SYMBOL:
600 case ESAC_SYMBOL: {
601 if (yield != M_VOID) {
602 genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
603 }
604 break;
605 }
606 default: {
607 MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
608 (void) genie_united_case (q);
609 break;
610 }
611 }
612 }
613 // ESAC.
614 CLOSE_FRAME;
615 return GPROP (p);
616 }
617
618 //! @brief Execute conditional-clause.
619
620 PROP_T genie_conditional (volatile NODE_T * p)
621 {
622 volatile ADDR_T pop_sp = A68_SP;
623 jmp_buf exit_buf;
624 volatile NODE_T *q = SUB (p);
625 volatile MOID_T *yield = MOID (q);
626 // IF or ELIF.
627 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
628 INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
629 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
630 ENQUIRY_CLAUSE (NEXT_SUB (q));
631 A68_SP = pop_sp;
632 FORWARD (q);
633 if (VALUE ((A68_BOOL *) STACK_TOP) == A68_TRUE) {
634 // THEN.
635 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
636 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
637 SERIAL_CLAUSE (NEXT_SUB (q));
638 CLOSE_FRAME;
639 } else {
640 // ELSE.
641 FORWARD (q);
642 switch (ATTRIBUTE (q)) {
643 case CHOICE:
644 case ELSE_PART: {
645 OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
646 INIT_STATIC_FRAME ((NODE_T *) SUB (q));
647 SERIAL_CLAUSE (NEXT_SUB (q));
648 CLOSE_FRAME;
649 break;
650 }
651 case CLOSE_SYMBOL:
652 case FI_SYMBOL: {
653 if (yield != M_VOID) {
654 genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
655 }
656 break;
657 }
658 default: {
659 MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
660 (void) genie_conditional (q);
661 break;
662 }
663 }
664 }
665 // FI.
666 CLOSE_FRAME;
667 return GPROP (p);
668 }
669
670 // INCREMENT_COUNTER procures that the counter only increments if there is
671 // a for-part or a to-part. Otherwise an infinite loop would trigger overflow
672 // when the anonymous counter reaches max int, which is strange behaviour.
673 // This is less relevant using 64-bit integers.
674
675 #define INCREMENT_COUNTER\
676 if (!(for_part == NO_NODE && to_part == NO_NODE)) {\
677 CHECK_INT_ADDITION ((NODE_T *) p, counter, by);\
678 counter += by;\
679 }
680
681 //! @brief Execute loop-clause.
682
683 PROP_T genie_loop (volatile NODE_T * p)
684 {
685 volatile ADDR_T pop_sp = A68_SP;
686 volatile INT_T from, by, to, counter;
687 volatile BOOL_T siga, conditional;
688 volatile NODE_T *for_part = NO_NODE, *to_part = NO_NODE, *q = NO_NODE;
689 jmp_buf exit_buf;
690 // FOR identifier.
691 if (IS (p, FOR_PART)) {
692 for_part = NEXT_SUB (p);
693 FORWARD (p);
694 }
695 // FROM unit.
696 if (IS (p, FROM_PART)) {
697 GENIE_UNIT (NEXT_SUB (p));
698 A68_SP = pop_sp;
699 from = VALUE ((A68_INT *) STACK_TOP);
700 FORWARD (p);
701 } else {
702 from = 1;
703 }
704 // BY unit.
705 if (IS (p, BY_PART)) {
706 GENIE_UNIT (NEXT_SUB (p));
707 A68_SP = pop_sp;
708 by = VALUE ((A68_INT *) STACK_TOP);
709 FORWARD (p);
710 } else {
711 by = 1;
712 }
713 // TO unit, DOWNTO unit.
714 if (IS (p, TO_PART)) {
715 if (IS (SUB (p), DOWNTO_SYMBOL)) {
716 by = -by;
717 }
718 GENIE_UNIT (NEXT_SUB (p));
719 A68_SP = pop_sp;
720 to = VALUE ((A68_INT *) STACK_TOP);
721 to_part = p;
722 FORWARD (p);
723 } else {
724 to = (by >= 0 ? A68_MAX_INT : -A68_MAX_INT);
725 }
726 q = NEXT_SUB (p);
727 // Here the loop part starts.
728 // We open the frame only once and reinitialise if necessary
729 OPEN_STATIC_FRAME ((NODE_T *) q);
730 INIT_GLOBAL_POINTER ((NODE_T *) q);
731 INIT_STATIC_FRAME ((NODE_T *) q);
732 counter = from;
733 // Does the loop contain conditionals?.
734 if (IS (p, WHILE_PART)) {
735 conditional = A68_TRUE;
736 } else if (IS (p, DO_PART) || IS (p, ALT_DO_PART)) {
737 NODE_T *until_part = NEXT_SUB (p);
738 if (IS (until_part, SERIAL_CLAUSE)) {
739 until_part = NEXT (until_part);
740 }
741 conditional = (BOOL_T) (until_part != NO_NODE && IS (until_part, UNTIL_PART));
742 } else {
743 conditional = A68_FALSE;
744 }
745 if (conditional) {
746 // [FOR ...] [WHILE ...] DO [...] [UNTIL ...] OD.
747 siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
748 while (siga) {
749 if (for_part != NO_NODE) {
750 A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part))));
751 STATUS (z) = INIT_MASK;
752 VALUE (z) = counter;
753 }
754 A68_SP = pop_sp;
755 if (IS (p, WHILE_PART)) {
756 ENQUIRY_CLAUSE (q);
757 A68_SP = pop_sp;
758 siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) != A68_FALSE);
759 }
760 if (siga) {
761 volatile NODE_T *do_part = p, *until_part;
762 if (IS (p, WHILE_PART)) {
763 do_part = NEXT_SUB (NEXT (p));
764 OPEN_STATIC_FRAME ((NODE_T *) do_part);
765 INIT_STATIC_FRAME ((NODE_T *) do_part);
766 } else {
767 do_part = NEXT_SUB (p);
768 }
769 if (IS (do_part, SERIAL_CLAUSE)) {
770 SERIAL_CLAUSE (do_part);
771 until_part = NEXT (do_part);
772 } else {
773 until_part = do_part;
774 }
775 // UNTIL part.
776 if (until_part != NO_NODE && IS (until_part, UNTIL_PART)) {
777 NODE_T *v = NEXT_SUB (until_part);
778 OPEN_STATIC_FRAME ((NODE_T *) v);
779 INIT_STATIC_FRAME ((NODE_T *) v);
780 A68_SP = pop_sp;
781 ENQUIRY_CLAUSE (v);
782 A68_SP = pop_sp;
783 siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) == A68_FALSE);
784 CLOSE_FRAME;
785 }
786 if (IS (p, WHILE_PART)) {
787 CLOSE_FRAME;
788 }
789 // Increment counter.
790 if (siga) {
791 INCREMENT_COUNTER;
792 siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
793 }
794 // The genie cannot take things to next iteration: re-initialise stack frame.
795 if (siga) {
796 FRAME_CLEAR (AP_INCREMENT (TABLE (q)));
797 if (INITIALISE_FRAME (TABLE (q))) {
798 initialise_frame ((NODE_T *) q);
799 }
800 }
801 }
802 }
803 } else {
804 // [FOR ...] DO ... OD.
805 siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
806 while (siga) {
807 if (for_part != NO_NODE) {
808 A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part))));
809 STATUS (z) = INIT_MASK;
810 VALUE (z) = counter;
811 }
812 A68_SP = pop_sp;
813 SERIAL_CLAUSE (q);
814 INCREMENT_COUNTER;
815 siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
816 // The genie cannot take things to next iteration: re-initialise stack frame.
817 if (siga) {
818 FRAME_CLEAR (AP_INCREMENT (TABLE (q)));
819 if (INITIALISE_FRAME (TABLE (q))) {
820 initialise_frame ((NODE_T *) q);
821 }
822 }
823 }
824 }
825 // OD.
826 CLOSE_FRAME;
827 A68_SP = pop_sp;
828 return GPROP (p);
829 }
830
831 #undef INCREMENT_COUNTER
832 #undef LOOP_OVERFLOW
833
834 //! @brief Execute closed clause.
835
836 PROP_T genie_closed (volatile NODE_T * p)
837 {
838 jmp_buf exit_buf;
839 volatile NODE_T *q = NEXT_SUB (p);
840 OPEN_STATIC_FRAME ((NODE_T *) q);
841 INIT_GLOBAL_POINTER ((NODE_T *) q);
842 INIT_STATIC_FRAME ((NODE_T *) q);
843 SERIAL_CLAUSE (q);
844 CLOSE_FRAME;
845 return GPROP (p);
846 }
847
848 //! @brief Execute enclosed clause.
849
850 PROP_T genie_enclosed (volatile NODE_T * p)
851 {
852 PROP_T self;
853 UNIT (&self) = (PROP_PROC *) genie_enclosed;
854 SOURCE (&self) = (NODE_T *) p;
855 switch (ATTRIBUTE (p)) {
856 case PARTICULAR_PROGRAM: {
857 self = genie_enclosed (SUB (p));
858 break;
859 }
860 case ENCLOSED_CLAUSE: {
861 self = genie_enclosed (SUB (p));
862 break;
863 }
864 case CLOSED_CLAUSE: {
865 self = genie_closed ((NODE_T *) p);
866 if (UNIT (&self) == genie_unit) {
867 UNIT (&self) = (PROP_PROC *) genie_closed;
868 SOURCE (&self) = (NODE_T *) p;
869 }
870 break;
871 }
872 #if defined (BUILD_PARALLEL_CLAUSE)
873 case PARALLEL_CLAUSE: {
874 (void) genie_parallel ((NODE_T *) NEXT_SUB (p));
875 break;
876 }
877 #endif
878 case COLLATERAL_CLAUSE: {
879 (void) genie_collateral ((NODE_T *) p);
880 break;
881 }
882 case CONDITIONAL_CLAUSE: {
883 MOID (SUB ((NODE_T *) p)) = MOID (p);
884 (void) genie_conditional (p);
885 UNIT (&self) = (PROP_PROC *) genie_conditional;
886 SOURCE (&self) = (NODE_T *) p;
887 break;
888 }
889 case CASE_CLAUSE: {
890 MOID (SUB ((NODE_T *) p)) = MOID (p);
891 (void) genie_int_case (p);
892 UNIT (&self) = (PROP_PROC *) genie_int_case;
893 SOURCE (&self) = (NODE_T *) p;
894 break;
895 }
896 case CONFORMITY_CLAUSE: {
897 MOID (SUB ((NODE_T *) p)) = MOID (p);
898 (void) genie_united_case (p);
899 UNIT (&self) = (PROP_PROC *) genie_united_case;
900 SOURCE (&self) = (NODE_T *) p;
901 break;
902 }
903 case LOOP_CLAUSE: {
904 (void) genie_loop (SUB ((NODE_T *) p));
905 UNIT (&self) = (PROP_PROC *) genie_loop;
906 SOURCE (&self) = SUB ((NODE_T *) p);
907 break;
908 }
909 }
910 GPROP (p) = self;
911 return self;
912 }
