plugin-gen.c
1 //! @file plugin-gen.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 generator routines.
25
26 #include "a68g.h"
27 #include "a68g-prelude.h"
28 #include "a68g-optimiser.h"
29 #include "a68g-plugin.h"
30 #include "a68g-parser.h"
31
32 //! @brief Compile code clause.
33
34 void embed_code_clause (NODE_T * p, FILE_T out)
35 {
36 for (; p != NO_NODE; FORWARD (p)) {
37 if (IS (p, ROW_CHAR_DENOTATION)) {
38 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s\n", NSYMBOL (p)));
39 }
40 embed_code_clause (SUB (p), out);
41 }
42 }
43
44 //! @brief Compile push.
45
46 void gen_push (NODE_T * p, FILE_T out)
47 {
48 if (primitive_mode (MOID (p))) {
49 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
50 inline_unit (p, out, L_YIELD);
51 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
52 } else if (basic_mode (MOID (p))) {
53 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) STACK_TOP, (void *) "));
54 inline_unit (p, out, L_YIELD);
55 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
56 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP += %d;\n", SIZE (MOID (p))));
57 } else {
58 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, moid_to_string (MOID (p), 80, NO_NODE));
59 }
60 }
61
62 //! @brief Compile assign (C source to C destination).
63
64 void gen_assign (NODE_T * p, FILE_T out, char *dst)
65 {
66 if (primitive_mode (MOID (p))) {
67 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", dst));
68 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = ", dst));
69 inline_unit (p, out, L_YIELD);
70 undent (out, ";\n");
71 } else if (basic_mode (MOID (p))) {
72 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", dst));
73 inline_unit (p, out, L_YIELD);
74 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
75 } else {
76 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, moid_to_string (MOID (p), 80, NO_NODE));
77 }
78 }
79
80 //! @brief Compile denotation.
81
82 char *gen_denotation (NODE_T * p, FILE_T out, int compose_fun)
83 {
84 if (primitive_mode (MOID (p))) {
85 if (compose_fun == A68_MAKE_FUNCTION) {
86 return compile_denotation (p, out);
87 } else {
88 static char fn[NAME_SIZE];
89 comment_source (p, out);
90 (void) make_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", NUMBER (p));
91 A68_OPT (root_idf) = NO_DEC;
92 inline_unit (p, out, L_DECLARE);
93 print_declarations (out, A68_OPT (root_idf));
94 inline_unit (p, out, L_EXECUTE);
95 if (primitive_mode (MOID (p))) {
96 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
97 inline_unit (p, out, L_YIELD);
98 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
99 } else {
100 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH (p, "));
101 inline_unit (p, out, L_YIELD);
102 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p))));
103 }
104 return fn;
105 }
106 } else {
107 return NO_TEXT;
108 }
109 }
110
111 //! @brief Compile cast.
112
113 char *gen_cast (NODE_T * p, FILE_T out, int compose_fun)
114 {
115 if (compose_fun == A68_MAKE_FUNCTION) {
116 return compile_cast (p, out);
117 } else if (basic_unit (p)) {
118 static char fn[NAME_SIZE];
119 comment_source (p, out);
120 (void) make_name (fn, moid_with_name ("", MOID (p), "_cast"), "", NUMBER (p));
121 A68_OPT (root_idf) = NO_DEC;
122 inline_unit (NEXT_SUB (p), out, L_DECLARE);
123 print_declarations (out, A68_OPT (root_idf));
124 inline_unit (NEXT_SUB (p), out, L_EXECUTE);
125 gen_push (NEXT_SUB (p), out);
126 return fn;
127 } else {
128 return NO_TEXT;
129 }
130 }
131
132 //! @brief Compile identifier.
133
134 char *gen_identifier (NODE_T * p, FILE_T out, int compose_fun)
135 {
136 if (compose_fun == A68_MAKE_FUNCTION) {
137 return compile_identifier (p, out);
138 } else if (basic_mode (MOID (p))) {
139 static char fn[NAME_SIZE];
140 (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", NUMBER (p));
141 comment_source (p, out);
142 A68_OPT (root_idf) = NO_DEC;
143 inline_unit (p, out, L_DECLARE);
144 print_declarations (out, A68_OPT (root_idf));
145 inline_unit (p, out, L_EXECUTE);
146 gen_push (p, out);
147 return fn;
148 } else {
149 return NO_TEXT;
150 }
151 }
152
153 //! @brief Compile dereference identifier.
154
155 char *gen_dereference_identifier (NODE_T * p, FILE_T out, int compose_fun)
156 {
157 if (compose_fun == A68_MAKE_FUNCTION) {
158 return compile_dereference_identifier (p, out);
159 } else if (basic_mode (MOID (p))) {
160 static char fn[NAME_SIZE];
161 comment_source (p, out);
162 (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", NUMBER (p));
163 A68_OPT (root_idf) = NO_DEC;
164 inline_unit (p, out, L_DECLARE);
165 print_declarations (out, A68_OPT (root_idf));
166 inline_unit (p, out, L_EXECUTE);
167 gen_push (p, out);
168 return fn;
169 } else {
170 return NO_TEXT;
171 }
172 }
173
174 //! @brief Compile slice.
175
176 char *gen_slice (NODE_T * p, FILE_T out, int compose_fun)
177 {
178 if (basic_mode (MOID (p)) && basic_unit (p)) {
179 static char fn[NAME_SIZE];
180 comment_source (p, out);
181 (void) make_name (fn, moid_with_name ("", MOID (p), "_slice"), "", NUMBER (p));
182 if (compose_fun == A68_MAKE_FUNCTION) {
183 write_fun_prelude (p, out, fn);
184 }
185 A68_OPT (root_idf) = NO_DEC;
186 inline_unit (p, out, L_DECLARE);
187 print_declarations (out, A68_OPT (root_idf));
188 inline_unit (p, out, L_EXECUTE);
189 gen_push (p, out);
190 if (compose_fun == A68_MAKE_FUNCTION) {
191 write_fun_postlude (p, out, fn);
192 }
193 return fn;
194 } else {
195 return NO_TEXT;
196 }
197 }
198
199 //! @brief Compile slice.
200
201 char *gen_dereference_slice (NODE_T * p, FILE_T out, int compose_fun)
202 {
203 if (basic_mode (MOID (p)) && basic_unit (p)) {
204 static char fn[NAME_SIZE];
205 comment_source (p, out);
206 (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_slice"), "", NUMBER (p));
207 if (compose_fun == A68_MAKE_FUNCTION) {
208 write_fun_prelude (p, out, fn);
209 }
210 A68_OPT (root_idf) = NO_DEC;
211 inline_unit (p, out, L_DECLARE);
212 print_declarations (out, A68_OPT (root_idf));
213 inline_unit (p, out, L_EXECUTE);
214 gen_push (p, out);
215 if (compose_fun == A68_MAKE_FUNCTION) {
216 write_fun_postlude (p, out, fn);
217 }
218 return fn;
219 } else {
220 return NO_TEXT;
221 }
222 }
223
224 //! @brief Compile selection.
225
226 char *gen_selection (NODE_T * p, FILE_T out, int compose_fun)
227 {
228 if (basic_mode (MOID (p)) && basic_unit (p)) {
229 static char fn[NAME_SIZE];
230 comment_source (p, out);
231 (void) make_name (fn, moid_with_name ("", MOID (p), "_select"), "", NUMBER (p));
232 if (compose_fun == A68_MAKE_FUNCTION) {
233 write_fun_prelude (p, out, fn);
234 }
235 A68_OPT (root_idf) = NO_DEC;
236 inline_unit (p, out, L_DECLARE);
237 print_declarations (out, A68_OPT (root_idf));
238 inline_unit (p, out, L_EXECUTE);
239 gen_push (p, out);
240 if (compose_fun == A68_MAKE_FUNCTION) {
241 write_fun_postlude (p, out, fn);
242 }
243 return fn;
244 } else {
245 return NO_TEXT;
246 }
247 }
248
249 //! @brief Compile selection.
250
251 char *gen_dereference_selection (NODE_T * p, FILE_T out, int compose_fun)
252 {
253 if (basic_mode (MOID (p)) && basic_unit (p)) {
254 static char fn[NAME_SIZE];
255 comment_source (p, out);
256 (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_select"), "", NUMBER (p));
257 if (compose_fun == A68_MAKE_FUNCTION) {
258 write_fun_prelude (p, out, fn);
259 }
260 A68_OPT (root_idf) = NO_DEC;
261 inline_unit (p, out, L_DECLARE);
262 print_declarations (out, A68_OPT (root_idf));
263 inline_unit (p, out, L_EXECUTE);
264 gen_push (p, out);
265 if (compose_fun == A68_MAKE_FUNCTION) {
266 write_fun_postlude (p, out, fn);
267 }
268 return fn;
269 } else {
270 return NO_TEXT;
271 }
272 }
273
274 //! @brief Compile formula.
275
276 char *gen_formula (NODE_T * p, FILE_T out, int compose_fun)
277 {
278 if (basic_unit (p)) {
279 static char fn[NAME_SIZE];
280 comment_source (p, out);
281 (void) make_name (fn, moid_with_name ("", MOID (p), "_formula"), "", NUMBER (p));
282 if (compose_fun == A68_MAKE_FUNCTION) {
283 write_fun_prelude (p, out, fn);
284 }
285 A68_OPT (root_idf) = NO_DEC;
286 inline_unit (p, out, L_DECLARE);
287 print_declarations (out, A68_OPT (root_idf));
288 if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
289 if (MOID (p) == M_REAL || MOID (p) == M_COMPLEX) {
290 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "errno = 0;\n"));
291 }
292 }
293 inline_unit (p, out, L_EXECUTE);
294 gen_push (p, out);
295 if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
296 if (MOID (p) == M_REAL) {
297 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);\n"));
298 }
299 if (MOID (p) == M_COMPLEX) {
300 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT);\n"));
301 }
302 }
303 if (compose_fun == A68_MAKE_FUNCTION) {
304 write_fun_postlude (p, out, fn);
305 }
306 return fn;
307 } else {
308 return NO_TEXT;
309 }
310 }
311
312 //! @brief Compile voiding formula.
313
314 char *gen_voiding_formula (NODE_T * p, FILE_T out, int compose_fun)
315 {
316 if (basic_unit (p)) {
317 static char fn[NAME_SIZE];
318 char pop[NAME_SIZE];
319 (void) make_name (pop, PUP, "", NUMBER (p));
320 comment_source (p, out);
321 (void) make_name (fn, moid_with_name ("void_", MOID (p), "_formula"), "", NUMBER (p));
322 if (compose_fun == A68_MAKE_FUNCTION) {
323 write_fun_prelude (p, out, fn);
324 }
325 A68_OPT (root_idf) = NO_DEC;
326 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
327 inline_unit (p, out, L_DECLARE);
328 print_declarations (out, A68_OPT (root_idf));
329 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
330 inline_unit (p, out, L_EXECUTE);
331 indent (out, "(void) (");
332 inline_unit (p, out, L_YIELD);
333 undent (out, ");\n");
334 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
335 if (compose_fun == A68_MAKE_FUNCTION) {
336 write_fun_postlude (p, out, fn);
337 }
338 return fn;
339 } else {
340 return NO_TEXT;
341 }
342 }
343
344 //! @brief Compile uniting.
345
346 char *gen_uniting (NODE_T * p, FILE_T out, int compose_fun)
347 {
348 MOID_T *u = MOID (p), *v = MOID (SUB (p));
349 NODE_T *q = SUB (p);
350 if (basic_unit (q) && ATTRIBUTE (v) != UNION_SYMBOL && primitive_mode (v)) {
351 static char fn[NAME_SIZE];
352 char pop0[NAME_SIZE];
353 (void) make_name (pop0, PUP, "0", NUMBER (p));
354 comment_source (p, out);
355 (void) make_name (fn, moid_with_name ("", MOID (p), "_unite"), "", NUMBER (p));
356 if (compose_fun == A68_MAKE_FUNCTION) {
357 write_fun_prelude (p, out, fn);
358 }
359 A68_OPT (root_idf) = NO_DEC;
360 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop0);
361 inline_unit (q, out, L_DECLARE);
362 print_declarations (out, A68_OPT (root_idf));
363 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop0));
364 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_UNION (_NODE_ (%d), %s);\n", NUMBER (p), internal_mode (v)));
365 inline_unit (q, out, L_EXECUTE);
366 gen_push (q, out);
367 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s + %d;\n", pop0, SIZE (u)));
368 if (compose_fun == A68_MAKE_FUNCTION) {
369 write_fun_postlude (p, out, fn);
370 }
371 return fn;
372 } else {
373 return NO_TEXT;
374 }
375 }
376
377 //! @brief Compile deproceduring.
378
379 char *gen_deproceduring (NODE_T * p, FILE_T out, int compose_fun)
380 {
381 NODE_T *idf = stems_from (SUB (p), IDENTIFIER);
382 if (idf == NO_NODE) {
383 return NO_TEXT;
384 } else if (!(SUB_MOID (idf) == M_VOID || basic_mode (SUB_MOID (idf)))) {
385 return NO_TEXT;
386 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
387 return NO_TEXT;
388 } else {
389 static char fn[NAME_SIZE];
390 char fun[NAME_SIZE];
391 (void) make_name (fun, FUN, "", NUMBER (idf));
392 comment_source (p, out);
393 (void) make_name (fn, moid_with_name ("", MOID (p), "_deproc"), "", NUMBER (p));
394 if (compose_fun == A68_MAKE_FUNCTION) {
395 write_fun_prelude (p, out, fn);
396 }
397 // Declare.
398 A68_OPT (root_idf) = NO_DEC;
399 (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun);
400 (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
401 print_declarations (out, A68_OPT (root_idf));
402 // Initialise.
403 get_stack (idf, out, fun, "A68_PROCEDURE");
404 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
405 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
406 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
407 // Execute procedure.
408 indent (out, "GENIE_UNIT_TRACE (NEXT_NEXT (body));\n");
409 indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
410 A68_OPT (indentation)++;
411 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
412 A68_OPT (indentation)--;
413 indent (out, "}\n");
414 indent (out, "CLOSE_FRAME;\n");
415 if (compose_fun == A68_MAKE_FUNCTION) {
416 write_fun_postlude (p, out, fn);
417 }
418 return fn;
419 }
420 }
421
422 //! @brief Compile deproceduring.
423
424 char *gen_voiding_deproceduring (NODE_T * p, FILE_T out, int compose_fun)
425 {
426 NODE_T *idf = stems_from (SUB_SUB (p), IDENTIFIER);
427 if (idf == NO_NODE) {
428 return NO_TEXT;
429 } else if (!(SUB_MOID (idf) == M_VOID || basic_mode (SUB_MOID (idf)))) {
430 return NO_TEXT;
431 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
432 return NO_TEXT;
433 } else {
434 static char fn[NAME_SIZE];
435 char fun[NAME_SIZE], pop[NAME_SIZE];
436 (void) make_name (fun, FUN, "", NUMBER (idf));
437 (void) make_name (pop, PUP, "", NUMBER (p));
438 comment_source (p, out);
439 (void) make_name (fn, moid_with_name ("void_", MOID (p), "_deproc"), "", NUMBER (p));
440 if (compose_fun == A68_MAKE_FUNCTION) {
441 write_fun_prelude (p, out, fn);
442 }
443 // Declare.
444 A68_OPT (root_idf) = NO_DEC;
445 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
446 (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun);
447 (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
448 print_declarations (out, A68_OPT (root_idf));
449 // Initialise.
450 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
451 // if (compose_fun != A68_MAKE_NOTHING) {
452 // }
453 get_stack (idf, out, fun, "A68_PROCEDURE");
454 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
455 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
456 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
457 // Execute procedure.
458 indent (out, "GENIE_UNIT_TRACE (NEXT_NEXT (body));\n");
459 indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
460 A68_OPT (indentation)++;
461 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
462 A68_OPT (indentation)--;
463 indent (out, "}\n");
464 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
465 indent (out, "CLOSE_FRAME;\n");
466 if (compose_fun == A68_MAKE_FUNCTION) {
467 write_fun_postlude (p, out, fn);
468 }
469 return fn;
470 }
471 }
472
473 //! @brief Compile call.
474
475 char *gen_call (NODE_T * p, FILE_T out, int compose_fun)
476 {
477 NODE_T *proc = SUB (p);
478 NODE_T *args = NEXT (proc);
479 NODE_T *idf = stems_from (proc, IDENTIFIER);
480 if (idf == NO_NODE) {
481 return NO_TEXT;
482 } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) {
483 return NO_TEXT;
484 } else if (DIM (MOID (proc)) == 0) {
485 return NO_TEXT;
486 } else if (A68_STANDENV_PROC (TAX (idf))) {
487 if (basic_call (p)) {
488 static char fun[NAME_SIZE];
489 comment_source (p, out);
490 (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p));
491 if (compose_fun == A68_MAKE_FUNCTION) {
492 write_fun_prelude (p, out, fun);
493 }
494 A68_OPT (root_idf) = NO_DEC;
495 inline_unit (p, out, L_DECLARE);
496 print_declarations (out, A68_OPT (root_idf));
497 inline_unit (p, out, L_EXECUTE);
498 gen_push (p, out);
499 if (compose_fun == A68_MAKE_FUNCTION) {
500 write_fun_postlude (p, out, fun);
501 }
502 return fun;
503 } else {
504 return NO_TEXT;
505 }
506 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
507 return NO_TEXT;
508 } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) {
509 return NO_TEXT;
510 } else if (!basic_argument (args)) {
511 return NO_TEXT;
512 } else {
513 static char fun[NAME_SIZE];
514 char body[NAME_SIZE], pop[NAME_SIZE];
515 // Declare.
516 (void) make_name (body, FUN, "", NUMBER (proc));
517 (void) make_name (pop, PUP, "", NUMBER (p));
518 comment_source (p, out);
519 (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p));
520 if (compose_fun == A68_MAKE_FUNCTION) {
521 write_fun_prelude (p, out, fun);
522 }
523 // Compute arguments.
524 int size = 0;
525 A68_OPT (root_idf) = NO_DEC;
526 inline_arguments (args, out, L_DECLARE, &size);
527 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
528 (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, body);
529 (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
530 print_declarations (out, A68_OPT (root_idf));
531 // Initialise.
532 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
533 inline_arguments (args, out, L_INITIALISE, &size);
534 get_stack (idf, out, body, "A68_PROCEDURE");
535 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", body));
536 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", body));
537 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
538 size = 0;
539 inline_arguments (args, out, L_EXECUTE, &size);
540 size = 0;
541 inline_arguments (args, out, L_YIELD, &size);
542 // Execute procedure.
543 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
544 indent (out, "GENIE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n");
545 indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
546 A68_OPT (indentation)++;
547 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
548 A68_OPT (indentation)--;
549 indent (out, "}\n");
550 indent (out, "CLOSE_FRAME;\n");
551 if (compose_fun == A68_MAKE_FUNCTION) {
552 write_fun_postlude (p, out, fun);
553 }
554 return fun;
555 }
556 }
557
558 //! @brief Compile call.
559
560 char *gen_voiding_call (NODE_T * p, FILE_T out, int compose_fun)
561 {
562 NODE_T *proc = SUB (stems_from (p, CALL));
563 NODE_T *args = NEXT (proc);
564 NODE_T *idf = stems_from (proc, IDENTIFIER);
565 if (idf == NO_NODE) {
566 return NO_TEXT;
567 } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) {
568 return NO_TEXT;
569 } else if (DIM (MOID (proc)) == 0) {
570 return NO_TEXT;
571 } else if (A68_STANDENV_PROC (TAX (idf))) {
572 return NO_TEXT;
573 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
574 return NO_TEXT;
575 } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) {
576 return NO_TEXT;
577 } else if (!basic_argument (args)) {
578 return NO_TEXT;
579 } else {
580 static char fun[NAME_SIZE];
581 // Declare.
582 char body[NAME_SIZE], pop[NAME_SIZE];
583 (void) make_name (body, FUN, "", NUMBER (proc));
584 (void) make_name (pop, PUP, "", NUMBER (p));
585 comment_source (p, out);
586 (void) make_name (fun, moid_with_name ("void_", SUB_MOID (proc), "_call"), "", NUMBER (p));
587 if (compose_fun == A68_MAKE_FUNCTION) {
588 write_fun_prelude (p, out, fun);
589 }
590 // Compute arguments.
591 int size = 0;
592 A68_OPT (root_idf) = NO_DEC;
593 inline_arguments (args, out, L_DECLARE, &size);
594 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
595 (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, body);
596 (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
597 print_declarations (out, A68_OPT (root_idf));
598 // Initialise.
599 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
600 inline_arguments (args, out, L_INITIALISE, &size);
601 get_stack (idf, out, body, "A68_PROCEDURE");
602 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", body));
603 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", body));
604 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
605 size = 0;
606 inline_arguments (args, out, L_EXECUTE, &size);
607 size = 0;
608 inline_arguments (args, out, L_YIELD, &size);
609 // Execute procedure.
610 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
611 indent (out, "GENIE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n");
612 indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
613 A68_OPT (indentation)++;
614 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
615 A68_OPT (indentation)--;
616 indent (out, "}\n");
617 indent (out, "CLOSE_FRAME;\n");
618 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
619 if (compose_fun == A68_MAKE_FUNCTION) {
620 write_fun_postlude (p, out, fun);
621 }
622 return fun;
623 }
624 }
625
626 //! @brief Compile voiding assignation.
627
628 char *gen_voiding_assignation_selection (NODE_T * p, FILE_T out, int compose_fun)
629 {
630 NODE_T *dst = SUB (stems_from (p, ASSIGNATION));
631 NODE_T *src = NEXT_NEXT (dst);
632 if (BASIC (dst, SELECTION) && basic_unit (src) && basic_mode_non_row (MOID (dst))) {
633 NODE_T *field = SUB (stems_from (dst, SELECTION));
634 NODE_T *sec = NEXT (field);
635 NODE_T *idf = stems_from (sec, IDENTIFIER);
636 char sel[NAME_SIZE], ref[NAME_SIZE], pop[NAME_SIZE];
637 char *field_idf = NSYMBOL (SUB (field));
638 static char fn[NAME_SIZE];
639 comment_source (p, out);
640 (void) make_name (pop, PUP, "", NUMBER (p));
641 (void) make_name (fn, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p));
642 if (compose_fun == A68_MAKE_FUNCTION) {
643 write_fun_prelude (p, out, fn);
644 }
645 // Declare.
646 A68_OPT (root_idf) = NO_DEC;
647 if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)) == NO_BOOK) {
648 (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field));
649 (void) make_name (sel, SEL, "", NUMBER (field));
650 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_REF * %s; /* %s */\n", ref, NSYMBOL (idf)));
651 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s * %s;\n", inline_mode (SUB_MOID (field)), sel));
652 sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
653 } else {
654 int n = NUMBER (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)));
655 (void) make_name (ref, NSYMBOL (idf), "", n);
656 (void) make_name (sel, SEL, "", n);
657 }
658 inline_unit (src, out, L_DECLARE);
659 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
660 print_declarations (out, A68_OPT (root_idf));
661 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
662 // Initialise.
663 if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)) == NO_BOOK) {
664 get_stack (idf, out, ref, "A68_REF");
665 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)));
666 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field));
667 }
668 inline_unit (src, out, L_EXECUTE);
669 // Generate.
670 gen_assign (src, out, sel);
671 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
672 if (compose_fun == A68_MAKE_FUNCTION) {
673 write_fun_postlude (p, out, fn);
674 }
675 return fn;
676 } else {
677 return NO_TEXT;
678 }
679 }
680
681 //! @brief Compile voiding assignation.
682
683 char *gen_voiding_assignation_slice (NODE_T * p, FILE_T out, int compose_fun)
684 {
685 NODE_T *dst = SUB (stems_from (p, ASSIGNATION));
686 NODE_T *src = NEXT_NEXT (dst);
687 NODE_T *slice = stems_from (SUB (dst), SLICE);
688 NODE_T *prim = SUB (slice);
689 MOID_T *mode = SUB_MOID (dst);
690 MOID_T *row_mode = DEFLEX (MOID (prim));
691 if (IS (row_mode, REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src))) {
692 NODE_T *indx = NEXT (prim);
693 char *symbol = NSYMBOL (SUB (prim));
694 char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], pop[NAME_SIZE];
695 static char fn[NAME_SIZE];
696 comment_source (p, out);
697 (void) make_name (pop, PUP, "", NUMBER (p));
698 (void) make_name (fn, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p));
699 if (compose_fun == A68_MAKE_FUNCTION) {
700 write_fun_prelude (p, out, fn);
701 }
702 // Declare.
703 A68_OPT (root_idf) = NO_DEC;
704 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
705 if (signed_in (BOOK_DECL, L_DECLARE, symbol) == NO_BOOK) {
706 (void) make_name (idf, symbol, "", NUMBER (prim));
707 (void) make_name (arr, ARR, "", NUMBER (prim));
708 (void) make_name (tup, TUP, "", NUMBER (prim));
709 (void) make_name (elm, ELM, "", NUMBER (prim));
710 (void) make_name (drf, DRF, "", NUMBER (prim));
711 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 1, idf);
712 (void) add_declaration (&A68_OPT (root_idf), "A68_REF", 0, elm);
713 (void) add_declaration (&A68_OPT (root_idf), "A68_ARRAY", 1, arr);
714 (void) add_declaration (&A68_OPT (root_idf), "A68_TUPLE", 1, tup);
715 (void) add_declaration (&A68_OPT (root_idf), inline_mode (mode), 1, drf);
716 sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim));
717 } else {
718 int n = NUMBER (signed_in (BOOK_DECL, L_EXECUTE, symbol));
719 (void) make_name (idf, symbol, "", n);
720 (void) make_name (arr, ARR, "", n);
721 (void) make_name (tup, TUP, "", n);
722 (void) make_name (elm, ELM, "", n);
723 (void) make_name (drf, DRF, "", n);
724 }
725 INT_T k = 0;
726 inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT);
727 inline_unit (src, out, L_DECLARE);
728 print_declarations (out, A68_OPT (root_idf));
729 // Initialise.
730 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
731 if (signed_in (BOOK_DECL, L_EXECUTE, symbol) == NO_BOOK) {
732 NODE_T *pidf = stems_from (prim, IDENTIFIER);
733 get_stack (pidf, out, idf, "A68_REF");
734 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf));
735 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr));
736 sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim));
737 }
738 k = 0;
739 inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT);
740 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr));
741 k = 0;
742 inline_indexer (indx, out, L_YIELD, &k, tup);
743 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ");\n"));
744 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm));
745 inline_unit (src, out, L_EXECUTE);
746 // Generate.
747 gen_assign (src, out, drf);
748 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
749 if (compose_fun == A68_MAKE_FUNCTION) {
750 write_fun_postlude (p, out, fn);
751 }
752 return fn;
753 } else {
754 return NO_TEXT;
755 }
756 }
757
758 //! @brief Compile voiding assignation.
759
760 char *gen_voiding_assignation_identifier (NODE_T * p, FILE_T out, int compose_fun)
761 {
762 NODE_T *dst = SUB (stems_from (p, ASSIGNATION));
763 NODE_T *src = NEXT_NEXT (dst);
764 if (BASIC (dst, IDENTIFIER) && basic_unit (src) && basic_mode_non_row (MOID (src))) {
765 static char fn[NAME_SIZE];
766 char idf[NAME_SIZE], pop[NAME_SIZE];
767 NODE_T *q = stems_from (dst, IDENTIFIER);
768 // Declare.
769 (void) make_name (pop, PUP, "", NUMBER (p));
770 comment_source (p, out);
771 (void) make_name (fn, moid_with_name ("void_", MOID (SUB (p)), "_assign"), "", NUMBER (p));
772 if (compose_fun == A68_MAKE_FUNCTION) {
773 write_fun_prelude (p, out, fn);
774 }
775 A68_OPT (root_idf) = NO_DEC;
776 if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) == NO_BOOK) {
777 (void) make_name (idf, NSYMBOL (q), "", NUMBER (p));
778 (void) add_declaration (&A68_OPT (root_idf), inline_mode (SUB_MOID (dst)), 1, idf);
779 sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q), NULL, NUMBER (p));
780 } else {
781 (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p))));
782 }
783 inline_unit (dst, out, L_DECLARE);
784 inline_unit (src, out, L_DECLARE);
785 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
786 print_declarations (out, A68_OPT (root_idf));
787 // Initialise.
788 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
789 inline_unit (dst, out, L_EXECUTE);
790 if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) == NO_BOOK) {
791 if (BODY (TAX (q)) != NO_TAG) {
792 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (SUB_MOID (dst))));
793 inline_unit (dst, out, L_YIELD);
794 undent (out, ");\n");
795 sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p));
796 } else {
797 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (SUB_MOID (dst))));
798 inline_unit (dst, out, L_YIELD);
799 undent (out, ");\n");
800 sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p));
801 }
802 }
803 inline_unit (src, out, L_EXECUTE);
804 gen_assign (src, out, idf);
805 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
806 if (compose_fun == A68_MAKE_FUNCTION) {
807 write_fun_postlude (p, out, fn);
808 }
809 return fn;
810 } else {
811 return NO_TEXT;
812 }
813 }
814
815 //! @brief Compile identity-relation.
816
817 char *gen_identity_relation (NODE_T * p, FILE_T out, int compose_fun)
818 {
819 #define GOOD(p) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((p), IDENTIFIER)), REF_SYMBOL))
820 NODE_T *lhs = SUB (p);
821 NODE_T *op = NEXT (lhs);
822 NODE_T *rhs = NEXT (op);
823 if (GOOD (lhs) && GOOD (rhs)) {
824 static char fn[NAME_SIZE];
825 comment_source (p, out);
826 (void) make_name (fn, moid_with_name ("", MOID (p), "_identity"), "", NUMBER (p));
827 if (compose_fun == A68_MAKE_FUNCTION) {
828 write_fun_prelude (p, out, fn);
829 }
830 A68_OPT (root_idf) = NO_DEC;
831 inline_identity_relation (p, out, L_DECLARE);
832 print_declarations (out, A68_OPT (root_idf));
833 inline_identity_relation (p, out, L_EXECUTE);
834 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
835 inline_identity_relation (p, out, L_YIELD);
836 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", A68_BOOL);\n"));
837 if (compose_fun == A68_MAKE_FUNCTION) {
838 write_fun_postlude (p, out, fn);
839 }
840 return fn;
841 } else if (GOOD (lhs) && stems_from (rhs, NIHIL) != NO_NODE) {
842 static char fn[NAME_SIZE];
843 comment_source (p, out);
844 (void) make_name (fn, moid_with_name ("", MOID (p), "_identity"), "", NUMBER (p));
845 if (compose_fun == A68_MAKE_FUNCTION) {
846 write_fun_prelude (p, out, fn);
847 }
848 A68_OPT (root_idf) = NO_DEC;
849 inline_identity_relation (p, out, L_DECLARE);
850 print_declarations (out, A68_OPT (root_idf));
851 inline_identity_relation (p, out, L_EXECUTE);
852 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
853 inline_identity_relation (p, out, L_YIELD);
854 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", A68_BOOL);\n"));
855 if (compose_fun == A68_MAKE_FUNCTION) {
856 write_fun_postlude (p, out, fn);
857 }
858 return fn;
859 } else {
860 return NO_TEXT;
861 }
862 #undef GOOD
863 }
864
865 //! @brief Compile closed clause.
866
867 void gen_declaration_list (NODE_T * p, FILE_T out, int *decs, char *pop)
868 {
869 for (; p != NO_NODE; FORWARD (p)) {
870 switch (ATTRIBUTE (p)) {
871 case MODE_DECLARATION:
872 case PROCEDURE_DECLARATION:
873 case BRIEF_OPERATOR_DECLARATION:
874 case PRIORITY_DECLARATION: {
875 // No action needed.
876 (*decs)++;
877 return;
878 }
879 case OPERATOR_DECLARATION: {
880 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_operator_dec (_NODE_ (%d));", NUMBER (SUB (p))));
881 inline_comment_source (p, out);
882 undent (out, NEWLINE_STRING);
883 (*decs)++;
884 break;
885 }
886 case IDENTITY_DECLARATION: {
887 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_identity_dec (_NODE_ (%d));", NUMBER (SUB (p))));
888 inline_comment_source (p, out);
889 undent (out, NEWLINE_STRING);
890 (*decs)++;
891 break;
892 }
893 case VARIABLE_DECLARATION: {
894 char declarer[NAME_SIZE];
895 (void) make_name (declarer, DEC, "", NUMBER (SUB (p)));
896 indent (out, "{");
897 inline_comment_source (p, out);
898 undent (out, NEWLINE_STRING);
899 A68_OPT (indentation)++;
900 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "NODE_T *%s = NO_NODE;\n", declarer));
901 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_variable_dec (_NODE_ (%d), &%s, A68_SP);\n", NUMBER (SUB (p)), declarer));
902 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
903 A68_OPT (indentation)--;
904 indent (out, "}\n");
905 (*decs)++;
906 break;
907 }
908 case PROCEDURE_VARIABLE_DECLARATION: {
909 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "genie_proc_variable_dec (_NODE_ (%d));", NUMBER (SUB (p))));
910 inline_comment_source (p, out);
911 undent (out, NEWLINE_STRING);
912 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
913 (*decs)++;
914 break;
915 }
916 default: {
917 gen_declaration_list (SUB (p), out, decs, pop);
918 break;
919 }
920 }
921 }
922 }
923
924 //! @brief Compile closed clause.
925
926 void gen_serial_clause (NODE_T * p, FILE_T out, NODE_T ** last, int *units, int *decs, char *pop, int compose_fun)
927 {
928 for (; p != NO_NODE && A68_OPT (code_errors) == 0; FORWARD (p)) {
929 if (compose_fun == A68_MAKE_OTHERS) {
930 if (IS (p, UNIT)) {
931 (*units)++;
932 }
933 if (IS (p, DECLARATION_LIST)) {
934 (*decs)++;
935 }
936 if (IS (p, UNIT) || IS (p, DECLARATION_LIST)) {
937 if (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
938 if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) {
939 gen_units (SUB_SUB (p), out);
940 } else {
941 gen_units (SUB (p), out);
942 }
943 } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
944 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
945 a68_free (COMPILE_NAME (GINFO (p)));
946 COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT);
947 }
948 return;
949 } else {
950 gen_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun);
951 }
952 } else
953 switch (ATTRIBUTE (p)) {
954 case UNIT: {
955 (*last) = p;
956 CODE_EXECUTE (p);
957 inline_comment_source (p, out);
958 undent (out, NEWLINE_STRING);
959 (*units)++;
960 return;
961 }
962 case SEMI_SYMBOL: {
963 if (IS (*last, UNIT) && MOID (*last) == M_VOID) {
964 break;
965 } else if (IS (*last, DECLARATION_LIST)) {
966 break;
967 } else {
968 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
969 }
970 break;
971 }
972 case DECLARATION_LIST: {
973 (*last) = p;
974 gen_declaration_list (SUB (p), out, decs, pop);
975 break;
976 }
977 default: {
978 gen_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun);
979 break;
980 }
981 }
982 }
983 }
984
985 //! @brief Embed serial clause.
986
987 void embed_serial_clause (NODE_T * p, FILE_T out, char *pop)
988 {
989 NODE_T *last = NO_NODE;
990 int units = 0, decs = 0;
991 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%d));\n", NUMBER (p)));
992 init_static_frame (out, p);
993 gen_serial_clause (p, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION);
994 indent (out, "CLOSE_FRAME;\n");
995 }
996
997 //! @brief Compile code clause.
998
999 char *gen_code_clause (NODE_T * p, FILE_T out, int compose_fun)
1000 {
1001 static char fn[NAME_SIZE];
1002 comment_source (p, out);
1003 (void) make_name (fn, "code", "", NUMBER (p));
1004 if (compose_fun == A68_MAKE_FUNCTION) {
1005 write_fun_prelude (p, out, fn);
1006 }
1007 embed_code_clause (SUB (p), out);
1008 if (compose_fun == A68_MAKE_FUNCTION) {
1009 (void) make_name (fn, "code", "", NUMBER (p));
1010 write_fun_postlude (p, out, fn);
1011 }
1012 return fn;
1013 }
1014
1015 //! @brief Compile closed clause.
1016
1017 char *gen_closed_clause (NODE_T * p, FILE_T out, int compose_fun)
1018 {
1019 NODE_T *sc = NEXT_SUB (p);
1020 if (MOID (p) == M_VOID && LABELS (TABLE (sc)) == NO_TAG) {
1021 static char fn[NAME_SIZE];
1022 char pop[NAME_SIZE];
1023 int units = 0, decs = 0;
1024 NODE_T *last = NO_NODE;
1025 gen_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
1026 (void) make_name (pop, PUP, "", NUMBER (p));
1027 comment_source (p, out);
1028 (void) make_name (fn, "closed", "", NUMBER (p));
1029 if (compose_fun == A68_MAKE_FUNCTION) {
1030 write_fun_prelude (p, out, fn);
1031 }
1032 A68_OPT (root_idf) = NO_DEC;
1033 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
1034 print_declarations (out, A68_OPT (root_idf));
1035 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
1036 embed_serial_clause (sc, out, pop);
1037 if (compose_fun == A68_MAKE_FUNCTION) {
1038 (void) make_name (fn, "closed", "", NUMBER (p));
1039 write_fun_postlude (p, out, fn);
1040 }
1041 return fn;
1042 } else {
1043 return NO_TEXT;
1044 }
1045 }
1046
1047 //! @brief Compile collateral clause.
1048
1049 char *gen_collateral_clause (NODE_T * p, FILE_T out, int compose_fun)
1050 {
1051 if (basic_unit (p) && IS (MOID (p), STRUCT_SYMBOL)) {
1052 static char fn[NAME_SIZE];
1053 comment_source (p, out);
1054 (void) make_name (fn, "collateral", "", NUMBER (p));
1055 if (compose_fun == A68_MAKE_FUNCTION) {
1056 write_fun_prelude (p, out, fn);
1057 }
1058 A68_OPT (root_idf) = NO_DEC;
1059 inline_collateral_units (NEXT_SUB (p), out, L_DECLARE);
1060 print_declarations (out, A68_OPT (root_idf));
1061 inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE);
1062 inline_collateral_units (NEXT_SUB (p), out, L_YIELD);
1063 if (compose_fun == A68_MAKE_FUNCTION) {
1064 (void) make_name (fn, "collateral", "", NUMBER (p));
1065 write_fun_postlude (p, out, fn);
1066 }
1067 return fn;
1068 } else {
1069 return NO_TEXT;
1070 }
1071 }
1072
1073 //! @brief Compile conditional clause.
1074
1075 char *gen_basic_conditional (NODE_T * p, FILE_T out, int compose_fun)
1076 {
1077 static char fn[NAME_SIZE];
1078 NODE_T *q = SUB (p);
1079 if (!(basic_mode (MOID (p)) || MOID (p) == M_VOID)) {
1080 return NO_TEXT;
1081 }
1082 p = q;
1083 if (!basic_conditional (p)) {
1084 return NO_TEXT;
1085 }
1086 comment_source (p, out);
1087 (void) make_name (fn, "conditional", "", NUMBER (q));
1088 if (compose_fun == A68_MAKE_FUNCTION) {
1089 write_fun_prelude (q, out, fn);
1090 }
1091 // Collect declarations.
1092 if (IS (p, IF_PART) || IS (p, OPEN_PART)) {
1093 A68_OPT (root_idf) = NO_DEC;
1094 inline_unit (SUB (NEXT_SUB (p)), out, L_DECLARE);
1095 print_declarations (out, A68_OPT (root_idf));
1096 inline_unit (SUB (NEXT_SUB (p)), out, L_EXECUTE);
1097 indent (out, "if (");
1098 inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD);
1099 undent (out, ") {\n");
1100 A68_OPT (indentation)++;
1101 } else {
1102 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1103 }
1104 FORWARD (p);
1105 if (IS (p, THEN_PART) || IS (p, CHOICE)) {
1106 int pop = A68_OPT (cse_pointer);
1107 (void) gen_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING);
1108 A68_OPT (indentation)--;
1109 A68_OPT (cse_pointer) = pop;
1110 } else {
1111 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
1112 }
1113 FORWARD (p);
1114 if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
1115 int pop = A68_OPT (cse_pointer);
1116 indent (out, "} else {\n");
1117 A68_OPT (indentation)++;
1118 (void) gen_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING);
1119 A68_OPT (indentation)--;
1120 A68_OPT (cse_pointer) = pop;
1121 }
1122 // Done.
1123 indent (out, "}\n");
1124 if (compose_fun == A68_MAKE_FUNCTION) {
1125 (void) make_name (fn, "conditional", "", NUMBER (q));
1126 write_fun_postlude (q, out, fn);
1127 }
1128 return fn;
1129 }
1130
1131 //! @brief Compile conditional clause.
1132
1133 char *gen_conditional_clause (NODE_T * p, FILE_T out, int compose_fun)
1134 {
1135 static char fn[NAME_SIZE];
1136 char pop[NAME_SIZE];
1137 int units = 0, decs = 0;
1138 // We only compile IF basic unit or ELIF basic unit, so we save on opening frames.
1139 // Check worthiness of the clause.
1140 if (MOID (p) != M_VOID) {
1141 return NO_TEXT;
1142 }
1143 NODE_T *q = SUB (p);
1144 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1145 if (!basic_serial (NEXT_SUB (q), 1)) {
1146 return NO_TEXT;
1147 }
1148 FORWARD (q);
1149 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1150 if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) {
1151 return NO_TEXT;
1152 }
1153 FORWARD (q);
1154 }
1155 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1156 q = SUB (q);
1157 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1158 FORWARD (q);
1159 }
1160 }
1161 // Generate embedded units.
1162 q = SUB (p);
1163 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1164 FORWARD (q);
1165 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1166 NODE_T *last = NO_NODE;
1167 units = decs = 0;
1168 gen_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
1169 FORWARD (q);
1170 }
1171 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1172 q = SUB (q);
1173 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1174 FORWARD (q);
1175 }
1176 }
1177 // Prep and Dec.
1178 (void) make_name (fn, "conditional", "", NUMBER (p));
1179 (void) make_name (pop, PUP, "", NUMBER (p));
1180 comment_source (p, out);
1181 if (compose_fun == A68_MAKE_FUNCTION) {
1182 write_fun_prelude (p, out, fn);
1183 }
1184 A68_OPT (root_idf) = NO_DEC;
1185 q = SUB (p);
1186 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1187 inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE);
1188 FORWARD (q);
1189 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1190 FORWARD (q);
1191 }
1192 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1193 q = SUB (q);
1194 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1195 FORWARD (q);
1196 }
1197 }
1198 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
1199 print_declarations (out, A68_OPT (root_idf));
1200 // Generate the function body.
1201 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
1202 q = SUB (p);
1203 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1204 inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE);
1205 FORWARD (q);
1206 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1207 FORWARD (q);
1208 }
1209 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1210 q = SUB (q);
1211 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1212 FORWARD (q);
1213 }
1214 }
1215 q = SUB (p);
1216 while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) {
1217 BOOL_T else_part = A68_FALSE;
1218 if (is_one_of (q, IF_PART, OPEN_PART, STOP)) {
1219 indent (out, "if (");
1220 } else {
1221 indent (out, "} else if (");
1222 }
1223 inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD);
1224 undent (out, ") {\n");
1225 FORWARD (q);
1226 while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) {
1227 if (else_part) {
1228 indent (out, "} else {\n");
1229 }
1230 A68_OPT (indentation)++;
1231 embed_serial_clause (NEXT_SUB (q), out, pop);
1232 A68_OPT (indentation)--;
1233 else_part = A68_TRUE;
1234 FORWARD (q);
1235 }
1236 if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
1237 q = SUB (q);
1238 } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL, STOP)) {
1239 FORWARD (q);
1240 }
1241 }
1242 indent (out, "}\n");
1243 if (compose_fun == A68_MAKE_FUNCTION) {
1244 (void) make_name (fn, "conditional", "", NUMBER (p));
1245 write_fun_postlude (p, out, fn);
1246 }
1247 return fn;
1248 }
1249
1250 //! @brief Compile unit from integral-case in-part.
1251
1252 BOOL_T gen_int_case_units (NODE_T * p, FILE_T out, NODE_T * sym, int k, int *count, int compose_fun)
1253 {
1254 if (p == NO_NODE) {
1255 return A68_FALSE;
1256 } else {
1257 if (IS (p, UNIT)) {
1258 if (k == *count) {
1259 if (compose_fun == A68_MAKE_FUNCTION) {
1260 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "case %d: {\n", k));
1261 A68_OPT (indentation)++;
1262 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%d));\n", NUMBER (sym)));
1263 CODE_EXECUTE (p);
1264 inline_comment_source (p, out);
1265 undent (out, NEWLINE_STRING);
1266 indent (out, "CLOSE_FRAME;\n");
1267 indent (out, "break;\n");
1268 A68_OPT (indentation)--;
1269 indent (out, "}\n");
1270 } else if (compose_fun == A68_MAKE_OTHERS) {
1271 if (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
1272 if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) {
1273 gen_units (SUB_SUB (p), out);
1274 } else {
1275 gen_units (SUB (p), out);
1276 }
1277 } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
1278 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
1279 a68_free (COMPILE_NAME (GINFO (p)));
1280 COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT);
1281 }
1282 }
1283 return A68_TRUE;
1284 } else {
1285 (*count)++;
1286 return A68_FALSE;
1287 }
1288 } else {
1289 if (gen_int_case_units (SUB (p), out, sym, k, count, compose_fun)) {
1290 return A68_TRUE;
1291 } else {
1292 return gen_int_case_units (NEXT (p), out, sym, k, count, compose_fun);
1293 }
1294 }
1295 }
1296 }
1297
1298 //! @brief Compile integral-case-clause.
1299
1300 char *gen_int_case_clause (NODE_T * p, FILE_T out, int compose_fun)
1301 {
1302 static char fn[NAME_SIZE];
1303 char pop[NAME_SIZE];
1304 int units = 0, decs = 0, k = 0, count = 0;
1305 // We only compile CASE basic unit.
1306 // Check worthiness of the clause.
1307 if (MOID (p) != M_VOID) {
1308 return NO_TEXT;
1309 }
1310 NODE_T *q = SUB (p);
1311 if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) {
1312 if (!basic_serial (NEXT_SUB (q), 1)) {
1313 return NO_TEXT;
1314 }
1315 FORWARD (q);
1316 } else {
1317 return NO_TEXT;
1318 }
1319 while (q != NO_NODE && is_one_of (q, CASE_IN_PART, OUT_PART, CHOICE, STOP)) {
1320 if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) {
1321 return NO_TEXT;
1322 }
1323 FORWARD (q);
1324 }
1325 if (q != NO_NODE && is_one_of (q, ESAC_SYMBOL, CLOSE_SYMBOL, STOP)) {
1326 FORWARD (q);
1327 } else {
1328 return NO_TEXT;
1329 }
1330 // Generate embedded units.
1331 q = SUB (p);
1332 if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) {
1333 FORWARD (q);
1334 if (q != NO_NODE && is_one_of (q, CASE_IN_PART, CHOICE, STOP)) {
1335 units = decs = 0;
1336 k = 0;
1337 do {
1338 count = 1;
1339 k++;
1340 } while (gen_int_case_units (NEXT_SUB (q), out, NO_NODE, k, &count, A68_MAKE_OTHERS));
1341 FORWARD (q);
1342 }
1343 if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) {
1344 NODE_T *last = NO_NODE;
1345 units = decs = 0;
1346 gen_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
1347 FORWARD (q);
1348 }
1349 }
1350 // Prep and Dec.
1351 (void) make_name (pop, PUP, "", NUMBER (p));
1352 comment_source (p, out);
1353 (void) make_name (fn, "case", "", NUMBER (p));
1354 if (compose_fun == A68_MAKE_FUNCTION) {
1355 write_fun_prelude (p, out, fn);
1356 }
1357 A68_OPT (root_idf) = NO_DEC;
1358 q = SUB (p);
1359 inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE);
1360 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
1361 print_declarations (out, A68_OPT (root_idf));
1362 // Generate the function body.
1363 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
1364 q = SUB (p);
1365 inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE);
1366 indent (out, "switch (");
1367 inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD);
1368 undent (out, ") {\n");
1369 A68_OPT (indentation)++;
1370 FORWARD (q);
1371 k = 0;
1372 do {
1373 count = 1;
1374 k++;
1375 } while (gen_int_case_units (NEXT_SUB (q), out, SUB (q), k, &count, A68_MAKE_FUNCTION));
1376 FORWARD (q);
1377 if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) {
1378 indent (out, "default: {\n");
1379 A68_OPT (indentation)++;
1380 embed_serial_clause (NEXT_SUB (q), out, pop);
1381 indent (out, "break;\n");
1382 A68_OPT (indentation)--;
1383 indent (out, "}\n");
1384 }
1385 A68_OPT (indentation)--;
1386 indent (out, "}\n");
1387 if (compose_fun == A68_MAKE_FUNCTION) {
1388 (void) make_name (fn, "case", "", NUMBER (p));
1389 write_fun_postlude (p, out, fn);
1390 }
1391 return fn;
1392 }
1393
1394 //! @brief Compile loop clause.
1395
1396 char *gen_loop_clause (NODE_T * p, FILE_T out, int compose_fun)
1397 {
1398 NODE_T *for_part = NO_NODE, *from_part = NO_NODE, *by_part = NO_NODE, *to_part = NO_NODE, *downto_part = NO_NODE, *while_part = NO_NODE, *sc;
1399 static char fn[NAME_SIZE];
1400 char idf[NAME_SIZE], z[NAME_SIZE], pop[NAME_SIZE];
1401 NODE_T *q = SUB (p);
1402 // FOR identifier.
1403 if (IS (q, FOR_PART)) {
1404 for_part = NEXT_SUB (q);
1405 FORWARD (q);
1406 }
1407 // FROM unit.
1408 if (IS (p, FROM_PART)) {
1409 from_part = NEXT_SUB (q);
1410 if (!basic_unit (from_part)) {
1411 return NO_TEXT;
1412 }
1413 FORWARD (q);
1414 }
1415 // BY unit.
1416 if (IS (q, BY_PART)) {
1417 by_part = NEXT_SUB (q);
1418 if (!basic_unit (by_part)) {
1419 return NO_TEXT;
1420 }
1421 FORWARD (q);
1422 }
1423 // TO unit, DOWNTO unit.
1424 if (IS (q, TO_PART)) {
1425 if (IS (SUB (q), TO_SYMBOL)) {
1426 to_part = NEXT_SUB (q);
1427 if (!basic_unit (to_part)) {
1428 return NO_TEXT;
1429 }
1430 } else if (IS (SUB (q), DOWNTO_SYMBOL)) {
1431 downto_part = NEXT_SUB (q);
1432 if (!basic_unit (downto_part)) {
1433 return NO_TEXT;
1434 }
1435 }
1436 FORWARD (q);
1437 }
1438 // WHILE DO OD is not yet supported.
1439 if (IS (q, WHILE_PART)) {
1440 return NO_TEXT;
1441 }
1442 // DO UNTIL OD is not yet supported.
1443 if (IS (q, DO_PART) || IS (q, ALT_DO_PART)) {
1444 sc = q = NEXT_SUB (q);
1445 if (IS (q, SERIAL_CLAUSE)) {
1446 FORWARD (q);
1447 }
1448 if (q != NO_NODE && IS (q, UNTIL_PART)) {
1449 return NO_TEXT;
1450 }
1451 } else {
1452 return NO_TEXT;
1453 }
1454 if (LABELS (TABLE (sc)) != NO_TAG) {
1455 return NO_TEXT;
1456 }
1457 // Loop clause is compiled.
1458 int units = 0, decs = 0;
1459 NODE_T *last = NO_NODE;
1460 gen_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS);
1461 BOOL_T gc = (decs > 0);
1462 comment_source (p, out);
1463 (void) make_name (fn, "loop", "", NUMBER (p));
1464 if (compose_fun == A68_MAKE_FUNCTION) {
1465 write_fun_prelude (p, out, fn);
1466 }
1467 A68_OPT (root_idf) = NO_DEC;
1468 (void) make_name (idf, "k", "", NUMBER (p));
1469 (void) add_declaration (&A68_OPT (root_idf), "INT_T", 0, idf);
1470 if (for_part != NO_NODE) {
1471 (void) make_name (z, "z", "", NUMBER (p));
1472 (void) add_declaration (&A68_OPT (root_idf), "A68_INT", 1, z);
1473 }
1474 if (from_part != NO_NODE) {
1475 inline_unit (from_part, out, L_DECLARE);
1476 }
1477 if (by_part != NO_NODE) {
1478 inline_unit (by_part, out, L_DECLARE);
1479 }
1480 if (to_part != NO_NODE) {
1481 inline_unit (to_part, out, L_DECLARE);
1482 }
1483 if (downto_part != NO_NODE) {
1484 inline_unit (downto_part, out, L_DECLARE);
1485 }
1486 if (while_part != NO_NODE) {
1487 inline_unit (SUB (NEXT_SUB (while_part)), out, L_DECLARE);
1488 }
1489 (void) make_name (pop, PUP, "", NUMBER (p));
1490 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
1491 print_declarations (out, A68_OPT (root_idf));
1492 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
1493 if (from_part != NO_NODE) {
1494 inline_unit (from_part, out, L_EXECUTE);
1495 }
1496 if (by_part != NO_NODE) {
1497 inline_unit (by_part, out, L_EXECUTE);
1498 }
1499 if (to_part != NO_NODE) {
1500 inline_unit (to_part, out, L_EXECUTE);
1501 }
1502 if (downto_part != NO_NODE) {
1503 inline_unit (downto_part, out, L_EXECUTE);
1504 }
1505 if (while_part != NO_NODE) {
1506 inline_unit (SUB (NEXT_SUB (while_part)), out, L_EXECUTE);
1507 }
1508 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_NODE_ (%d));\n", NUMBER (sc)));
1509 init_static_frame (out, sc);
1510 if (for_part != NO_NODE) {
1511 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (_NODE_ (%d)))));\n", z, NUMBER (for_part)));
1512 }
1513 // The loop in C.
1514 // Initialisation.
1515 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "for (%s = ", idf));
1516 if (from_part == NO_NODE) {
1517 undent (out, "1");
1518 } else {
1519 inline_unit (from_part, out, L_YIELD);
1520 }
1521 undent (out, "; ");
1522 // Condition.
1523 if (to_part == NO_NODE && downto_part == NO_NODE && while_part == NO_NODE) {
1524 undent (out, "A68_TRUE");
1525 } else {
1526 undent (out, idf);
1527 if (to_part != NO_NODE) {
1528 undent (out, " <= ");
1529 } else if (downto_part != NO_NODE) {
1530 undent (out, " >= ");
1531 }
1532 inline_unit (to_part, out, L_YIELD);
1533 }
1534 undent (out, "; ");
1535 // Increment.
1536 if (by_part == NO_NODE) {
1537 undent (out, idf);
1538 if (to_part != NO_NODE) {
1539 undent (out, " ++");
1540 } else if (downto_part != NO_NODE) {
1541 undent (out, " --");
1542 } else {
1543 undent (out, " ++");
1544 }
1545 } else {
1546 undent (out, idf);
1547 if (to_part != NO_NODE) {
1548 undent (out, " += ");
1549 } else if (downto_part != NO_NODE) {
1550 undent (out, " -= ");
1551 } else {
1552 undent (out, " += ");
1553 }
1554 inline_unit (by_part, out, L_YIELD);
1555 }
1556 undent (out, ") {\n");
1557 A68_OPT (indentation)++;
1558 if (gc) {
1559 indent (out, "// genie_preemptive_gc_heap (p);\n");
1560 }
1561 if (for_part != NO_NODE) {
1562 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_STATUS_ (%s) = INIT_MASK;\n", z));
1563 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "_VALUE_ (%s) = %s;\n", z, idf));
1564 }
1565 units = decs = 0;
1566 gen_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION);
1567 // Re-initialise if necessary.
1568 BOOL_T need_reinit = (BOOL_T) (AP_INCREMENT (TABLE (sc)) > 0 || need_initialise_frame (sc));
1569 if (need_reinit) {
1570 indent (out, "if (");
1571 if (to_part == NO_NODE && downto_part == NO_NODE) {
1572 undent (out, "A68_TRUE");
1573 } else {
1574 undent (out, idf);
1575 if (to_part != NO_NODE) {
1576 undent (out, " < ");
1577 } else if (downto_part != NO_NODE) {
1578 undent (out, " > ");
1579 }
1580 inline_unit (to_part, out, L_YIELD);
1581 }
1582 undent (out, ") {\n");
1583 A68_OPT (indentation)++;
1584 if (AP_INCREMENT (TABLE (sc)) > 0) {
1585 #if (A68_LEVEL >= 3)
1586 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (%llu);\n", AP_INCREMENT (TABLE (sc))));
1587 #else
1588 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (%u);\n", AP_INCREMENT (TABLE (sc))));
1589 #endif
1590 }
1591 if (need_initialise_frame (sc)) {
1592 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "initialise_frame (_NODE_ (%d));\n", NUMBER (sc)));
1593 }
1594 A68_OPT (indentation)--;
1595 indent (out, "}\n");
1596 }
1597 // End of loop.
1598 A68_OPT (indentation)--;
1599 indent (out, "}\n");
1600 indent (out, "CLOSE_FRAME;\n");
1601 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
1602 if (compose_fun == A68_MAKE_FUNCTION) {
1603 (void) make_name (fn, "loop", "", NUMBER (p));
1604 write_fun_postlude (p, out, fn);
1605 }
1606 return fn;
1607 }
1608
1609 //! @brief Optimise units.
1610
1611 char *gen_unit (NODE_T * p, FILE_T out, int compose_fun)
1612 {
1613 #define COMPILE(p, out, fun, compose_fun) {\
1614 char * fn = (fun) (p, out, compose_fun);\
1615 if (compose_fun == A68_MAKE_FUNCTION && fn != NO_TEXT) {\
1616 ABEND (strlen (fn) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__);\
1617 COMPILE_NAME (GINFO (p)) = new_string (fn, NO_TEXT);\
1618 if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {\
1619 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));\
1620 } else {\
1621 COMPILE_NODE (GINFO (p)) = NUMBER (p);\
1622 }\
1623 return COMPILE_NAME (GINFO (p));\
1624 } else {\
1625 COMPILE_NAME (GINFO (p)) = NO_TEXT;\
1626 COMPILE_NODE (GINFO (p)) = 0;\
1627 return NO_TEXT;\
1628 }}
1629
1630 LOW_SYSTEM_STACK_ALERT (p);
1631 if (p == NO_NODE) {
1632 return NO_TEXT;
1633 } else if (COMPILE_NAME (GINFO (p)) != NO_TEXT) {
1634 return NO_TEXT;
1635 } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) {
1636 COMPILE (SUB (p), out, gen_unit, compose_fun);
1637 }
1638 if (A68_OPT (OPTION_CODE_LEVEL) >= 3) {
1639 // Control structure.
1640 if (IS (p, CLOSED_CLAUSE)) {
1641 COMPILE (p, out, gen_closed_clause, compose_fun);
1642 } else if (IS (p, COLLATERAL_CLAUSE)) {
1643 COMPILE (p, out, gen_collateral_clause, compose_fun);
1644 } else if (IS (p, CONDITIONAL_CLAUSE)) {
1645 char *fn2 = gen_basic_conditional (p, out, compose_fun);
1646 if (compose_fun == A68_MAKE_FUNCTION && fn2 != NO_TEXT) {
1647 ABEND (strlen (fn2) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__);
1648 COMPILE_NAME (GINFO (p)) = new_string (fn2, NO_TEXT);
1649 if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {
1650 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
1651 } else {
1652 COMPILE_NODE (GINFO (p)) = NUMBER (p);
1653 }
1654 return COMPILE_NAME (GINFO (p));
1655 } else {
1656 COMPILE (p, out, gen_conditional_clause, compose_fun);
1657 }
1658 } else if (IS (p, CASE_CLAUSE)) {
1659 COMPILE (p, out, gen_int_case_clause, compose_fun);
1660 } else if (IS (p, LOOP_CLAUSE)) {
1661 COMPILE (p, out, gen_loop_clause, compose_fun);
1662 }
1663 }
1664 if (A68_OPT (OPTION_CODE_LEVEL) >= 2) {
1665 // Simple constructions.
1666 if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), IDENTIFIER) != NO_NODE) {
1667 COMPILE (p, out, gen_voiding_assignation_identifier, compose_fun);
1668 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SLICE) != NO_NODE) {
1669 COMPILE (p, out, gen_voiding_assignation_slice, compose_fun);
1670 } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SELECTION) != NO_NODE) {
1671 COMPILE (p, out, gen_voiding_assignation_selection, compose_fun);
1672 } else if (IS (p, SLICE)) {
1673 COMPILE (p, out, gen_slice, compose_fun);
1674 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SLICE) != NO_NODE) {
1675 COMPILE (p, out, gen_dereference_slice, compose_fun);
1676 } else if (IS (p, SELECTION)) {
1677 COMPILE (p, out, gen_selection, compose_fun);
1678 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SELECTION) != NO_NODE) {
1679 COMPILE (p, out, gen_dereference_selection, compose_fun);
1680 } else if (IS (p, VOIDING) && IS (SUB (p), FORMULA)) {
1681 COMPILE (SUB (p), out, gen_voiding_formula, compose_fun);
1682 } else if (IS (p, VOIDING) && IS (SUB (p), MONADIC_FORMULA)) {
1683 COMPILE (SUB (p), out, gen_voiding_formula, compose_fun);
1684 } else if (IS (p, DEPROCEDURING)) {
1685 COMPILE (p, out, gen_deproceduring, compose_fun);
1686 } else if (IS (p, VOIDING) && IS (SUB (p), DEPROCEDURING)) {
1687 COMPILE (p, out, gen_voiding_deproceduring, compose_fun);
1688 } else if (IS (p, VOIDING) && IS (SUB (p), CALL)) {
1689 COMPILE (p, out, gen_voiding_call, compose_fun);
1690 } else if (IS (p, IDENTITY_RELATION)) {
1691 COMPILE (p, out, gen_identity_relation, compose_fun);
1692 } else if (IS (p, UNITING)) {
1693 COMPILE (p, out, gen_uniting, compose_fun);
1694 }
1695 }
1696 if (A68_OPT (OPTION_CODE_LEVEL) >= 1) {
1697 // Most basic stuff.
1698 if (IS (p, VOIDING)) {
1699 COMPILE (SUB (p), out, gen_unit, compose_fun);
1700 } else if (IS (p, DENOTATION)) {
1701 COMPILE (p, out, gen_denotation, compose_fun);
1702 } else if (IS (p, CAST)) {
1703 COMPILE (p, out, gen_cast, compose_fun);
1704 } else if (IS (p, IDENTIFIER)) {
1705 COMPILE (p, out, gen_identifier, compose_fun);
1706 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER) != NO_NODE) {
1707 COMPILE (p, out, gen_dereference_identifier, compose_fun);
1708 } else if (IS (p, MONADIC_FORMULA)) {
1709 COMPILE (p, out, gen_formula, compose_fun);
1710 } else if (IS (p, FORMULA)) {
1711 COMPILE (p, out, gen_formula, compose_fun);
1712 } else if (IS (p, CALL)) {
1713 COMPILE (p, out, gen_call, compose_fun);
1714 }
1715 }
1716 if (IS (p, CODE_CLAUSE)) {
1717 COMPILE (p, out, gen_code_clause, compose_fun);
1718 }
1719 return NO_TEXT;
1720 #undef COMPILE
1721 }
1722
1723 //! @brief Compile unit.
1724
1725 char *gen_basic (NODE_T * p, FILE_T out)
1726 {
1727 #define COMPILE(p, out, fun) {\
1728 char * fn = (fun) (p, out);\
1729 if (fn != NO_TEXT) {\
1730 ABEND (strlen (fn) >= NAME_SIZE, ERROR_INTERNAL_CONSISTENCY, __func__);\
1731 COMPILE_NAME (GINFO (p)) = new_string (fn, NO_TEXT);\
1732 if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {\
1733 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));\
1734 } else {\
1735 COMPILE_NODE (GINFO (p)) = NUMBER (p);\
1736 }\
1737 return COMPILE_NAME (GINFO (p));\
1738 } else {\
1739 COMPILE_NAME (GINFO (p)) = NO_TEXT;\
1740 COMPILE_NODE (GINFO (p)) = 0;\
1741 return NO_TEXT;\
1742 }}
1743
1744 LOW_SYSTEM_STACK_ALERT (p);
1745 if (p == NO_NODE) {
1746 return NO_TEXT;
1747 } else if (COMPILE_NAME (GINFO (p)) != NO_TEXT) {
1748 return NO_TEXT;
1749 } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) {
1750 COMPILE (SUB (p), out, gen_basic);
1751 }
1752 // Most basic stuff.
1753 if (IS (p, VOIDING)) {
1754 COMPILE (SUB (p), out, gen_basic);
1755 } else if (IS (p, DENOTATION)) {
1756 COMPILE (p, out, compile_denotation);
1757 } else if (IS (p, CAST)) {
1758 COMPILE (p, out, compile_cast);
1759 } else if (IS (p, IDENTIFIER)) {
1760 COMPILE (p, out, compile_identifier);
1761 } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER) != NO_NODE) {
1762 COMPILE (p, out, compile_dereference_identifier);
1763 } else if (IS (p, FORMULA)) {
1764 COMPILE (p, out, compile_formula);
1765 } else if (IS (p, CALL)) {
1766 COMPILE (p, out, compile_call);
1767 }
1768 return NO_TEXT;
1769 #undef COMPILE
1770 }
1771
1772 //! @brief Optimise units.
1773
1774 void gen_units (NODE_T * p, FILE_T out)
1775 {
1776 for (; p != NO_NODE; FORWARD (p)) {
1777 if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) {
1778 if (gen_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) {
1779 gen_units (SUB (p), out);
1780 } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
1781 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
1782 COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT);
1783 }
1784 } else {
1785 gen_units (SUB (p), out);
1786 }
1787 }
1788 }
1789
1790 //! @brief Compile units.
1791
1792 void gen_basics (NODE_T * p, FILE_T out)
1793 {
1794 for (; p != NO_NODE; FORWARD (p)) {
1795 if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) {
1796 if (gen_basic (p, out) == NO_TEXT) {
1797 gen_basics (SUB (p), out);
1798 } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) {
1799 COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));
1800 COMPILE_NAME (GINFO (p)) = new_string (COMPILE_NAME (GINFO (SUB (p))), NO_TEXT);
1801 }
1802 } else {
1803 gen_basics (SUB (p), out);
1804 }
1805 }
1806 }
