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