plugin-basic.c
1 //! @file plugin-basic.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 routines.
25
26 #include "a68g.h"
27 #include "a68g-optimiser.h"
28 #include "a68g-plugin.h"
29
30 // Whether stuff is sufficiently "basic" to be compiled.
31
32 //! @brief Whether primitive mode, with simple C equivalent.
33
34 BOOL_T primitive_mode (const MOID_T * m)
35 {
36 if (m == M_INT) {
37 return A68_TRUE;
38 } else if (m == M_REAL) {
39 return A68_TRUE;
40 } else if (m == M_BOOL) {
41 return A68_TRUE;
42 } else if (m == M_CHAR) {
43 return A68_TRUE;
44 } else if (m == M_BITS) {
45 return A68_TRUE;
46 } else {
47 return A68_FALSE;
48 }
49 }
50
51 //! @brief Whether basic mode, for which units are compiled.
52
53 BOOL_T basic_mode (MOID_T * m)
54 {
55 if (primitive_mode (m)) {
56 return A68_TRUE;
57 } else if (IS (m, REF_SYMBOL)) {
58 if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) {
59 return A68_FALSE;
60 } else {
61 return basic_mode (SUB (m));
62 }
63 } else if (IS (m, ROW_SYMBOL)) {
64 return A68_FALSE;
65 // Not (fully) implemented yet.
66 // TODO: code to convert stacked units into an array.
67 // if (primitive_mode (SUB (m))) {
68 // return A68_TRUE;
69 // } else if (IS (SUB (m), STRUCT_SYMBOL)) {
70 // return basic_mode (SUB (m));
71 // } else {
72 // return A68_FALSE;
73 // }
74 } else if (IS (m, STRUCT_SYMBOL)) {
75 for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) {
76 if (!primitive_mode (MOID (p))) {
77 return A68_FALSE;
78 }
79 }
80 return A68_TRUE;
81 } else {
82 return A68_FALSE;
83 }
84 }
85
86 //! @brief Whether basic mode, which is not a row.
87
88 BOOL_T basic_mode_non_row (MOID_T * m)
89 {
90 if (primitive_mode (m)) {
91 return A68_TRUE;
92 } else if (IS (m, REF_SYMBOL)) {
93 if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) {
94 return A68_FALSE;
95 } else {
96 return basic_mode_non_row (SUB (m));
97 }
98 } else if (IS (m, STRUCT_SYMBOL)) {
99 for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) {
100 if (!primitive_mode (MOID (p))) {
101 return A68_FALSE;
102 }
103 }
104 return A68_TRUE;
105 } else {
106 return A68_FALSE;
107 }
108 }
109
110 //! @brief Whether basic collateral clause.
111
112 BOOL_T basic_collateral (NODE_T * p)
113 {
114 if (p == NO_NODE) {
115 return A68_TRUE;
116 } else if (IS (p, UNIT)) {
117 return (BOOL_T) (basic_mode (MOID (p)) && basic_unit (SUB (p)) && basic_collateral (NEXT (p)));
118 } else {
119 return (BOOL_T) (basic_collateral (SUB (p)) && basic_collateral (NEXT (p)));
120 }
121 }
122
123 //! @brief Whether basic serial clause.
124
125 void count_basic_units (NODE_T * p, int *total, int *good)
126 {
127 for (; p != NO_NODE; FORWARD (p)) {
128 if (IS (p, UNIT)) {
129 (*total)++;
130 if (basic_unit (p)) {
131 (*good)++;
132 }
133 } else if (IS (p, DECLARATION_LIST)) {
134 (*total)++;
135 } else {
136 count_basic_units (SUB (p), total, good);
137 }
138 }
139 }
140
141 //! @brief Whether basic serial clause.
142
143 BOOL_T basic_serial (NODE_T * p, int want)
144 {
145 int total = 0, good = 0;
146 count_basic_units (p, &total, &good);
147 if (want > 0) {
148 return total == want && total == good;
149 } else {
150 return total == good;
151 }
152 }
153
154 //! @brief Whether basic indexer.
155
156 BOOL_T basic_indexer (NODE_T * p)
157 {
158 if (p == NO_NODE) {
159 return A68_TRUE;
160 } else if (IS (p, TRIMMER)) {
161 return A68_FALSE;
162 } else if (IS (p, UNIT)) {
163 return basic_unit (p);
164 } else {
165 return (BOOL_T) (basic_indexer (SUB (p)) && basic_indexer (NEXT (p)));
166 }
167 }
168
169 //! @brief Whether basic slice.
170
171 BOOL_T basic_slice (NODE_T * p)
172 {
173 if (IS (p, SLICE)) {
174 NODE_T *prim = SUB (p);
175 NODE_T *idf = stems_from (prim, IDENTIFIER);
176 if (idf != NO_NODE) {
177 NODE_T *indx = NEXT (prim);
178 return basic_indexer (indx);
179 }
180 }
181 return A68_FALSE;
182 }
183
184 //! @brief Whether basic argument.
185
186 BOOL_T basic_argument (NODE_T * p)
187 {
188 if (p == NO_NODE) {
189 return A68_TRUE;
190 } else if (IS (p, UNIT)) {
191 return (BOOL_T) (basic_mode (MOID (p)) && basic_unit (p) && basic_argument (NEXT (p)));
192 } else {
193 return (BOOL_T) (basic_argument (SUB (p)) && basic_argument (NEXT (p)));
194 }
195 }
196
197 //! @brief Whether basic call.
198
199 BOOL_T basic_call (NODE_T * p)
200 {
201 if (IS (p, CALL)) {
202 NODE_T *prim = SUB (p);
203 NODE_T *idf = stems_from (prim, IDENTIFIER);
204 if (idf == NO_NODE) {
205 return A68_FALSE;
206 } else if (SUB_MOID (idf) == MOID (p)) { // Prevent partial parametrisation
207 for (int k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
208 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
209 NODE_T *args = NEXT (prim);
210 return basic_argument (args);
211 }
212 }
213 }
214 }
215 return A68_FALSE;
216 }
217
218 //! @brief Whether basic monadic formula.
219
220 BOOL_T basic_monadic_formula (NODE_T * p)
221 {
222 if (IS (p, MONADIC_FORMULA)) {
223 NODE_T *op = SUB (p);
224 for (int k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
225 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
226 NODE_T *rhs = NEXT (op);
227 return basic_unit (rhs);
228 }
229 }
230 }
231 return A68_FALSE;
232 }
233
234 //! @brief Whether basic dyadic formula.
235
236 BOOL_T basic_formula (NODE_T * p)
237 {
238 if (IS (p, FORMULA)) {
239 NODE_T *lhs = SUB (p);
240 NODE_T *op = NEXT (lhs);
241 if (op == NO_NODE) {
242 return basic_monadic_formula (lhs);
243 } else {
244 for (int k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
245 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
246 NODE_T *rhs = NEXT (op);
247 return (BOOL_T) (basic_unit (lhs) && basic_unit (rhs));
248 }
249 }
250 }
251 }
252 return A68_FALSE;
253 }
254
255 //! @brief Whether basic conditional clause.
256
257 BOOL_T basic_conditional (NODE_T * p)
258 {
259 if (!(IS (p, IF_PART) || IS (p, OPEN_PART))) {
260 return A68_FALSE;
261 }
262 if (!basic_serial (NEXT_SUB (p), 1)) {
263 return A68_FALSE;
264 }
265 FORWARD (p);
266 if (!(IS (p, THEN_PART) || IS (p, CHOICE))) {
267 return A68_FALSE;
268 }
269 if (!basic_serial (NEXT_SUB (p), 1)) {
270 return A68_FALSE;
271 }
272 FORWARD (p);
273 if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
274 return basic_serial (NEXT_SUB (p), 1);
275 } else if (IS (p, FI_SYMBOL)) {
276 return A68_TRUE;
277 } else {
278 return A68_FALSE;
279 }
280 }
281
282 //! @brief Whether basic unit.
283
284 BOOL_T basic_unit (NODE_T * p)
285 {
286 if (p == NO_NODE) {
287 return A68_FALSE;
288 } else if (IS (p, UNIT)) {
289 return basic_unit (SUB (p));
290 } else if (IS (p, TERTIARY)) {
291 return basic_unit (SUB (p));
292 } else if (IS (p, SECONDARY)) {
293 return basic_unit (SUB (p));
294 } else if (IS (p, PRIMARY)) {
295 return basic_unit (SUB (p));
296 } else if (IS (p, ENCLOSED_CLAUSE)) {
297 return basic_unit (SUB (p));
298 }
299 if (A68_OPT (OPTION_CODE_LEVEL) >= 3) {
300 if (IS (p, CLOSED_CLAUSE)) {
301 return basic_serial (NEXT_SUB (p), 1);
302 } else if (IS (p, COLLATERAL_CLAUSE)) {
303 return basic_mode (MOID (p)) && basic_collateral (NEXT_SUB (p));
304 } else if (IS (p, CONDITIONAL_CLAUSE)) {
305 return basic_mode (MOID (p)) && basic_conditional (SUB (p));
306 }
307 }
308 if (A68_OPT (OPTION_CODE_LEVEL) >= 2) {
309 if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), IDENTIFIER) != NO_NODE) {
310 NODE_T *dst = SUB_SUB (p);
311 NODE_T *src = NEXT_NEXT (dst);
312 return (BOOL_T) basic_unit (src) && basic_mode_non_row (MOID (src));
313 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SLICE) != NO_NODE) {
314 NODE_T *dst = SUB_SUB (p);
315 NODE_T *src = NEXT_NEXT (dst);
316 NODE_T *slice = stems_from (dst, SLICE);
317 return (BOOL_T) (IS (MOID (slice), REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src)));
318 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SELECTION) != NO_NODE) {
319 NODE_T *dst = SUB_SUB (p);
320 NODE_T *src = NEXT_NEXT (dst);
321 return (BOOL_T) (stems_from (NEXT_SUB (stems_from (dst, SELECTION)), IDENTIFIER) != NO_NODE && basic_unit (src) && basic_mode_non_row (MOID (dst)));
322 } else if (IS (p, VOIDING)) {
323 return basic_unit (SUB (p));
324 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SLICE)) {
325 NODE_T *slice = stems_from (SUB (p), SLICE);
326 return (BOOL_T) (basic_mode (MOID (p)) && IS (MOID (SUB (slice)), REF_SYMBOL) && basic_slice (slice));
327 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SELECTION)) {
328 return (BOOL_T) (primitive_mode (MOID (p)) && BASIC (SUB (p), SELECTION));
329 } else if (IS (p, WIDENING)) {
330 if (WIDEN_TO (p, INT, REAL)) {
331 return basic_unit (SUB (p));
332 } else if (WIDEN_TO (p, REAL, COMPLEX)) {
333 return basic_unit (SUB (p));
334 } else {
335 return A68_FALSE;
336 }
337 } else if (IS (p, CAST)) {
338 return (BOOL_T) (folder_mode (MOID (SUB (p))) && basic_unit (NEXT_SUB (p)));
339 } else if (IS (p, SLICE)) {
340 return (BOOL_T) (basic_mode (MOID (p)) && basic_slice (p));
341 } else if (IS (p, SELECTION)) {
342 NODE_T *sec = stems_from (NEXT_SUB (p), IDENTIFIER);
343 if (sec == NO_NODE) {
344 return A68_FALSE;
345 } else {
346 return basic_mode_non_row (MOID (sec));
347 }
348 } else if (IS (p, IDENTITY_RELATION)) {
349 #define GOOD(p) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((p), IDENTIFIER)), REF_SYMBOL))
350 NODE_T *lhs = SUB (p);
351 NODE_T *rhs = NEXT_NEXT (lhs);
352 if (GOOD (lhs) && GOOD (rhs)) {
353 return A68_TRUE;
354 } else if (GOOD (lhs) && stems_from (rhs, NIHIL) != NO_NODE) {
355 return A68_TRUE;
356 } else {
357 return A68_FALSE;
358 }
359 #undef GOOD
360 }
361 }
362 if (A68_OPT (OPTION_CODE_LEVEL) >= 1) {
363 if (IS (p, IDENTIFIER)) {
364 if (A68_STANDENV_PROC (TAX (p))) {
365 for (int k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
366 if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
367 return A68_TRUE;
368 }
369 }
370 return A68_FALSE;
371 } else {
372 return basic_mode (MOID (p));
373 }
374 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER)) {
375 return (BOOL_T) (basic_mode (MOID (p)) && BASIC (SUB (p), IDENTIFIER));
376 } else if (IS (p, DENOTATION)) {
377 return primitive_mode (MOID (p));
378 } else if (IS (p, MONADIC_FORMULA)) {
379 return (BOOL_T) (basic_mode (MOID (p)) && basic_monadic_formula (p));
380 } else if (IS (p, FORMULA)) {
381 return (BOOL_T) (basic_mode (MOID (p)) && basic_formula (p));
382 } else if (IS (p, CALL)) {
383 return (BOOL_T) (basic_mode (MOID (p)) && basic_call (p));
384 }
385 }
386 return A68_FALSE;
387 }
388
