genie-call.c
1 //! @file genie-call.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 procedure calls.
25
26 // Algol 68 Genie implements Charles Lindsey's proposal for partial parametrization.
27 // A procedure has a locale to store parameters until the pack is complete, and only
28 // then the procedure is actually called.
29
30 #include "a68g.h"
31 #include "a68g-genie.h"
32 #include "a68g-frames.h"
33 #include "a68g-prelude.h"
34 #include "a68g-transput.h"
35
36 void genie_argument (NODE_T * p, NODE_T ** seq)
37 {
38 for (; p != NO_NODE; FORWARD (p)) {
39 if (IS (p, UNIT)) {
40 GENIE_UNIT_NO_GC (p);
41 STACK_DNS (p, MOID (p), A68_FP);
42 SEQUENCE (*seq) = p;
43 (*seq) = p;
44 return;
45 } else if (IS (p, TRIMMER)) {
46 return;
47 } else {
48 genie_argument (SUB (p), seq);
49 }
50 }
51 }
52
53 //! @brief Evaluate partial call.
54
55 void genie_partial_call (NODE_T * p, MOID_T * p_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE z, ADDR_T pop_sp, ADDR_T pop_fp)
56 {
57 // Get or make locale for the new procedure descriptor.
58 A68_REF ref; A68_HANDLE *locale;
59 if (LOCALE (&z) == NO_HANDLE) {
60 int size = 0;
61 for (PACK_T *s = PACK (p_mode); s != NO_PACK; FORWARD (s)) {
62 size += (SIZE (M_BOOL) + SIZE (MOID (s)));
63 }
64 ref = heap_generator (p, p_mode, size);
65 locale = REF_HANDLE (&ref);
66 } else {
67 int size = SIZE (LOCALE (&z));
68 ref = heap_generator (p, p_mode, size);
69 locale = REF_HANDLE (&ref);
70 COPY (POINTER (locale), POINTER (LOCALE (&z)), size);
71 }
72 // Move arguments from stack to locale using pmap.
73 BYTE_T *u = POINTER (locale), *v = STACK_ADDRESS (pop_sp);
74 // Uninitialised arguments are VOID.
75 int voids = 0;
76 PACK_T *s = PACK (p_mode);
77 for (PACK_T *t = PACK (pmap); t != NO_PACK && s != NO_PACK; FORWARD (t)) {
78 // Skip already initialised arguments.
79 while (u != NULL && VALUE ((A68_BOOL *) & u[0])) {
80 u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
81 FORWARD (s);
82 }
83 if (u != NULL && MOID (t) == M_VOID) {
84 // Move to next field in locale.
85 voids++;
86 u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
87 FORWARD (s);
88 } else {
89 // Move argument from stack to locale.
90 A68_BOOL w;
91 STATUS (&w) = INIT_MASK;
92 VALUE (&w) = A68_TRUE;
93 *(A68_BOOL *) & u[0] = w;
94 COPY (&(u[SIZE (M_BOOL)]), v, SIZE (MOID (t)));
95 u = &(u[SIZE (M_BOOL) + SIZE (MOID (s))]);
96 v = &(v[SIZE (MOID (t))]);
97 FORWARD (s);
98 }
99 }
100 A68_SP = pop_sp;
101 LOCALE (&z) = locale;
102 // When closure is complete, push locale onto the stack and call procedure body.
103 if (voids == 0) {
104 A68_SP = pop_sp;
105 u = POINTER (locale);
106 v = STACK_ADDRESS (A68_SP);
107 for (s = PACK (p_mode); s != NO_PACK; FORWARD (s)) {
108 int size = SIZE (MOID (s));
109 COPY (v, &u[SIZE (M_BOOL)], size);
110 u = &(u[SIZE (M_BOOL) + size]);
111 v = &(v[SIZE (MOID (s))]);
112 INCREMENT_STACK_POINTER (p, size);
113 }
114 genie_call_procedure (p, p_mode, pproc, M_VOID, &z, pop_sp, pop_fp);
115 } else {
116 // Closure is not complete. Return procedure body.
117 PUSH_PROCEDURE (p, z);
118 }
119 }
120
121 //! @brief Closure and deproceduring of routines with PARAMSETY.
122
123 void genie_call_procedure (NODE_T * p, MOID_T * p_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE * z, ADDR_T pop_sp, ADDR_T pop_fp)
124 {
125 if (pmap != M_VOID && p_mode != pmap) {
126 genie_partial_call (p, p_mode, pproc, pmap, *z, pop_sp, pop_fp);
127 } else if (STATUS (z) & STANDENV_PROC_MASK) {
128 NODE_T *save = A68 (f_entry);
129 A68 (f_entry) = p;
130 (void) ((*(PROCEDURE (&(BODY (z))))) (p));
131 A68 (f_entry) = save;
132 } else if (STATUS (z) & SKIP_PROCEDURE_MASK) {
133 A68_SP = pop_sp;
134 genie_push_undefined (p, SUB ((MOID (z))));
135 } else {
136 NODE_T *body = NODE (&(BODY (z)));
137 if (IS (body, ROUTINE_TEXT)) {
138 NODE_T *entry = SUB (body);
139 ADDR_T fp0 = 0;
140 // Copy arguments from stack to frame.
141 OPEN_PROC_FRAME (entry, ENVIRON (z));
142 INIT_STATIC_FRAME (entry);
143 FRAME_DNS (A68_FP) = pop_fp;
144 for (PACK_T *args = PACK (p_mode); args != NO_PACK; FORWARD (args)) {
145 int size = SIZE (MOID (args));
146 COPY ((FRAME_OBJECT (fp0)), STACK_ADDRESS (pop_sp + fp0), size);
147 fp0 += size;
148 }
149 A68_SP = pop_sp;
150 ARGSIZE (GINFO (p)) = fp0;
151 // Interpret routine text.
152 if (DIM (p_mode) > 0) {
153 // With PARAMETERS.
154 entry = NEXT (NEXT_NEXT (entry));
155 } else {
156 // Without PARAMETERS.
157 entry = NEXT_NEXT (entry);
158 }
159 GENIE_UNIT_TRACE (entry);
160 if (A68_FP == A68_MON (finish_frame_pointer)) {
161 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
162 }
163 CLOSE_FRAME;
164 STACK_DNS (p, SUB (p_mode), A68_FP);
165 } else {
166 OPEN_PROC_FRAME (body, ENVIRON (z));
167 INIT_STATIC_FRAME (body);
168 FRAME_DNS (A68_FP) = pop_fp;
169 GENIE_UNIT_TRACE (body);
170 if (A68_FP == A68_MON (finish_frame_pointer)) {
171 change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);
172 }
173 CLOSE_FRAME;
174 STACK_DNS (p, SUB (p_mode), A68_FP);
175 }
176 }
177 }
178
179 //! @brief Call event routine.
180
181 void genie_call_event_routine (NODE_T * p, MOID_T * m, A68_PROCEDURE * proc, ADDR_T pop_sp, ADDR_T pop_fp)
182 {
183 if (NODE (&(BODY (proc))) != NO_NODE) {
184 A68_PROCEDURE save = *proc;
185 set_default_event_procedure (proc);
186 genie_call_procedure (p, MOID (&save), m, m, &save, pop_sp, pop_fp);
187 (*proc) = save;
188 }
189 }
190
191 //! @brief Call PROC with arguments and push result.
192
193 PROP_T genie_call_standenv_quick (NODE_T * p)
194 {
195 NODE_T *save = A68 (f_entry);
196 A68 (f_entry) = p;
197 NODE_T *pr = SUB (p);
198 TAG_T *proc = TAX (SOURCE (&GPROP (pr)));
199 // Get arguments.
200 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
201 GENIE_UNIT_NO_GC (q);
202 STACK_DNS (p, MOID (q), A68_FP);
203 }
204 (void) ((*(PROCEDURE (proc))) (p));
205 A68 (f_entry) = save;
206 return GPROP (p);
207 }
208
209 //! @brief Call PROC with arguments and push result.
210
211 PROP_T genie_call_quick (NODE_T * p)
212 {
213 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
214 // Get procedure.
215 NODE_T *proc = SUB (p);
216 GENIE_UNIT_NO_GC (proc);
217 A68_PROCEDURE z;
218 POP_OBJECT (proc, &z, A68_PROCEDURE);
219 genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
220 // Get arguments.
221 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
222 NODE_T top_seq;
223 GINFO_T g;
224 NODE_T *seq = &top_seq;
225 GINFO (seq) = &g;
226 SEQUENCE (seq) = NO_NODE;
227 genie_argument (NEXT (proc), &seq);
228 SEQUENCE (p) = SEQUENCE (&top_seq);
229 STATUS_SET (p, SEQUENCE_MASK);
230 } else {
231 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
232 GENIE_UNIT_NO_GC (q);
233 STACK_DNS (p, MOID (q), A68_FP);
234 }
235 }
236 genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
237 return GPROP (p);
238 }
239
240 //! @brief Call PROC with arguments and push result.
241
242 PROP_T genie_call (NODE_T * p)
243 {
244 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
245 PROP_T self;
246 UNIT (&self) = genie_call_quick;
247 SOURCE (&self) = p;
248 // Get procedure.
249 NODE_T *proc = SUB (p);
250 GENIE_UNIT_NO_GC (proc);
251 A68_PROCEDURE z;
252 POP_OBJECT (proc, &z, A68_PROCEDURE);
253 genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
254 // Get arguments.
255 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
256 NODE_T top_seq;
257 GINFO_T g;
258 NODE_T *seq = &top_seq;
259 GINFO (seq) = &g;
260 SEQUENCE (seq) = NO_NODE;
261 genie_argument (NEXT (proc), &seq);
262 SEQUENCE (p) = SEQUENCE (&top_seq);
263 STATUS_SET (p, SEQUENCE_MASK);
264 } else {
265 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
266 GENIE_UNIT_NO_GC (q);
267 }
268 }
269 genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
270 if (PARTIAL_LOCALE (GINFO (proc)) != M_VOID && MOID (&z) != PARTIAL_LOCALE (GINFO (proc))) {
271 ;
272 } else if (STATUS (&z) & STANDENV_PROC_MASK) {
273 if (UNIT (&GPROP (proc)) == genie_identifier_standenv_proc) {
274 UNIT (&self) = genie_call_standenv_quick;
275 }
276 }
277 return self;
278 }
