plugin-inline.c
1 //! @file plugin-inline.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 inlining routines.
25
26 #include "a68g.h"
27 #include "a68g-optimiser.h"
28 #include "a68g-plugin.h"
29 #include "a68g-transput.h"
30
31 //! @brief Code an A68 mode.
32
33 char *inline_mode (MOID_T * m)
34 {
35 if (m == M_INT) {
36 return "A68_INT";
37 } else if (m == M_REAL) {
38 return "A68_REAL";
39 } else if (m == M_BOOL) {
40 return "A68_BOOL";
41 } else if (m == M_CHAR) {
42 return "A68_CHAR";
43 } else if (m == M_BITS) {
44 return "A68_BITS";
45 } else if (m == M_COMPLEX) {
46 return "A68_COMPLEX";
47 } else if (IS (m, REF_SYMBOL)) {
48 return "A68_REF";
49 } else if (IS (m, ROW_SYMBOL)) {
50 return "A68_ROW";
51 } else if (IS (m, PROC_SYMBOL)) {
52 return "A68_PROCEDURE";
53 } else if (IS (m, STRUCT_SYMBOL)) {
54 return "A68_STRUCT";
55 } else {
56 return "A68_ERROR";
57 }
58 }
59
60 //! @brief Compile inline arguments.
61
62 void inline_arguments (NODE_T * p, FILE_T out, int phase, int *size)
63 {
64 if (p == NO_NODE) {
65 return;
66 } else if (IS (p, UNIT) && phase == L_PUSH) {
67 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GENIE_UNIT_TRACE (_NODE_ (%d));\n", NUMBER (p)));
68 inline_arguments (NEXT (p), out, L_PUSH, size);
69 } else if (IS (p, UNIT)) {
70 char arg[NAME_SIZE];
71 (void) make_name (arg, ARG, "", NUMBER (p));
72 if (phase == L_DECLARE) {
73 (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 1, arg);
74 inline_unit (p, out, L_DECLARE);
75 } else if (phase == L_INITIALISE) {
76 inline_unit (p, out, L_EXECUTE);
77 } else if (phase == L_EXECUTE) {
78 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) FRAME_OBJECT (%d);\n", arg, inline_mode (MOID (p)), *size));
79 (*size) += SIZE (MOID (p));
80 } else if (phase == L_YIELD && primitive_mode (MOID (p))) {
81 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", arg));
82 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = ", arg));
83 inline_unit (p, out, L_YIELD);
84 undent (out, ";\n");
85 } else if (phase == L_YIELD && basic_mode (MOID (p))) {
86 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", arg));
87 inline_unit (p, out, L_YIELD);
88 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
89 }
90 } else {
91 inline_arguments (SUB (p), out, phase, size);
92 inline_arguments (NEXT (p), out, phase, size);
93 }
94 }
95
96 //! @brief Code denotation.
97
98 void inline_denotation (NODE_T * p, FILE_T out, int phase)
99 {
100 if (phase == L_YIELD) {
101 if (MOID (p) == M_INT) {
102 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
103 char *den = NSYMBOL (s);
104 A68_INT z;
105 if (genie_string_to_value_internal (p, M_INT, den, (BYTE_T *) & z) == A68_FALSE) {
106 diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_INT);
107 }
108 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, A68_LD, VALUE (&z)));
109 } else if (MOID (p) == M_REAL) {
110 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
111 char *den = NSYMBOL (s);
112 A68_REAL z;
113 if (genie_string_to_value_internal (p, M_REAL, den, (BYTE_T *) & z) == A68_FALSE) {
114 diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_REAL);
115 }
116 if (strchr (den, '.') == NO_TEXT && strchr (den, 'e') == NO_TEXT && strchr (den, 'E') == NO_TEXT) {
117 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(REAL_T) %s", den));
118 } else {
119 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", den));
120 }
121 } else if (MOID (p) == M_BOOL) {
122 undent (out, "(BOOL_T) A68_");
123 undent (out, NSYMBOL (p));
124 } else if (MOID (p) == M_CHAR) {
125 if (NSYMBOL (p)[0] == '\'') {
126 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'\\''"));
127 } else if (NSYMBOL (p)[0] == NULL_CHAR) {
128 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "NULL_CHAR"));
129 } else if (NSYMBOL (p)[0] == '\\') {
130 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'\\\\'"));
131 } else {
132 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'%c'", (NSYMBOL (p))[0]));
133 }
134 } else if (MOID (p) == M_BITS) {
135 A68_BITS z;
136 NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p);
137 if (genie_string_to_value_internal (p, M_BITS, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {
138 diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, M_BITS);
139 }
140 ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "(UNSIGNED_T) 0x" A68_LX, VALUE (&z)) >= 0);
141 undent (out, A68 (edit_line));
142 }
143 }
144 }
145
146 //! @brief Code widening.
147
148 void inline_widening (NODE_T * p, FILE_T out, int phase)
149 {
150 if (WIDEN_TO (p, INT, REAL)) {
151 if (phase == L_DECLARE) {
152 inline_unit (SUB (p), out, L_DECLARE);
153 } else if (phase == L_EXECUTE) {
154 inline_unit (SUB (p), out, L_EXECUTE);
155 } else if (phase == L_YIELD) {
156 undent (out, "(REAL_T) (");
157 inline_unit (SUB (p), out, L_YIELD);
158 undent (out, ")");
159 }
160 } else if (WIDEN_TO (p, REAL, COMPLEX)) {
161 char acc[NAME_SIZE];
162 (void) make_name (acc, TMP, "", NUMBER (p));
163 if (phase == L_DECLARE) {
164 (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_COMPLEX), 0, acc);
165 inline_unit (SUB (p), out, L_DECLARE);
166 } else if (phase == L_EXECUTE) {
167 inline_unit (SUB (p), out, L_EXECUTE);
168 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "STATUS_RE (%s) = INIT_MASK;\n", acc));
169 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "STATUS_IM (%s) = INIT_MASK;\n", acc));
170 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "RE (%s) = (REAL_T) (", acc));
171 inline_unit (SUB (p), out, L_YIELD);
172 undent (out, ");\n");
173 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "IM (%s) = 0.0;\n", acc));
174 } else if (phase == L_YIELD) {
175 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) %s", acc));
176 }
177 }
178 }
179
180 //! @brief Code dereferencing of identifier.
181
182 void inline_dereference_identifier (NODE_T * p, FILE_T out, int phase)
183 {
184 NODE_T *q = stems_from (SUB (p), IDENTIFIER);
185 ABEND (q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
186 if (phase == L_DECLARE) {
187 if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) != NO_BOOK) {
188 return;
189 } else {
190 char idf[NAME_SIZE];
191 (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
192 (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 1, idf);
193 sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
194 inline_unit (SUB (p), out, L_DECLARE);
195 }
196 } else if (phase == L_EXECUTE) {
197 if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) {
198 return;
199 } else {
200 char idf[NAME_SIZE];
201 (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
202 inline_unit (SUB (p), out, L_EXECUTE);
203 if (BODY (TAX (q)) != NO_TAG) {
204 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (MOID (p))));
205 sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
206 inline_unit (SUB (p), out, L_YIELD);
207 undent (out, ");\n");
208 } else {
209 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (MOID (p))));
210 sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
211 inline_unit (SUB (p), out, L_YIELD);
212 undent (out, ");\n");
213 }
214 gen_check_init (p, out, idf);
215 }
216 } else if (phase == L_YIELD) {
217 char idf[NAME_SIZE];
218 if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) {
219 (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q))));
220 } else {
221 (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
222 }
223 if (primitive_mode (MOID (p))) {
224 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", idf));
225 } else if (MOID (p) == M_COMPLEX) {
226 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf));
227 } else if (basic_mode (MOID (p))) {
228 undent (out, idf);
229 }
230 }
231 }
232
233 //! @brief Code identifier.
234
235 void inline_identifier (NODE_T * p, FILE_T out, int phase)
236 {
237 // Possible constant folding.
238 NODE_T *def = NODE (TAX (p));
239 if (primitive_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) {
240 NODE_T *src = stems_from (NEXT_NEXT (def), DENOTATION);
241 if (src != NO_NODE) {
242 inline_denotation (src, out, phase);
243 return;
244 }
245 }
246 // No folding - consider identifier.
247 if (phase == L_DECLARE) {
248 if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) {
249 return;
250 } else if (A68_STANDENV_PROC (TAX (p))) {
251 return;
252 } else {
253 char idf[NAME_SIZE];
254 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
255 (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 1, idf);
256 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
257 }
258 } else if (phase == L_EXECUTE) {
259 if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) {
260 return;
261 } else if (A68_STANDENV_PROC (TAX (p))) {
262 return;
263 } else {
264 char idf[NAME_SIZE];
265 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
266 get_stack (p, out, idf, inline_mode (MOID (p)));
267 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
268 gen_check_init (p, out, idf);
269 }
270 } else if (phase == L_YIELD) {
271 if (A68_STANDENV_PROC (TAX (p))) {
272 for (int k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
273 if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
274 undent (out, CODE (&constants[k]));
275 return;
276 }
277 }
278 } else {
279 char idf[NAME_SIZE];
280 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p));
281 if (entry != NO_BOOK) {
282 (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry));
283 } else {
284 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
285 }
286 if (primitive_mode (MOID (p))) {
287 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", idf));
288 } else if (MOID (p) == M_COMPLEX) {
289 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf));
290 } else if (basic_mode (MOID (p))) {
291 undent (out, idf);
292 }
293 }
294 }
295 }
296
297 //! @brief Code indexer.
298
299 void inline_indexer (NODE_T * p, FILE_T out, int phase, INT_T * k, char *tup)
300 {
301 if (p == NO_NODE) {
302 return;
303 } else if (IS (p, UNIT)) {
304 if (phase != L_YIELD) {
305 inline_unit (p, out, phase);
306 } else {
307 if ((*k) == 0) {
308 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(SPAN (&%s[" A68_LD "]) * (", tup, (*k)));
309 } else {
310 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, " + (SPAN (&%s[" A68_LD "]) * (", tup, (*k)));
311 }
312 inline_unit (p, out, L_YIELD);
313 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ") - SHIFT (&%s[" A68_LD "]))", tup, (*k)));
314 }
315 (*k)++;
316 } else {
317 inline_indexer (SUB (p), out, phase, k, tup);
318 inline_indexer (NEXT (p), out, phase, k, tup);
319 }
320 }
321
322 //! @brief Code dereferencing of slice.
323
324 void inline_dereference_slice (NODE_T * p, FILE_T out, int phase)
325 {
326 NODE_T *prim = SUB (p);
327 NODE_T *indx = NEXT (prim);
328 MOID_T *row_mode = DEFLEX (MOID (prim));
329 MOID_T *mode = SUB_SUB (row_mode);
330 char *symbol = NSYMBOL (SUB (prim));
331 char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE];
332 if (phase == L_DECLARE) {
333 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
334 if (entry == NO_BOOK) {
335 (void) make_name (idf, symbol, "", NUMBER (prim));
336 (void) make_name (arr, ARR, "", NUMBER (prim));
337 (void) make_name (tup, TUP, "", NUMBER (prim));
338 (void) make_name (elm, ELM, "", NUMBER (prim));
339 (void) make_name (drf, DRF, "", NUMBER (prim));
340 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, idf);
341 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
342 (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr);
343 (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup);
344 (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
345 sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
346 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
347 (void) make_name (elm, ELM, "", NUMBER (prim));
348 (void) make_name (drf, DRF, "", NUMBER (prim));
349 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
350 (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
351 }
352 INT_T k = 0;
353 inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
354 } else if (phase == L_EXECUTE) {
355 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
356 NODE_T *pidf = stems_from (prim, IDENTIFIER);
357 if (entry == NO_BOOK) {
358 (void) make_name (idf, symbol, "", NUMBER (prim));
359 (void) make_name (arr, ARR, "", NUMBER (prim));
360 (void) make_name (tup, TUP, "", NUMBER (prim));
361 (void) make_name (elm, ELM, "", NUMBER (prim));
362 (void) make_name (drf, DRF, "", NUMBER (prim));
363 get_stack (pidf, out, idf, "A68_REF");
364 if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) {
365 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
366 } else {
367 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
368 }
369 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
370 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
371 (void) make_name (arr, ARR, "", NUMBER (entry));
372 (void) make_name (tup, TUP, "", NUMBER (entry));
373 (void) make_name (elm, ELM, "", NUMBER (prim));
374 (void) make_name (drf, DRF, "", NUMBER (prim));
375 } else {
376 return;
377 }
378 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
379 INT_T k = 0;
380 inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
381 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
382 k = 0;
383 inline_indexer (indx, out, L_YIELD, &k, tup);
384 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
385 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
386 } else if (phase == L_YIELD) {
387 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
388 if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
389 (void) make_name (drf, DRF, "", NUMBER (entry));
390 } else {
391 (void) make_name (drf, DRF, "", NUMBER (prim));
392 }
393 if (primitive_mode (mode)) {
394 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", drf));
395 } else if (mode == M_COMPLEX) {
396 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf));
397 } else if (basic_mode (mode)) {
398 undent (out, drf);
399 } else {
400 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
401 }
402 }
403 }
404
405 //! @brief Code slice REF [] MODE -> REF MODE.
406
407 void inline_slice_ref_to_ref (NODE_T * p, FILE_T out, int phase)
408 {
409 NODE_T *prim = SUB (p);
410 NODE_T *indx = NEXT (prim);
411 MOID_T *mode = SUB_MOID (p);
412 MOID_T *row_mode = DEFLEX (MOID (prim));
413 char *symbol = NSYMBOL (SUB (prim));
414 char idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], drf[NAME_SIZE];
415 if (phase == L_DECLARE) {
416 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
417 if (entry == NO_BOOK) {
418 (void) make_name (idf, symbol, "", NUMBER (prim));
419 (void) make_name (arr, ARR, "", NUMBER (prim));
420 (void) make_name (tup, TUP, "", NUMBER (prim));
421 (void) make_name (elm, ELM, "", NUMBER (prim));
422 (void) make_name (drf, DRF, "", NUMBER (prim));
423 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, idf);
424 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
425 (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr);
426 (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup);
427 (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
428 sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
429 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
430 (void) make_name (elm, ELM, "", NUMBER (prim));
431 (void) make_name (drf, DRF, "", NUMBER (prim));
432 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
433 (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
434 }
435 INT_T k = 0;
436 inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
437 } else if (phase == L_EXECUTE) {
438 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
439 if (entry == NO_BOOK) {
440 NODE_T *pidf = stems_from (prim, IDENTIFIER);
441 (void) make_name (idf, symbol, "", NUMBER (prim));
442 (void) make_name (arr, ARR, "", NUMBER (prim));
443 (void) make_name (tup, TUP, "", NUMBER (prim));
444 (void) make_name (elm, ELM, "", NUMBER (prim));
445 (void) make_name (drf, DRF, "", NUMBER (prim));
446 get_stack (pidf, out, idf, "A68_REF");
447 if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) {
448 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
449 } else {
450 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
451 }
452 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
453 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
454 (void) make_name (arr, ARR, "", NUMBER (entry));
455 (void) make_name (tup, TUP, "", NUMBER (entry));
456 (void) make_name (elm, ELM, "", NUMBER (prim));
457 (void) make_name (drf, DRF, "", NUMBER (prim));
458 } else {
459 return;
460 }
461 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
462 INT_T k = 0;
463 inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
464 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
465 k = 0;
466 inline_indexer (indx, out, L_YIELD, &k, tup);
467 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
468 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
469 } else if (phase == L_YIELD) {
470 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
471 if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
472 (void) make_name (elm, ELM, "", NUMBER (entry));
473 } else {
474 (void) make_name (elm, ELM, "", NUMBER (prim));
475 }
476 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(&%s)", elm));
477 }
478 }
479
480 //! @brief Code slice [] MODE -> MODE.
481
482 void inline_slice (NODE_T * p, FILE_T out, int phase)
483 {
484 NODE_T *prim = SUB (p);
485 NODE_T *indx = NEXT (prim);
486 MOID_T *mode = MOID (p);
487 MOID_T *row_mode = DEFLEX (MOID (prim));
488 char *symbol = NSYMBOL (SUB (prim));
489 char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE];
490 if (phase == L_DECLARE) {
491 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, symbol);
492 if (entry == NO_BOOK) {
493 (void) make_name (idf, symbol, "", NUMBER (prim));
494 (void) make_name (arr, ARR, "", NUMBER (prim));
495 (void) make_name (tup, TUP, "", NUMBER (prim));
496 (void) make_name (elm, ELM, "", NUMBER (prim));
497 (void) make_name (drf, DRF, "", NUMBER (prim));
498 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_REF * %s, %s; %s * %s; A68_ARRAY * %s; A68_TUPLE * %s;\n", idf, elm, inline_mode (mode), drf, arr, tup));
499 sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
500 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
501 (void) make_name (elm, ELM, "", NUMBER (prim));
502 (void) make_name (drf, DRF, "", NUMBER (prim));
503 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_REF %s; %s * %s;\n", elm, inline_mode (mode), drf));
504 }
505 INT_T k = 0;
506 inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
507 } else if (phase == L_EXECUTE) {
508 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
509 if (entry == NO_BOOK) {
510 NODE_T *pidf = stems_from (prim, IDENTIFIER);
511 (void) make_name (idf, symbol, "", NUMBER (prim));
512 (void) make_name (arr, ARR, "", NUMBER (prim));
513 (void) make_name (tup, TUP, "", NUMBER (prim));
514 (void) make_name (elm, ELM, "", NUMBER (prim));
515 (void) make_name (drf, DRF, "", NUMBER (prim));
516 get_stack (pidf, out, idf, "A68_REF");
517 if (IS (row_mode, REF_SYMBOL)) {
518 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
519 } else {
520 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, (A68_ROW *) %s);\n", arr, tup, idf));
521 }
522 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
523 } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) {
524 (void) make_name (arr, ARR, "", NUMBER (entry));
525 (void) make_name (tup, TUP, "", NUMBER (entry));
526 (void) make_name (elm, ELM, "", NUMBER (prim));
527 (void) make_name (drf, DRF, "", NUMBER (prim));
528 } else {
529 return;
530 }
531 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
532 INT_T k = 0;
533 inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
534 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
535 k = 0;
536 inline_indexer (indx, out, L_YIELD, &k, tup);
537 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
538 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
539 } else if (phase == L_YIELD) {
540 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, symbol);
541 if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) {
542 (void) make_name (drf, DRF, "", NUMBER (entry));
543 } else {
544 (void) make_name (drf, DRF, "", NUMBER (prim));
545 }
546 if (primitive_mode (mode)) {
547 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", drf));
548 } else if (mode == M_COMPLEX) {
549 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf));
550 } else if (basic_mode (mode)) {
551 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", drf));
552 } else {
553 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
554 }
555 }
556 }
557
558 //! @brief Code monadic formula.
559
560 void inline_monadic_formula (NODE_T * p, FILE_T out, int phase)
561 {
562 NODE_T *op = SUB (p), *rhs = NEXT (op);
563 if (IS (p, MONADIC_FORMULA) && MOID (p) == M_COMPLEX) {
564 char acc[NAME_SIZE];
565 (void) make_name (acc, TMP, "", NUMBER (p));
566 if (phase == L_DECLARE) {
567 (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_COMPLEX), 0, acc);
568 inline_unit (rhs, out, L_DECLARE);
569 } else if (phase == L_EXECUTE) {
570 inline_unit (rhs, out, L_EXECUTE);
571 for (int k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
572 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
573 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&monadics[k]), acc));
574 inline_unit (rhs, out, L_YIELD);
575 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
576 }
577 }
578 } else if (phase == L_YIELD) {
579 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", acc));
580 }
581 } else if (IS (p, MONADIC_FORMULA) && basic_mode (MOID (p))) {
582 if (phase != L_YIELD) {
583 inline_unit (rhs, out, phase);
584 } else {
585 for (int k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
586 if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
587 if (IS_ALNUM ((CODE (&monadics[k]))[0])) {
588 undent (out, CODE (&monadics[k]));
589 undent (out, "(");
590 inline_unit (rhs, out, L_YIELD);
591 undent (out, ")");
592 } else {
593 undent (out, CODE (&monadics[k]));
594 undent (out, "(");
595 inline_unit (rhs, out, L_YIELD);
596 undent (out, ")");
597 }
598 }
599 }
600 }
601 }
602 }
603
604 //! @brief Code dyadic formula.
605
606 void inline_formula (NODE_T * p, FILE_T out, int phase)
607 {
608 NODE_T *lhs = SUB (p), *rhs;
609 NODE_T *op = NEXT (lhs);
610 if (IS (p, FORMULA) && op == NO_NODE) {
611 inline_monadic_formula (lhs, out, phase);
612 return;
613 }
614 rhs = NEXT (op);
615 if (IS (p, FORMULA) && MOID (p) == M_COMPLEX) {
616 if (op == NO_NODE) {
617 inline_monadic_formula (lhs, out, phase);
618 } else if (phase == L_DECLARE) {
619 char acc[NAME_SIZE];
620 (void) make_name (acc, TMP, "", NUMBER (p));
621 (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 0, acc);
622 inline_unit (lhs, out, L_DECLARE);
623 inline_unit (rhs, out, L_DECLARE);
624 } else if (phase == L_EXECUTE) {
625 char acc[NAME_SIZE];
626 (void) make_name (acc, TMP, "", NUMBER (p));
627 inline_unit (lhs, out, L_EXECUTE);
628 inline_unit (rhs, out, L_EXECUTE);
629 for (int k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
630 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
631 if (MOID (p) == M_COMPLEX) {
632 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&dyadics[k]), acc));
633 } else {
634 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s (& %s, ", CODE (&dyadics[k]), acc));
635 }
636 inline_unit (lhs, out, L_YIELD);
637 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", "));
638 inline_unit (rhs, out, L_YIELD);
639 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
640 }
641 }
642 } else if (phase == L_YIELD) {
643 char acc[NAME_SIZE];
644 (void) make_name (acc, TMP, "", NUMBER (p));
645 if (MOID (p) == M_COMPLEX) {
646 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", acc));
647 } else {
648 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (& %s)", acc));
649 }
650 }
651 } else if (IS (p, FORMULA) && basic_mode (MOID (p))) {
652 if (phase != L_YIELD) {
653 inline_unit (lhs, out, phase);
654 inline_unit (rhs, out, phase);
655 } else {
656 for (int k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
657 if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
658 if (IS_ALNUM ((CODE (&dyadics[k]))[0])) {
659 undent (out, CODE (&dyadics[k]));
660 undent (out, "(");
661 inline_unit (lhs, out, L_YIELD);
662 undent (out, ", ");
663 inline_unit (rhs, out, L_YIELD);
664 undent (out, ")");
665 } else {
666 undent (out, "(");
667 inline_unit (lhs, out, L_YIELD);
668 undent (out, " ");
669 undent (out, CODE (&dyadics[k]));
670 undent (out, " ");
671 inline_unit (rhs, out, L_YIELD);
672 undent (out, ")");
673 }
674 }
675 }
676 }
677 }
678 }
679
680 //! @brief Code argument.
681
682 void inline_single_argument (NODE_T * p, FILE_T out, int phase)
683 {
684 for (; p != NO_NODE; FORWARD (p)) {
685 if (IS (p, ARGUMENT_LIST) || IS (p, ARGUMENT)) {
686 inline_single_argument (SUB (p), out, phase);
687 } else if (IS (p, GENERIC_ARGUMENT_LIST) || IS (p, GENERIC_ARGUMENT)) {
688 inline_single_argument (SUB (p), out, phase);
689 } else if (IS (p, UNIT)) {
690 inline_unit (p, out, phase);
691 }
692 }
693 }
694
695 //! @brief Code call.
696
697 void inline_call (NODE_T * p, FILE_T out, int phase)
698 {
699 NODE_T *prim = SUB (p);
700 NODE_T *args = NEXT (prim);
701 NODE_T *idf = stems_from (prim, IDENTIFIER);
702 if (MOID (p) == M_COMPLEX) {
703 char acc[NAME_SIZE];
704 (void) make_name (acc, TMP, "", NUMBER (p));
705 if (phase == L_DECLARE) {
706 (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_COMPLEX), 0, acc);
707 inline_single_argument (args, out, L_DECLARE);
708 } else if (phase == L_EXECUTE) {
709 inline_single_argument (args, out, L_EXECUTE);
710 for (int k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
711 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
712 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s (%s, ", CODE (&functions[k]), acc));
713 inline_single_argument (args, out, L_YIELD);
714 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
715 }
716 }
717 } else if (phase == L_YIELD) {
718 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", acc));
719 }
720 } else if (basic_mode (MOID (p))) {
721 if (phase != L_YIELD) {
722 inline_single_argument (args, out, phase);
723 } else {
724 for (int k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
725 if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
726 undent (out, CODE (&functions[k]));
727 undent (out, " (");
728 inline_single_argument (args, out, L_YIELD);
729 undent (out, ")");
730 }
731 }
732 }
733 }
734 }
735
736 //! @brief Code collateral units.
737
738 void inline_collateral_units (NODE_T * p, FILE_T out, int phase)
739 {
740 if (p == NO_NODE) {
741 return;
742 } else if (IS (p, UNIT)) {
743 if (phase == L_DECLARE) {
744 inline_unit (SUB (p), out, L_DECLARE);
745 } else if (phase == L_EXECUTE) {
746 inline_unit (SUB (p), out, L_EXECUTE);
747 } else if (phase == L_YIELD) {
748 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
749 inline_unit (SUB (p), out, L_YIELD);
750 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
751 }
752 } else {
753 inline_collateral_units (SUB (p), out, phase);
754 inline_collateral_units (NEXT (p), out, phase);
755 }
756 }
757
758 //! @brief Code collateral units.
759
760 void inline_collateral (NODE_T * p, FILE_T out, int phase)
761 {
762 char dsp[NAME_SIZE];
763 (void) make_name (dsp, DSP, "", NUMBER (p));
764 if (p == NO_NODE) {
765 return;
766 } else if (phase == L_DECLARE) {
767 if (MOID (p) == M_COMPLEX) {
768 (void) add_declaration (&A68_OPT (root_idf), inline_mode (M_REAL), 1, dsp);
769 } else {
770 (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (p)), 1, dsp);
771 }
772 inline_collateral_units (NEXT_SUB (p), out, L_DECLARE);
773 } else if (phase == L_EXECUTE) {
774 if (MOID (p) == M_COMPLEX) {
775 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (M_REAL)));
776 } else {
777 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (MOID (p))));
778 }
779 inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE);
780 inline_collateral_units (NEXT_SUB (p), out, L_YIELD);
781 } else if (phase == L_YIELD) {
782 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", dsp));
783 }
784 }
785
786 //! @brief Code basic closed clause.
787
788 void inline_closed (NODE_T * p, FILE_T out, int phase)
789 {
790 if (p == NO_NODE) {
791 return;
792 } else if (phase != L_YIELD) {
793 inline_unit (SUB (NEXT_SUB (p)), out, phase);
794 } else {
795 undent (out, "(");
796 inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD);
797 undent (out, ")");
798 }
799 }
800
801 //! @brief Code basic closed clause.
802
803 void inline_conditional (NODE_T * p, FILE_T out, int phase)
804 {
805 NODE_T *if_part = NO_NODE, *then_part = NO_NODE, *else_part = NO_NODE;
806 p = SUB (p);
807 if (IS (p, IF_PART) || IS (p, OPEN_PART)) {
808 if_part = p;
809 } else {
810 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
811 }
812 FORWARD (p);
813 if (IS (p, THEN_PART) || IS (p, CHOICE)) {
814 then_part = p;
815 } else {
816 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
817 }
818 FORWARD (p);
819 if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
820 else_part = p;
821 } else {
822 else_part = NO_NODE;
823 }
824 if (phase == L_DECLARE) {
825 inline_unit (SUB (NEXT_SUB (if_part)), out, L_DECLARE);
826 inline_unit (SUB (NEXT_SUB (then_part)), out, L_DECLARE);
827 inline_unit (SUB (NEXT_SUB (else_part)), out, L_DECLARE);
828 } else if (phase == L_EXECUTE) {
829 inline_unit (SUB (NEXT_SUB (if_part)), out, L_EXECUTE);
830 inline_unit (SUB (NEXT_SUB (then_part)), out, L_EXECUTE);
831 inline_unit (SUB (NEXT_SUB (else_part)), out, L_EXECUTE);
832 } else if (phase == L_YIELD) {
833 undent (out, "(");
834 inline_unit (SUB (NEXT_SUB (if_part)), out, L_YIELD);
835 undent (out, " ? ");
836 inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD);
837 undent (out, " : ");
838 if (else_part != NO_NODE) {
839 inline_unit (SUB (NEXT_SUB (else_part)), out, L_YIELD);
840 } else {
841 // This is not an ideal solution although RR permits it;
842 // an omitted else-part means SKIP: yield some value of the
843 // mode required.
844 inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD);
845 }
846 undent (out, ")");
847 }
848 }
849
850 //! @brief Code dereferencing of selection.
851
852 void inline_dereference_selection (NODE_T * p, FILE_T out, int phase)
853 {
854 NODE_T *field = SUB (p);
855 NODE_T *sec = NEXT (field);
856 NODE_T *idf = stems_from (sec, IDENTIFIER);
857 char ref[NAME_SIZE], sel[NAME_SIZE];
858 char *field_idf = NSYMBOL (SUB (field));
859 if (phase == L_DECLARE) {
860 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
861 if (entry == NO_BOOK) {
862 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
863 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, ref);
864 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
865 }
866 if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
867 (void) make_name (sel, SEL, "", NUMBER (field));
868 (void) add_declaration (&A68_OPT (root_idf), inline_mode (SUB_MOID (field)), 1, sel);
869 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
870 }
871 inline_unit (sec, out, L_DECLARE);
872 } else if (phase == L_EXECUTE) {
873 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
874 if (entry == NO_BOOK) {
875 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
876 get_stack (idf, out, ref, "A68_REF");
877 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), NULL, NUMBER (field));
878 }
879 if (entry == NO_BOOK) {
880 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
881 (void) make_name (sel, SEL, "", NUMBER (field));
882 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[" A68_LU "]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field)));
883 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
884 } else if (field_idf != (char *) (INFO (entry))) {
885 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
886 (void) make_name (sel, SEL, "", NUMBER (field));
887 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[" A68_LU "]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field)));
888 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
889 }
890 inline_unit (sec, out, L_EXECUTE);
891 } else if (phase == L_YIELD) {
892 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
893 if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
894 (void) make_name (sel, SEL, "", NUMBER (entry));
895 } else {
896 (void) make_name (sel, SEL, "", NUMBER (field));
897 }
898 if (primitive_mode (SUB_MOID (p))) {
899 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", sel));
900 } else if (SUB_MOID (p) == M_COMPLEX) {
901 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) (%s)", sel));
902 } else if (basic_mode (SUB_MOID (p))) {
903 undent (out, sel);
904 } else {
905 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
906 }
907 }
908 }
909
910 //! @brief Code selection.
911
912 void inline_selection (NODE_T * p, FILE_T out, int phase)
913 {
914 NODE_T *field = SUB (p);
915 NODE_T *sec = NEXT (field);
916 NODE_T *idf = stems_from (sec, IDENTIFIER);
917 char ref[NAME_SIZE], sel[NAME_SIZE];
918 char *field_idf = NSYMBOL (SUB (field));
919 if (phase == L_DECLARE) {
920 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
921 if (entry == NO_BOOK) {
922 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
923 (void) add_declaration (&A68_OPT (root_idf), "A68_STRUCT", 0, ref);
924 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
925 }
926 if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
927 (void) make_name (sel, SEL, "", NUMBER (field));
928 (void) add_declaration (&A68_OPT (root_idf), inline_mode (MOID (field)), 1, sel);
929 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
930 }
931 inline_unit (sec, out, L_DECLARE);
932 } else if (phase == L_EXECUTE) {
933 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
934 if (entry == NO_BOOK) {
935 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
936 get_stack (idf, out, ref, "BYTE_T");
937 (void) make_name (sel, SEL, "", NUMBER (field));
938 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (%s[" A68_LU "]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field)));
939 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
940 } else if (field_idf != (char *) (INFO (entry))) {
941 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
942 (void) make_name (sel, SEL, "", NUMBER (field));
943 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) & (%s[" A68_LU "]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field)));
944 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
945 }
946 inline_unit (sec, out, L_EXECUTE);
947 } else if (phase == L_YIELD) {
948 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
949 if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
950 (void) make_name (sel, SEL, "", NUMBER (entry));
951 } else {
952 (void) make_name (sel, SEL, "", NUMBER (field));
953 }
954 if (primitive_mode (MOID (p))) {
955 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s)", sel));
956 } else {
957 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
958 }
959 }
960 }
961
962 //! @brief Code selection.
963
964 void inline_selection_ref_to_ref (NODE_T * p, FILE_T out, int phase)
965 {
966 NODE_T *field = SUB (p);
967 NODE_T *sec = NEXT (field);
968 NODE_T *idf = stems_from (sec, IDENTIFIER);
969 char ref[NAME_SIZE], sel[NAME_SIZE];
970 char *field_idf = NSYMBOL (SUB (field));
971 if (phase == L_DECLARE) {
972 BOOK_T *entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf));
973 if (entry == NO_BOOK) {
974 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
975 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, ref);
976 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field));
977 }
978 if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) {
979 (void) make_name (sel, SEL, "", NUMBER (field));
980 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, sel);
981 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
982 }
983 inline_unit (sec, out, L_DECLARE);
984 } else if (phase == L_EXECUTE) {
985 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf));
986 if (entry == NO_BOOK) {
987 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
988 get_stack (idf, out, ref, "A68_REF");
989 (void) make_name (sel, SEL, "", NUMBER (field));
990 sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
991 } else if (field_idf != (char *) (INFO (entry))) {
992 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry));
993 (void) make_name (sel, SEL, "", NUMBER (field));
994 sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
995 }
996 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = *%s;\n", sel, ref));
997 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (&%s) += " A68_LU ";\n", sel, OFFSET_OFF (field)));
998 inline_unit (sec, out, L_EXECUTE);
999 } else if (phase == L_YIELD) {
1000 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf));
1001 if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) {
1002 (void) make_name (sel, SEL, "", NUMBER (entry));
1003 } else {
1004 (void) make_name (sel, SEL, "", NUMBER (field));
1005 }
1006 if (primitive_mode (SUB_MOID (p))) {
1007 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(&%s)", sel));
1008 } else {
1009 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1010 }
1011 }
1012 }
1013
1014 //! @brief Code identifier.
1015
1016 void inline_ref_identifier (NODE_T * p, FILE_T out, int phase)
1017 {
1018 // No folding - consider identifier.
1019 if (phase == L_DECLARE) {
1020 if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) {
1021 return;
1022 } else {
1023 char idf[NAME_SIZE];
1024 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
1025 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, idf);
1026 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p));
1027 }
1028 } else if (phase == L_EXECUTE) {
1029 if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) {
1030 return;
1031 } else {
1032 char idf[NAME_SIZE];
1033 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
1034 get_stack (p, out, idf, "A68_REF");
1035 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p));
1036 }
1037 } else if (phase == L_YIELD) {
1038 char idf[NAME_SIZE];
1039 BOOK_T *entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p));
1040 if (entry != NO_BOOK) {
1041 (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry));
1042 } else {
1043 (void) make_name (idf, NSYMBOL (p), "", NUMBER (p));
1044 }
1045 undent (out, idf);
1046 }
1047 }
1048
1049 //! @brief Code identity-relation.
1050
1051 void inline_identity_relation (NODE_T * p, FILE_T out, int phase)
1052 {
1053 #define GOOD(p) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((p), IDENTIFIER)), REF_SYMBOL))
1054 NODE_T *lhs = SUB (p);
1055 NODE_T *op = NEXT (lhs);
1056 NODE_T *rhs = NEXT (op);
1057 if (GOOD (lhs) && GOOD (rhs)) {
1058 if (phase == L_DECLARE) {
1059 NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1060 NODE_T *ridf = stems_from (rhs, IDENTIFIER);
1061 inline_ref_identifier (lidf, out, L_DECLARE);
1062 inline_ref_identifier (ridf, out, L_DECLARE);
1063 } else if (phase == L_EXECUTE) {
1064 NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1065 NODE_T *ridf = stems_from (rhs, IDENTIFIER);
1066 inline_ref_identifier (lidf, out, L_EXECUTE);
1067 inline_ref_identifier (ridf, out, L_EXECUTE);
1068 } else if (phase == L_YIELD) {
1069 NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1070 NODE_T *ridf = stems_from (rhs, IDENTIFIER);
1071 if (IS (op, IS_SYMBOL)) {
1072 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "ADDRESS ("));
1073 inline_ref_identifier (lidf, out, L_YIELD);
1074 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ") == ADDRESS ("));
1075 inline_ref_identifier (ridf, out, L_YIELD);
1076 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ")"));
1077 } else {
1078 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "ADDRESS ("));
1079 inline_ref_identifier (lidf, out, L_YIELD);
1080 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ") != ADDRESS ("));
1081 inline_ref_identifier (ridf, out, L_YIELD);
1082 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ")"));
1083 }
1084 }
1085 } else if (GOOD (lhs) && stems_from (rhs, NIHIL) != NO_NODE) {
1086 if (phase == L_DECLARE) {
1087 NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1088 inline_ref_identifier (lidf, out, L_DECLARE);
1089 } else if (phase == L_EXECUTE) {
1090 NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1091 inline_ref_identifier (lidf, out, L_EXECUTE);
1092 } else if (phase == L_YIELD) {
1093 NODE_T *lidf = stems_from (lhs, IDENTIFIER);
1094 if (IS (op, IS_SYMBOL)) {
1095 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "IS_NIL (*"));
1096 inline_ref_identifier (lidf, out, L_YIELD);
1097 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ")"));
1098 } else {
1099 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "!IS_NIL (*"));
1100 inline_ref_identifier (lidf, out, L_YIELD);
1101 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ")"));
1102 }
1103 }
1104 }
1105 #undef GOOD
1106 }
1107
1108 //! @brief Code unit.
1109
1110 void inline_unit (NODE_T * p, FILE_T out, int phase)
1111 {
1112 if (p == NO_NODE) {
1113 return;
1114 } else if (constant_unit (p) && stems_from (p, DENOTATION) == NO_NODE) {
1115 constant_folder (p, out, phase);
1116 } else if (IS (p, UNIT)) {
1117 inline_unit (SUB (p), out, phase);
1118 } else if (IS (p, TERTIARY)) {
1119 inline_unit (SUB (p), out, phase);
1120 } else if (IS (p, SECONDARY)) {
1121 inline_unit (SUB (p), out, phase);
1122 } else if (IS (p, PRIMARY)) {
1123 inline_unit (SUB (p), out, phase);
1124 } else if (IS (p, ENCLOSED_CLAUSE)) {
1125 inline_unit (SUB (p), out, phase);
1126 } else if (IS (p, CLOSED_CLAUSE)) {
1127 inline_closed (p, out, phase);
1128 } else if (IS (p, COLLATERAL_CLAUSE)) {
1129 inline_collateral (p, out, phase);
1130 } else if (IS (p, CONDITIONAL_CLAUSE)) {
1131 inline_conditional (p, out, phase);
1132 } else if (IS (p, WIDENING)) {
1133 inline_widening (p, out, phase);
1134 } else if (IS (p, IDENTIFIER)) {
1135 inline_identifier (p, out, phase);
1136 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER) != NO_NODE) {
1137 inline_dereference_identifier (p, out, phase);
1138 } else if (IS (p, SLICE)) {
1139 NODE_T *prim = SUB (p);
1140 MOID_T *mode = MOID (p);
1141 MOID_T *row_mode = DEFLEX (MOID (prim));
1142 if (mode == SUB (row_mode)) {
1143 inline_slice (p, out, phase);
1144 } else if (IS (mode, REF_SYMBOL) && IS (row_mode, REF_SYMBOL) && SUB (mode) == SUB_SUB (row_mode)) {
1145 inline_slice_ref_to_ref (p, out, phase);
1146 } else {
1147 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1148 }
1149 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SLICE) != NO_NODE) {
1150 inline_dereference_slice (SUB (p), out, phase);
1151 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SELECTION) != NO_NODE) {
1152 inline_dereference_selection (SUB (p), out, phase);
1153 } else if (IS (p, SELECTION)) {
1154 NODE_T *sec = NEXT_SUB (p);
1155 MOID_T *mode = MOID (p);
1156 MOID_T *struct_mode = MOID (sec);
1157 if (IS (struct_mode, REF_SYMBOL) && IS (mode, REF_SYMBOL)) {
1158 inline_selection_ref_to_ref (p, out, phase);
1159 } else if (IS (struct_mode, STRUCT_SYMBOL) && primitive_mode (mode)) {
1160 inline_selection (p, out, phase);
1161 } else {
1162 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1163 }
1164 } else if (IS (p, DENOTATION)) {
1165 inline_denotation (p, out, phase);
1166 } else if (IS (p, MONADIC_FORMULA)) {
1167 inline_monadic_formula (p, out, phase);
1168 } else if (IS (p, FORMULA)) {
1169 inline_formula (p, out, phase);
1170 } else if (IS (p, CALL)) {
1171 inline_call (p, out, phase);
1172 } else if (IS (p, CAST)) {
1173 inline_unit (NEXT_SUB (p), out, phase);
1174 } else if (IS (p, IDENTITY_RELATION)) {
1175 inline_identity_relation (p, out, phase);
1176 }
1177 }
1178
