plugin-folder.c
1 //! @file plugin-folder.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 //! Plugin compiler constant folder.
25
26 #include "a68g.h"
27 #include "a68g-prelude.h"
28 #include "a68g-genie.h"
29 #include "a68g-optimiser.h"
30 #include "a68g-plugin.h"
31 #include "a68g-transput.h"
32
33 // Constant folder .
34 // Uses interpreter routines to calculate compile-time expressions.
35
36 //! @brief Whether mode is handled by the constant folder.
37
38 BOOL_T folder_mode (MOID_T * m)
39 {
40 if (primitive_mode (m)) {
41 return A68_TRUE;
42 } else if (m == M_COMPLEX) {
43 return A68_TRUE;
44 } else {
45 return A68_FALSE;
46 }
47 }
48
49 // Constant unit check.
50
51 //! @brief Whether constant collateral clause.
52
53 BOOL_T constant_collateral (NODE_T * p)
54 {
55 if (p == NO_NODE) {
56 return A68_TRUE;
57 } else if (IS (p, UNIT)) {
58 return (BOOL_T) (folder_mode (MOID (p)) && constant_unit (SUB (p)) && constant_collateral (NEXT (p)));
59 } else {
60 return (BOOL_T) (constant_collateral (SUB (p)) && constant_collateral (NEXT (p)));
61 }
62 }
63
64 //! @brief Whether constant serial clause.
65
66 void count_constant_units (NODE_T * p, int *total, int *good)
67 {
68 if (p != NO_NODE) {
69 if (IS (p, UNIT)) {
70 (*total)++;
71 if (constant_unit (p)) {
72 (*good)++;
73 }
74 count_constant_units (NEXT (p), total, good);
75 } else {
76 count_constant_units (SUB (p), total, good);
77 count_constant_units (NEXT (p), total, good);
78 }
79 }
80 }
81
82 //! @brief Whether constant serial clause.
83
84 BOOL_T constant_serial (NODE_T * p, int want)
85 {
86 int total = 0, good = 0;
87 count_constant_units (p, &total, &good);
88 if (want > 0) {
89 return total == want && total == good;
90 } else {
91 return total == good;
92 }
93 }
94
95 //! @brief Whether constant argument.
96
97 BOOL_T constant_argument (NODE_T * p)
98 {
99 if (p == NO_NODE) {
100 return A68_TRUE;
101 } else if (IS (p, UNIT)) {
102 return (BOOL_T) (folder_mode (MOID (p)) && constant_unit (p) && constant_argument (NEXT (p)));
103 } else {
104 return (BOOL_T) (constant_argument (SUB (p)) && constant_argument (NEXT (p)));
105 }
106 }
107
108 //! @brief Whether constant call.
109
110 BOOL_T constant_call (NODE_T * p)
111 {
112 if (IS (p, CALL)) {
113 NODE_T *prim = SUB (p);
114 NODE_T *idf = stems_from (prim, IDENTIFIER);
115 if (idf != NO_NODE) {
116 for (int k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
117 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
118 NODE_T *args = NEXT (prim);
119 return constant_argument (args);
120 }
121 }
122 }
123 }
124 return A68_FALSE;
125 }
126
127 //! @brief Whether constant monadic formula.
128
129 BOOL_T constant_monadic_formula (NODE_T * p)
130 {
131 if (IS (p, MONADIC_FORMULA)) {
132 NODE_T *op = SUB (p);
133 for (int k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
134 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
135 NODE_T *rhs = NEXT (op);
136 return constant_unit (rhs);
137 }
138 }
139 }
140 return A68_FALSE;
141 }
142
143 //! @brief Whether constant dyadic formula.
144
145 BOOL_T constant_formula (NODE_T * p)
146 {
147 if (IS (p, FORMULA)) {
148 NODE_T *lhs = SUB (p);
149 NODE_T *op = NEXT (lhs);
150 if (op == NO_NODE) {
151 return constant_monadic_formula (lhs);
152 } else {
153 for (int k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
154 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
155 NODE_T *rhs = NEXT (op);
156 return (BOOL_T) (constant_unit (lhs) && constant_unit (rhs));
157 }
158 }
159 }
160 }
161 return A68_FALSE;
162 }
163
164 //! @brief Whether constant unit.
165
166 BOOL_T constant_unit (NODE_T * p)
167 {
168 if (p == NO_NODE) {
169 return A68_FALSE;
170 } else if (IS (p, UNIT)) {
171 return constant_unit (SUB (p));
172 } else if (IS (p, TERTIARY)) {
173 return constant_unit (SUB (p));
174 } else if (IS (p, SECONDARY)) {
175 return constant_unit (SUB (p));
176 } else if (IS (p, PRIMARY)) {
177 return constant_unit (SUB (p));
178 } else if (IS (p, ENCLOSED_CLAUSE)) {
179 return constant_unit (SUB (p));
180 } else if (IS (p, CLOSED_CLAUSE)) {
181 return constant_serial (NEXT_SUB (p), 1);
182 } else if (IS (p, COLLATERAL_CLAUSE)) {
183 return folder_mode (MOID (p)) && constant_collateral (NEXT_SUB (p));
184 } else if (IS (p, WIDENING)) {
185 if (WIDEN_TO (p, INT, REAL)) {
186 return constant_unit (SUB (p));
187 } else if (WIDEN_TO (p, REAL, COMPLEX)) {
188 return constant_unit (SUB (p));
189 } else {
190 return A68_FALSE;
191 }
192 } else if (IS (p, IDENTIFIER)) {
193 if (A68_STANDENV_PROC (TAX (p))) {
194 for (int k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
195 if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
196 return A68_TRUE;
197 }
198 }
199 return A68_FALSE;
200 } else {
201 // Possible constant folding.
202 NODE_T *def = NODE (TAX (p));
203 BOOL_T ret = A68_FALSE;
204 if (STATUS (p) & COOKIE_MASK) {
205 diagnostic (A68_WARNING, p, WARNING_UNINITIALISED);
206 } else {
207 STATUS (p) |= COOKIE_MASK;
208 if (folder_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) {
209 ret = constant_unit (NEXT_NEXT (def));
210 }
211 }
212 STATUS (p) &= !(COOKIE_MASK);
213 return ret;
214 }
215 } else if (IS (p, DENOTATION)) {
216 return primitive_mode (MOID (p));
217 } else if (IS (p, MONADIC_FORMULA)) {
218 return (BOOL_T) (folder_mode (MOID (p)) && constant_monadic_formula (p));
219 } else if (IS (p, FORMULA)) {
220 return (BOOL_T) (folder_mode (MOID (p)) && constant_formula (p));
221 } else if (IS (p, CALL)) {
222 return (BOOL_T) (folder_mode (MOID (p)) && constant_call (p));
223 } else if (IS (p, CAST)) {
224 return (BOOL_T) (folder_mode (MOID (SUB (p))) && constant_unit (NEXT_SUB (p)));
225 } else {
226 return A68_FALSE;
227 }
228 }
229
230 // Evaluate compile-time expressions using interpreter routines.
231
232 //! @brief Push denotation.
233
234 void push_denotation (NODE_T * p)
235 {
236 #define PUSH_DENOTATION(mode, decl) {\
237 decl z;\
238 NODE_T *s = (IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p));\
239 if (genie_string_to_value_internal (p, MODE (mode), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {\
240 diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\
241 }\
242 PUSH_VALUE (p, VALUE (&z), decl);}
243
244 if (MOID (p) == M_INT) {
245 PUSH_DENOTATION (INT, A68_INT);
246 } else if (MOID (p) == M_REAL) {
247 PUSH_DENOTATION (REAL, A68_REAL);
248 } else if (MOID (p) == M_BOOL) {
249 PUSH_DENOTATION (BOOL, A68_BOOL);
250 } else if (MOID (p) == M_CHAR) {
251 if ((NSYMBOL (p))[0] == NULL_CHAR) {
252 PUSH_VALUE (p, NULL_CHAR, A68_CHAR);
253 } else {
254 PUSH_VALUE (p, (NSYMBOL (p))[0], A68_CHAR);
255 }
256 } else if (MOID (p) == M_BITS) {
257 PUSH_DENOTATION (BITS, A68_BITS);
258 }
259 #undef PUSH_DENOTATION
260 }
261
262 //! @brief Push widening.
263
264 void push_widening (NODE_T * p)
265 {
266 push_unit (SUB (p));
267 if (WIDEN_TO (p, INT, REAL)) {
268 A68_INT k;
269 POP_OBJECT (p, &k, A68_INT);
270 PUSH_VALUE (p, (REAL_T) VALUE (&k), A68_REAL);
271 } else if (WIDEN_TO (p, REAL, COMPLEX)) {
272 PUSH_VALUE (p, 0.0, A68_REAL);
273 }
274 }
275
276 //! @brief Code collateral units.
277
278 void push_collateral_units (NODE_T * p)
279 {
280 if (p == NO_NODE) {
281 return;
282 } else if (IS (p, UNIT)) {
283 push_unit (p);
284 } else {
285 push_collateral_units (SUB (p));
286 push_collateral_units (NEXT (p));
287 }
288 }
289
290 //! @brief Code argument.
291
292 void push_argument (NODE_T * p)
293 {
294 for (; p != NO_NODE; FORWARD (p)) {
295 if (IS (p, UNIT)) {
296 push_unit (p);
297 } else {
298 push_argument (SUB (p));
299 }
300 }
301 }
302
303 //! @brief Push unit.
304
305 void push_unit (NODE_T * p)
306 {
307 if (p == NO_NODE) {
308 return;
309 }
310 if (IS (p, UNIT)) {
311 push_unit (SUB (p));
312 } else if (IS (p, TERTIARY)) {
313 push_unit (SUB (p));
314 } else if (IS (p, SECONDARY)) {
315 push_unit (SUB (p));
316 } else if (IS (p, PRIMARY)) {
317 push_unit (SUB (p));
318 } else if (IS (p, ENCLOSED_CLAUSE)) {
319 push_unit (SUB (p));
320 } else if (IS (p, CLOSED_CLAUSE)) {
321 push_unit (SUB (NEXT_SUB (p)));
322 } else if (IS (p, COLLATERAL_CLAUSE)) {
323 push_collateral_units (NEXT_SUB (p));
324 } else if (IS (p, WIDENING)) {
325 push_widening (p);
326 } else if (IS (p, IDENTIFIER)) {
327 if (A68_STANDENV_PROC (TAX (p))) {
328 (void) (*(PROCEDURE (TAX (p)))) (p);
329 } else {
330 // Possible constant folding
331 NODE_T *def = NODE (TAX (p));
332 push_unit (NEXT_NEXT (def));
333 }
334 } else if (IS (p, DENOTATION)) {
335 push_denotation (p);
336 } else if (IS (p, MONADIC_FORMULA)) {
337 NODE_T *op = SUB (p);
338 NODE_T *rhs = NEXT (op);
339 push_unit (rhs);
340 (*(PROCEDURE (TAX (op)))) (op);
341 } else if (IS (p, FORMULA)) {
342 NODE_T *lhs = SUB (p);
343 NODE_T *op = NEXT (lhs);
344 if (op == NO_NODE) {
345 push_unit (lhs);
346 } else {
347 NODE_T *rhs = NEXT (op);
348 push_unit (lhs);
349 push_unit (rhs);
350 (*(PROCEDURE (TAX (op)))) (op);
351 }
352 } else if (IS (p, CALL)) {
353 NODE_T *prim = SUB (p);
354 NODE_T *args = NEXT (prim);
355 NODE_T *idf = stems_from (prim, IDENTIFIER);
356 push_argument (args);
357 (void) (*(PROCEDURE (TAX (idf)))) (p);
358 } else if (IS (p, CAST)) {
359 push_unit (NEXT_SUB (p));
360 }
361 }
362
363 //! @brief Code constant folding.
364
365 void constant_folder (NODE_T * p, FILE_T out, int phase)
366 {
367 if (phase == L_DECLARE) {
368 if (MOID (p) == M_COMPLEX) {
369 char acc[NAME_SIZE];
370 A68_REAL re, im;
371 (void) make_name (acc, CON, "", NUMBER (p));
372 A68_SP = 0;
373 push_unit (p);
374 POP_OBJECT (p, &im, A68_REAL);
375 POP_OBJECT (p, &re, A68_REAL);
376 indentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "A68_COMPLEX %s = {", acc));
377 undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "{INIT_MASK, %.*g}", A68_REAL_WIDTH + 2, VALUE (&re)));
378 undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, ", {INIT_MASK, %.*g}", A68_REAL_WIDTH + 2, VALUE (&im)));
379 undent (out, "};\n");
380 ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
381 }
382 } else if (phase == L_EXECUTE) {
383 if (MOID (p) == M_COMPLEX) {
384 // Done at declaration stage
385 }
386 } else if (phase == L_YIELD) {
387 if (MOID (p) == M_INT) {
388 A68_INT k;
389 A68_SP = 0;
390 push_unit (p);
391 POP_OBJECT (p, &k, A68_INT);
392 ASSERT (a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, A68_LD, VALUE (&k)) >= 0);
393 undent (out, A68 (edit_line));
394 ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
395 } else if (MOID (p) == M_REAL) {
396 A68_REAL x;
397 A68_SP = 0;
398 push_unit (p);
399 POP_OBJECT (p, &x, A68_REAL);
400 // Mind overflowing or underflowing values.
401 if (!a68_finite_real (VALUE (&x))) {
402 A68_OPT (code_errors)++;
403 VALUE (&x) = 0.0;
404 }
405 if (VALUE (&x) == A68_REAL_MAX) {
406 undent (out, "A68_REAL_MAX");
407 } else if (VALUE (&x) == -A68_REAL_MAX) {
408 undent (out, "(-A68_REAL_MAX)");
409 } else {
410 ASSERT (a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%.*g", A68_REAL_WIDTH + 2, VALUE (&x)) >= 0);
411 undent (out, A68 (edit_line));
412 }
413 ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
414 } else if (MOID (p) == M_BOOL) {
415 A68_BOOL b;
416 A68_SP = 0;
417 push_unit (p);
418 POP_OBJECT (p, &b, A68_BOOL);
419 ASSERT (a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", (VALUE (&b) ? "A68_TRUE" : "A68_FALSE")) >= 0);
420 undent (out, A68 (edit_line));
421 ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
422 } else if (MOID (p) == M_CHAR) {
423 A68_CHAR c;
424 A68_SP = 0;
425 push_unit (p);
426 POP_OBJECT (p, &c, A68_CHAR);
427 if (VALUE (&c) == '\'') {
428 undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "'\\\''"));
429 } else if (VALUE (&c) == '\\') {
430 undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "'\\\\'"));
431 } else if (VALUE (&c) == NULL_CHAR) {
432 undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "NULL_CHAR"));
433 } else if (IS_PRINT (VALUE (&c))) {
434 undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "'%c'", (CHAR_T) VALUE (&c)));
435 } else {
436 undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(CHAR_T) %d", VALUE (&c)));
437 }
438 ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
439 } else if (MOID (p) == M_BITS) {
440 A68_BITS b;
441 A68_SP = 0;
442 push_unit (p);
443 POP_OBJECT (p, &b, A68_BITS);
444 ASSERT (a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(UNSIGNED_T) 0x" A68_LX, VALUE (&b)) >= 0);
445 undent (out, A68 (edit_line));
446 ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
447 } else if (MOID (p) == M_COMPLEX) {
448 char acc[NAME_SIZE];
449 (void) make_name (acc, CON, "", NUMBER (p));
450 undentf (out, a68_bufprt (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) %s", acc));
451 }
452 }
453 }
