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