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