genie-hip.c
1 //! @file genie-hip.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 jumps and SKIP.
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
33 //! @brief Push an undefined value of the required mode.
34
35 void genie_push_undefined (NODE_T * p, MOID_T * u)
36 {
37 // For primitive modes we push an initialised value.
38 if (u == M_VOID) {
39 ;
40 } else if (u == M_INT) {
41 PUSH_VALUE (p, 1, A68_INT); // Because users write [~] INT !
42 } else if (u == M_REAL) {
43 PUSH_VALUE (p, (a68_unif_rand ()), A68_REAL);
44 } else if (u == M_BOOL) {
45 PUSH_VALUE (p, (BOOL_T) (a68_unif_rand () < 0.5), A68_BOOL);
46 } else if (u == M_CHAR) {
47 PUSH_VALUE (p, (char) (32 + 96 * a68_unif_rand ()), A68_CHAR);
48 } else if (u == M_BITS) {
49 PUSH_VALUE (p, (UNSIGNED_T) (a68_unif_rand () * (double) A68_MAX_BITS), A68_BITS);
50 } else if (u == M_COMPLEX) {
51 PUSH_COMPLEX (p, a68_unif_rand (), a68_unif_rand ());
52 } else if (u == M_BYTES) {
53 PUSH_BYTES (p, "SKIP");
54 } else if (u == M_LONG_BYTES) {
55 PUSH_LONG_BYTES (p, "SKIP");
56 } else if (u == M_STRING) {
57 PUSH_REF (p, empty_string (p));
58 } else if (u == M_LONG_INT) {
59 #if (A68_LEVEL >= 3)
60 DOUBLE_NUM_T w;
61 set_lw (w, 1);
62 PUSH_VALUE (p, w, A68_LONG_INT); // Because users write [~] INT !
63 #else
64 (void) nil_mp (p, DIGITS (u));
65 #endif
66 } else if (u == M_LONG_REAL) {
67 #if (A68_LEVEL >= 3)
68 genie_next_random_double (p);
69 #else
70 (void) nil_mp (p, DIGITS (u));
71 #endif
72 } else if (u == M_LONG_BITS) {
73 #if (A68_LEVEL >= 3)
74 DOUBLE_NUM_T w;
75 set_lw (w, 1);
76 PUSH_VALUE (p, w, A68_LONG_BITS); // Because users write [~] INT !
77 #else
78 (void) nil_mp (p, DIGITS (u));
79 #endif
80 } else if (u == M_LONG_LONG_INT) {
81 (void) nil_mp (p, DIGITS (u));
82 } else if (u == M_LONG_LONG_REAL) {
83 (void) nil_mp (p, DIGITS (u));
84 } else if (u == M_LONG_LONG_BITS) {
85 (void) nil_mp (p, DIGITS (u));
86 } else if (u == M_LONG_COMPLEX) {
87 #if (A68_LEVEL >= 3)
88 genie_next_random_double (p);
89 genie_next_random_double (p);
90 #else
91 (void) nil_mp (p, DIGITS_COMPL (u));
92 (void) nil_mp (p, DIGITS_COMPL (u));
93 #endif
94 } else if (u == M_LONG_LONG_COMPLEX) {
95 (void) nil_mp (p, DIGITS_COMPL (u));
96 (void) nil_mp (p, DIGITS_COMPL (u));
97 } else if (IS_REF (u)) {
98 // All REFs are NIL.
99 PUSH_REF (p, nil_ref);
100 } else if (IS_ROW (u) || IS_FLEX (u)) {
101 // [] AMODE or FLEX [] AMODE.
102 A68_REF er = empty_row (p, u);
103 STATUS (&er) |= SKIP_ROW_MASK;
104 PUSH_REF (p, er);
105 } else if (IS_STRUCT (u)) {
106 // STRUCT.
107 for (PACK_T *v = PACK (u); v != NO_PACK; FORWARD (v)) {
108 genie_push_undefined (p, MOID (v));
109 }
110 } else if (IS_UNION (u)) {
111 // UNION.
112 ADDR_T pop_sp = A68_SP;
113 PUSH_UNION (p, MOID (PACK (u)));
114 genie_push_undefined (p, MOID (PACK (u)));
115 A68_SP = pop_sp + SIZE (u);
116 } else if (IS (u, PROC_SYMBOL)) {
117 // PROC.
118 A68_PROCEDURE z;
119 STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | SKIP_PROCEDURE_MASK);
120 (NODE (&BODY (&z))) = NO_NODE;
121 ENVIRON (&z) = 0;
122 LOCALE (&z) = NO_HANDLE;
123 MOID (&z) = u;
124 PUSH_PROCEDURE (p, z);
125 } else if (u == M_FORMAT) {
126 // FORMAT etc. - what arbitrary FORMAT could mean anything at all?.
127 A68_FORMAT z;
128 STATUS (&z) = (STATUS_MASK_T) (INIT_MASK | SKIP_FORMAT_MASK);
129 BODY (&z) = NO_NODE;
130 ENVIRON (&z) = 0;
131 PUSH_FORMAT (p, z);
132 } else if (u == M_SIMPLOUT) {
133 ADDR_T pop_sp = A68_SP;
134 PUSH_UNION (p, M_STRING);
135 PUSH_REF (p, c_to_a_string (p, "SKIP", DEFAULT_WIDTH));
136 A68_SP = pop_sp + SIZE (u);
137 } else if (u == M_SIMPLIN) {
138 ADDR_T pop_sp = A68_SP;
139 PUSH_UNION (p, M_REF_STRING);
140 genie_push_undefined (p, M_REF_STRING);
141 A68_SP = pop_sp + SIZE (u);
142 } else if (u == M_REF_FILE) {
143 PUSH_REF (p, A68 (skip_file));
144 } else if (u == M_FILE) {
145 A68_REF *z = (A68_REF *) STACK_TOP;
146 int size = SIZE (M_FILE);
147 ADDR_T pop_sp = A68_SP;
148 PUSH_REF (p, A68 (skip_file));
149 A68_SP = pop_sp;
150 PUSH (p, ADDRESS (z), size);
151 } else if (u == M_CHANNEL) {
152 PUSH_OBJECT (p, A68 (skip_channel), A68_CHANNEL);
153 } else if (u == M_PIPE) {
154 genie_push_undefined (p, M_REF_FILE);
155 genie_push_undefined (p, M_REF_FILE);
156 genie_push_undefined (p, M_INT);
157 } else if (u == M_SOUND) {
158 A68_SOUND *z = (A68_SOUND *) STACK_TOP;
159 int size = SIZE (M_SOUND);
160 INCREMENT_STACK_POINTER (p, size);
161 FILL (z, 0, size);
162 STATUS (z) = INIT_MASK;
163 } else {
164 BYTE_T *tos = STACK_TOP;
165 int size = SIZE_ALIGNED (u);
166 INCREMENT_STACK_POINTER (p, size);
167 FILL (tos, 0, size);
168 }
169 }
170
171 //! @brief Push an undefined value of the required mode.
172
173 PROP_T genie_skip (NODE_T * p)
174 {
175 PROP_T self;
176 if (MOID (p) != M_VOID) {
177 genie_push_undefined (p, MOID (p));
178 }
179 UNIT (&self) = genie_skip;
180 SOURCE (&self) = p;
181 return self;
182 }
183
184 //! @brief Jump to the serial clause where the label is at.
185
186 void genie_jump (NODE_T * p)
187 {
188 // Stack pointer and frame pointer were saved at target serial clause.
189 NODE_T *jump = SUB (p);
190 NODE_T *label = (IS (jump, GOTO_SYMBOL)) ? NEXT (jump) : jump;
191 ADDR_T target_frame_pointer = A68_FP;
192 jmp_buf *jump_stat = NO_JMP_BUF;
193 // Find the stack frame this jump points to.
194 BOOL_T found = A68_FALSE;
195 while (target_frame_pointer > 0 && !found) {
196 found = (BOOL_T) ((TAG_TABLE (TAX (label)) == TABLE (FRAME_TREE (target_frame_pointer))) && FRAME_JUMP_STAT (target_frame_pointer) != NO_JMP_BUF);
197 if (!found) {
198 target_frame_pointer = FRAME_STATIC_LINK (target_frame_pointer);
199 }
200 }
201 // Beam us up, Scotty!.
202 #if defined (BUILD_PARALLEL_CLAUSE)
203 {
204 pthread_t target_id = FRAME_THREAD_ID (target_frame_pointer);
205 if (SAME_THREAD (target_id, pthread_self ())) {
206 jump_stat = FRAME_JUMP_STAT (target_frame_pointer);
207 JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label));
208 longjmp (*(jump_stat), 1);
209 } else if (SAME_THREAD (target_id, A68_PAR (main_thread_id))) {
210 // A jump out of all parallel clauses back into the main program.
211 genie_abend_all_threads (p, FRAME_JUMP_STAT (target_frame_pointer), label);
212 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
213 } else {
214 diagnostic (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_JUMP);
215 exit_genie (p, A68_RUNTIME_ERROR);
216 }
217 }
218 #else
219 jump_stat = FRAME_JUMP_STAT (target_frame_pointer);
220 JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label));
221 longjmp (*(jump_stat), 1);
222 #endif
223 }
