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-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 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 NODE_T *seq = &top_seq;
224 GINFO_T g;
225 GINFO (&top_seq) = &g;
226 genie_argument (NEXT (proc), &seq);
227 SEQUENCE (p) = SEQUENCE (&top_seq);
228 STATUS_SET (p, SEQUENCE_MASK);
229 } else {
230 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
231 GENIE_UNIT_NO_GC (q);
232 STACK_DNS (p, MOID (q), A68_FP);
233 }
234 }
235 genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
236 return GPROP (p);
237 }
238
239 //! @brief Call PROC with arguments and push result.
240
241 PROP_T genie_call (NODE_T * p)
242 {
243 ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
244 PROP_T self;
245 UNIT (&self) = genie_call_quick;
246 SOURCE (&self) = p;
247 // Get procedure.
248 NODE_T *proc = SUB (p);
249 GENIE_UNIT_NO_GC (proc);
250 A68_PROCEDURE z;
251 POP_OBJECT (proc, &z, A68_PROCEDURE);
252 genie_check_initialisation (p, (BYTE_T *) & z, MOID (proc));
253 // Get arguments.
254 if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
255 NODE_T top_seq;
256 NODE_T *seq = &top_seq;
257 GINFO_T g;
258 GINFO (&top_seq) = &g;
259 genie_argument (NEXT (proc), &seq);
260 SEQUENCE (p) = SEQUENCE (&top_seq);
261 STATUS_SET (p, SEQUENCE_MASK);
262 } else {
263 for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
264 GENIE_UNIT_NO_GC (q);
265 }
266 }
267 genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp);
268 if (PARTIAL_LOCALE (GINFO (proc)) != M_VOID && MOID (&z) != PARTIAL_LOCALE (GINFO (proc))) {
269 ;
270 } else if (STATUS (&z) & STANDENV_PROC_MASK) {
271 if (UNIT (&GPROP (proc)) == genie_identifier_standenv_proc) {
272 UNIT (&self) = genie_call_standenv_quick;
273 }
274 }
275 return self;
276 }
