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