plugin.c
1 //! @file plugin.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 driver.
25
26 // The plugin compiler generates optimised C routines for many units in an Algol 68 source
27 // program. A68G 1.x contained some general optimised routines. These are
28 // decommissioned in A68G 2.x that dynamically generates routines depending
29 // on the source code. The generated routines are compiled on the fly into a
30 // dynamic library that is linked by the running interpreter, like a plugin.
31
32 // To invoke this code generator specify option --optimise.
33 // Currently the optimiser only considers units that operate on basic modes that are
34 // contained in a single C struct, for instance primitive modes
35 //
36 // INT, REAL, BOOL, CHAR and BITS
37 //
38 // and simple structures of these basic modes, such as
39 //
40 // COMPLEX
41 //
42 // and also (single) references, rows and procedures
43 //
44 // REF MODE, [] MODE, PROC PARAMSETY MODE
45 //
46 // The code generator employs a few simple optimisations like constant folding
47 // and common subexpression elimination when DEREFERENCING or SLICING is
48 // performed; for instance
49 //
50 // x[i + 1] := x[i + 1] + 1
51 //
52 // translates into
53 //
54 // tmp = x[i + 1]; tmp := tmp + 1
55 //
56 // We don't do stuff that is easily recognised by a back end compiler,
57 // for instance symbolic simplification.
58
59 #include "a68g.h"
60 #include "a68g-prelude.h"
61 #include "a68g-genie.h"
62 #include "a68g-listing.h"
63 #include "a68g-optimiser.h"
64 #include "a68g-plugin.h"
65 #include "a68g-transput.h"
66
67 //! @brief Compiler optimisation option string
68
69 char *optimisation_option (void)
70 {
71 switch (OPTION_OPT_LEVEL (&A68_JOB)) {
72 case OPTIMISE_0: {
73 return "-Og";
74 }
75 case OPTIMISE_1: {
76 return "-O1";
77 }
78 case OPTIMISE_2: {
79 return "-O2";
80 }
81 case OPTIMISE_3: {
82 return "-O3";
83 }
84 case OPTIMISE_FAST: {
85 return "-Ofast";
86 }
87 default: {
88 return "-Og";
89 }
90 }
91 }
92
93 //! @brief Emit code for the plugin-compiler.
94
95 void plugin_driver_emit (FILE_T out)
96 {
97 ADDR_T pop_temp_heap_pointer = A68 (temp_heap_pointer);
98 if (OPTION_OPT_LEVEL (&A68_JOB) == NO_OPTIMISE) {
99 return;
100 }
101 A68_OPT (indentation) = 0;
102 A68_OPT (code_errors) = 0;
103 A68_OPT (procedures) = 0;
104 A68_OPT (cse_pointer) = 0;
105 A68_OPT (unic_pointer) = 0;
106 A68_OPT (root_idf) = NO_DEC;
107 A68 (global_level) = INT_MAX;
108 A68_GLOBALS = 0;
109 get_global_level (SUB (TOP_NODE (&A68_JOB)));
110 A68 (max_lex_lvl) = 0;
111 genie_preprocess (TOP_NODE (&A68_JOB), &A68 (max_lex_lvl), NULL);
112 get_global_level (TOP_NODE (&A68_JOB));
113 A68_SP = A68 (stack_start);
114 A68 (expr_stack_limit) = A68 (stack_end) - A68 (storage_overhead);
115 if (OPTION_COMPILE_CHECK (&A68_JOB)) {
116 monadics = monadics_check;
117 dyadics = dyadics_check;
118 functions = functions_check;
119 } else {
120 monadics = monadics_nocheck;
121 dyadics = dyadics_nocheck;
122 functions = functions_nocheck;
123 }
124 if (OPTION_OPT_LEVEL (&A68_JOB) == OPTIMISE_0) {
125 // Allow basic optimisation only.
126 A68_OPT (OPTION_CODE_LEVEL) = 1;
127 write_prelude (out);
128 gen_basics (TOP_NODE (&A68_JOB), out);
129 } else {
130 // Allow all optimisations.
131 A68_OPT (OPTION_CODE_LEVEL) = 9;
132 write_prelude (out);
133 gen_units (TOP_NODE (&A68_JOB), out);
134 }
135 ABEND (A68_OPT (indentation) != 0, ERROR_INTERNAL_CONSISTENCY, __func__);
136 // At the end we discard temporary declarations.
137 A68 (temp_heap_pointer) = pop_temp_heap_pointer;
138 if (OPTION_VERBOSE (&A68_JOB)) {
139 ASSERT (snprintf (A68 (output_line), SNPRINTF_SIZE, "%s: A68_OPT (procedures)=%d unique-names=%d", A68 (a68_cmd_name), A68_OPT (procedures), A68_OPT (unic_pointer)) >= 0);
140 io_close_tty_line ();
141 WRITE (A68_STDOUT, A68 (output_line));
142 }
143 for (int k = 0; k < A68_OPT (unic_pointer); k++) {
144 a68_free (UNIC_NAME (k));
145 }
146 }
147
148 // Pretty printing stuff.
149
150 //! @brief Name formatting
151
152 char *moid_with_name (char *pre, MOID_T * m, char *post)
153 {
154 static char buf[NAME_SIZE];
155 char *mode = "MODE", *ref = NO_TEXT;
156 if (m != NO_MOID && IS (m, REF_SYMBOL)) {
157 ref = "REF";
158 m = SUB (m);
159 }
160 if (m == M_INT) {
161 mode = "INT";
162 } else if (m == M_REAL) {
163 mode = "REAL";
164 } else if (m == M_BOOL) {
165 mode = "BOOL";
166 } else if (m == M_CHAR) {
167 mode = "CHAR";
168 } else if (m == M_BITS) {
169 mode = "BITS";
170 } else if (m == M_VOID) {
171 mode = "VOID";
172 }
173 if (ref == NO_TEXT) {
174 snprintf (buf, NAME_SIZE, "%s%s%s", pre, mode, post);
175 } else {
176 snprintf (buf, NAME_SIZE, "%sREF_%s%s", pre, mode, post);
177 }
178 return buf;
179 }
180
181 //! @brief Write indented text.
182
183 void indent (FILE_T out, char *str)
184 {
185 int j = A68_OPT (indentation);
186 if (out == 0) {
187 return;
188 }
189 while (j-- > 0) {
190 WRITE (out, " ");
191 }
192 WRITE (out, str);
193 }
194
195 //! @brief Write unindented text.
196
197 void undent (FILE_T out, char *str)
198 {
199 if (out == 0) {
200 return;
201 }
202 WRITE (out, str);
203 }
204
205 //! @brief Write indent text.
206
207 void indentf (FILE_T out, int ret)
208 {
209 if (out == 0) {
210 return;
211 }
212 if (ret >= 0) {
213 indent (out, A68 (edit_line));
214 } else {
215 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, error_specification ());
216 }
217 }
218
219 //! @brief Write unindent text.
220
221 void undentf (FILE_T out, int ret)
222 {
223 if (out == 0) {
224 return;
225 }
226 if (ret >= 0) {
227 WRITE (out, A68 (edit_line));
228 } else {
229 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, error_specification ());
230 }
231 }
232
233 // Administration of C declarations .
234 // Pretty printing of C declarations.
235
236 //! @brief Add declaration to a tree.
237
238 DEC_T *add_identifier (DEC_T ** p, int level, char *idf)
239 {
240 char *z = new_temp_string (idf);
241 while (*p != NO_DEC) {
242 int k = strcmp (z, TEXT (*p));
243 if (k < 0) {
244 p = &LESS (*p);
245 } else if (k > 0) {
246 p = &MORE (*p);
247 } else {
248 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, z);
249 return *p;
250 }
251 }
252 *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (DEC_T));
253 TEXT (*p) = z;
254 LEVEL (*p) = level;
255 SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC;
256 return *p;
257 }
258
259 //! @brief Add declaration to a tree.
260
261 DEC_T *add_declaration (DEC_T ** p, char *mode, int level, char *idf)
262 {
263 char *z = new_temp_string (mode);
264 while (*p != NO_DEC) {
265 int k = strcmp (z, TEXT (*p));
266 if (k < 0) {
267 p = &LESS (*p);
268 } else if (k > 0) {
269 p = &MORE (*p);
270 } else {
271 (void) add_identifier (&SUB (*p), level, idf);
272 return *p;
273 }
274 }
275 *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (DEC_T));
276 TEXT (*p) = z;
277 LEVEL (*p) = -1;
278 SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC;
279 (void) add_identifier (&SUB (*p), level, idf);
280 return *p;
281 }
282
283 //! @brief Print identifiers (following mode).
284
285 void print_identifiers (FILE_T out, DEC_T * p)
286 {
287 if (p != NO_DEC) {
288 print_identifiers (out, LESS (p));
289 if (A68_OPT (put_idf_comma)) {
290 WRITE (out, ", ");
291 } else {
292 A68_OPT (put_idf_comma) = A68_TRUE;
293 }
294 if (LEVEL (p) > 0) {
295 int k = LEVEL (p);
296 while (k--) {
297 WRITE (out, "*");
298 }
299 WRITE (out, " ");
300 }
301 WRITE (out, TEXT (p));
302 print_identifiers (out, MORE (p));
303 }
304 }
305
306 //! @brief Print declarations.
307
308 void print_declarations (FILE_T out, DEC_T * p)
309 {
310 if (p != NO_DEC) {
311 print_declarations (out, LESS (p));
312 indent (out, TEXT (p));
313 WRITE (out, " ");
314 A68_OPT (put_idf_comma) = A68_FALSE;
315 print_identifiers (out, SUB (p));
316 WRITE (out, ";\n");
317 print_declarations (out, MORE (p));
318 }
319 }
320
321 // Administration for common functions.
322 // Otherwise we generate many routines that push 0 or 1 or TRUE etc.
323
324 //! @brief Make name.
325
326 char *make_unic_name (char *buf, char *name, char *tag, char *ext)
327 {
328 if (strlen (tag) > 0) {
329 ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s_%s", name, tag, ext) >= 0);
330 } else {
331 ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s", name, ext) >= 0);
332 }
333 ABEND (strlen (buf) >= NAME_SIZE, ERROR_ACTION, __func__);
334 return buf;
335 }
336
337 //! @brief Look up a name in the list.
338
339 char *signed_in_name (char *name)
340 {
341 for (int k = 0; k < A68_OPT (unic_pointer); k++) {
342 if (strcmp (UNIC_NAME (k), name) == 0) {
343 return UNIC_NAME (k);
344 }
345 }
346 return NO_TEXT;
347 }
348
349 //! @brief Enter new name in list, if there is space.
350
351 void sign_in_name (char *name, int *action)
352 {
353 if (signed_in_name (name)) {
354 *action = UNIC_EXISTS;
355 } else if (A68_OPT (unic_pointer) < MAX_UNIC) {
356 UNIC_NAME (A68_OPT (unic_pointer)) = new_string (name, NO_TEXT);
357 A68_OPT (unic_pointer)++;
358 *action = UNIC_MAKE_NEW;
359 } else {
360 *action = UNIC_MAKE_ALT;
361 }
362 }
363
364 //! @brief Book identifier to keep track of it for CSE.
365
366 void sign_in (int action, int phase, char *idf, void *info, int number)
367 {
368 if (A68_OPT (cse_pointer) < MAX_BOOK) {
369 ACTION (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = action;
370 PHASE (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = phase;
371 IDF (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = idf;
372 INFO (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = info;
373 NUMBER (&A68_OPT (cse_book)[A68_OPT (cse_pointer)]) = number;
374 A68_OPT (cse_pointer)++;
375 }
376 }
377
378 //! @brief Whether identifier is signed_in.
379
380 BOOK_T *signed_in (int action, int phase, char *idf)
381 {
382 for (int k = 0; k < A68_OPT (cse_pointer); k++) {
383 if (IDF (&A68_OPT (cse_book)[k]) == idf && ACTION (&A68_OPT (cse_book)[k]) == action && PHASE (&A68_OPT (cse_book)[k]) >= phase) {
384 return &(A68_OPT (cse_book)[k]);
385 }
386 }
387 return NO_BOOK;
388 }
389
390 //! @brief Make name.
391
392 char *make_name (char *buf, char *name, char *tag, int n)
393 {
394 if (strlen (tag) > 0) {
395 ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%s_%d", name, tag, n) >= 0);
396 } else {
397 ASSERT (snprintf (buf, NAME_SIZE, "genie_%s_%d", name, n) >= 0);
398 }
399 ABEND (strlen (buf) >= NAME_SIZE, ERROR_ACTION, __func__);
400 return buf;
401 }
402
403 //! @brief Whether two sub-trees are the same Algol 68 construct.
404
405 BOOL_T same_tree (NODE_T * l, NODE_T * r)
406 {
407 if (l == NO_NODE) {
408 return (BOOL_T) (r == NO_NODE);
409 } else if (r == NO_NODE) {
410 return (BOOL_T) (l == NO_NODE);
411 } else if (ATTRIBUTE (l) == ATTRIBUTE (r) && NSYMBOL (l) == NSYMBOL (r)) {
412 return (BOOL_T) (same_tree (SUB (l), SUB (r)) && same_tree (NEXT (l), NEXT (r)));
413 } else {
414 return A68_FALSE;
415 }
416 }
417
418 // Basic mode check.
419
420 //! @brief Whether stems from certain attribute.
421
422 NODE_T *stems_from (NODE_T * p, int att)
423 {
424 if (IS (p, VOIDING)) {
425 return stems_from (SUB (p), att);
426 } else if (IS (p, UNIT)) {
427 return stems_from (SUB (p), att);
428 } else if (IS (p, TERTIARY)) {
429 return stems_from (SUB (p), att);
430 } else if (IS (p, SECONDARY)) {
431 return stems_from (SUB (p), att);
432 } else if (IS (p, PRIMARY)) {
433 return stems_from (SUB (p), att);
434 } else if (IS (p, att)) {
435 return p;
436 } else {
437 return NO_NODE;
438 }
439 }
440
441 // Auxilliary routines for emitting C code.
442
443 //! @brief Whether frame needs initialisation.
444
445 BOOL_T need_initialise_frame (NODE_T * p)
446 {
447 for (TAG_T *tag = ANONYMOUS (TABLE (p)); tag != NO_TAG; FORWARD (tag)) {
448 if (PRIO (tag) == ROUTINE_TEXT) {
449 return A68_TRUE;
450 } else if (PRIO (tag) == FORMAT_TEXT) {
451 return A68_TRUE;
452 }
453 }
454 int count = 0;
455 genie_find_proc_op (p, &count);
456 if (count > 0) {
457 return A68_TRUE;
458 } else {
459 return A68_FALSE;
460 }
461 }
462
463 //! @brief Comment source line.
464
465 void comment_tree (NODE_T * p, FILE_T out, int *want_space, int *max_print)
466 {
467 // Take care not to generate nested comments.
468 #define UNDENT(out, p) {\
469 for (char *q = p; q[0] != NULL_CHAR; q ++) {\
470 if (q[0] == '*' && q[1] == '/') {\
471 undent (out, "\\*\\/");\
472 q ++;\
473 } else if (q[0] == '/' && q[1] == '*') {\
474 undent (out, "\\/\\*");\
475 q ++;\
476 } else {\
477 char w[2];\
478 w[0] = q[0];\
479 w[1] = NULL_CHAR;\
480 undent (out, w);\
481 }\
482 }}
483
484 for (; p != NO_NODE && (*max_print) >= 0; FORWARD (p)) {
485 if (IS (p, ROW_CHAR_DENOTATION)) {
486 if (*want_space != 0) {
487 UNDENT (out, " ");
488 }
489 UNDENT (out, "\"");
490 UNDENT (out, NSYMBOL (p));
491 UNDENT (out, "\"");
492 *want_space = 2;
493 } else if (SUB (p) != NO_NODE) {
494 comment_tree (SUB (p), out, want_space, max_print);
495 } else if (NSYMBOL (p)[0] == '(' || NSYMBOL (p)[0] == '[' || NSYMBOL (p)[0] == '{') {
496 if (*want_space == 2) {
497 UNDENT (out, " ");
498 }
499 UNDENT (out, NSYMBOL (p));
500 *want_space = 0;
501 } else if (NSYMBOL (p)[0] == ')' || NSYMBOL (p)[0] == ']' || NSYMBOL (p)[0] == '}') {
502 UNDENT (out, NSYMBOL (p));
503 *want_space = 1;
504 } else if (NSYMBOL (p)[0] == ';' || NSYMBOL (p)[0] == ',') {
505 UNDENT (out, NSYMBOL (p));
506 *want_space = 2;
507 } else if (strlen (NSYMBOL (p)) == 1 && (NSYMBOL (p)[0] == '.' || NSYMBOL (p)[0] == ':')) {
508 UNDENT (out, NSYMBOL (p));
509 *want_space = 2;
510 } else {
511 if (*want_space != 0) {
512 UNDENT (out, " ");
513 }
514 if ((*max_print) > 0) {
515 UNDENT (out, NSYMBOL (p));
516 } else if ((*max_print) == 0) {
517 if (*want_space == 0) {
518 UNDENT (out, " ");
519 }
520 UNDENT (out, "...");
521 }
522 (*max_print)--;
523 if (IS_UPPER (NSYMBOL (p)[0])) {
524 *want_space = 2;
525 } else if (!IS_ALNUM (NSYMBOL (p)[0])) {
526 *want_space = 2;
527 } else {
528 *want_space = 1;
529 }
530 }
531 }
532 #undef UNDENT
533 }
534
535 //! @brief Comment source line.
536
537 void comment_source (NODE_T * p, FILE_T out)
538 {
539 int want_space = 0, max_print = 16, ld = -1;
540 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\n// %s: %d: ", FILENAME (LINE (INFO (p))), LINE_NUMBER (p)));
541 comment_tree (p, out, &want_space, &max_print);
542 tree_listing (out, p, 1, LINE (INFO (p)), &ld, A68_TRUE);
543 undent (out, "\n");
544 }
545
546 //! @brief Inline comment source line.
547
548 void inline_comment_source (NODE_T * p, FILE_T out)
549 {
550 int want_space = 0, max_print = 8;
551 undent (out, " // ");
552 comment_tree (p, out, &want_space, &max_print);
553 // undent (out, " */");
554 }
555
556 //! @brief Write prelude.
557
558 void write_prelude (FILE_T out)
559 {
560 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// \"%s\" %s\n", FILE_OBJECT_NAME (&A68_JOB), PACKAGE_STRING));
561 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// optimiser_level=%d code_level=%d\n", OPTION_OPT_LEVEL (&A68_JOB), A68_OPT (OPTION_CODE_LEVEL)));
562 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "// %s %s\n", __DATE__, __TIME__));
563 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\n#include <%s/a68g-config.h>\n", PACKAGE));
564 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g.h>\n", PACKAGE));
565 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-genie.h>\n", PACKAGE));
566 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-prelude.h>\n", PACKAGE));
567 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-environ.h>\n", PACKAGE));
568 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-lib.h>\n", PACKAGE));
569 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-optimiser.h>\n", PACKAGE));
570 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "#include <%s/a68g-frames.h>\n", PACKAGE));
571 indent (out, "\n#define _NODE_(n) (A68 (node_register)[n])\n");
572 indent (out, "#define _STATUS_(z) (STATUS (z))\n");
573 indent (out, "#define _VALUE_(z) (VALUE (z))\n");
574 }
575
576 //! @brief Write initialisation of frame.
577
578 void init_static_frame (FILE_T out, NODE_T * p)
579 {
580 if (AP_INCREMENT (TABLE (p)) > 0) {
581 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "FRAME_CLEAR (" A68_LU ");\n", AP_INCREMENT (TABLE (p))));
582 }
583 if (LEX_LEVEL (p) == A68 (global_level)) {
584 indent (out, "A68_GLOBALS = A68_FP;\n");
585 }
586 if (need_initialise_frame (p)) {
587 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "initialise_frame (_NODE_ (%d));\n", NUMBER (p)));
588 }
589 }
590
591 // COMPILATION OF PARTIAL UNITS.
592
593 void gen_check_init (NODE_T * p, FILE_T out, char *idf)
594 {
595 if (OPTION_COMPILE_CHECK (&A68_JOB) && folder_mode (MOID (p))) {
596 if (MOID (p) == M_COMPLEX) {
597 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "if (!(INITIALISED (&(*%s)[0]) && INITIALISED (&(*%s)[1]))) {\n", idf, idf));
598 A68_OPT (indentation)++;
599 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE_FROM, M_COMPLEX);\n"));
600 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "exit_genie ((p), A68_RUNTIME_ERROR);\n"));
601 A68_OPT (indentation)--;
602 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "}\n"));
603 } else {
604 char *M = "M_ERROR";
605 if (MOID (p) == M_INT) {
606 M = "M_INT";
607 } else if (MOID (p) == M_REAL) {
608 M = "M_REAL";
609 } else if (MOID (p) == M_BOOL) {
610 M = "M_BOOL";
611 } else if (MOID (p) == M_CHAR) {
612 M = "M_CHAR";
613 }
614 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "if (!INITIALISED(%s)) {\n", idf));
615 A68_OPT (indentation)++;
616 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "diagnostic (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE_FROM, %s);\n", M));
617 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "exit_genie ((p), A68_RUNTIME_ERROR);\n"));
618 A68_OPT (indentation)--;
619 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "}\n"));
620 }
621 }
622 }
623
624 //! @brief Code getting objects from the stack.
625
626 void get_stack (NODE_T * p, FILE_T out, char *dst, char *cast)
627 {
628 if (A68_OPT (OPTION_CODE_LEVEL) >= 4) {
629 if (LEVEL (GINFO (p)) == A68 (global_level)) {
630 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_GLOBAL (%s, %s, " A68_LU ");\n", dst, cast, OFFSET (TAX (p))));
631 } else {
632 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, " A68_LU ");\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p))));
633 }
634 } else {
635 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, " A68_LU ");\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p))));
636 }
637 }
638
639 //! @brief Code function prelude.
640
641 void write_fun_prelude (NODE_T * p, FILE_T out, char *fn)
642 {
643 (void) p;
644 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "\nPROP_T %s (NODE_T *p) {\n", fn));
645 A68_OPT (indentation)++;
646 indent (out, "PROP_T self;\n");
647 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "UNIT (&self) = %s;\n", fn));
648 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "SOURCE (&self) = _NODE_ (%d);\n", NUMBER (p)));
649 A68_OPT (cse_pointer) = 0;
650 }
651
652 //! @brief Code function postlude.
653
654 void write_fun_postlude (NODE_T * p, FILE_T out, char *fn)
655 {
656 (void) fn;
657 (void) p;
658 indent (out, "return (self);\n");
659 A68_OPT (indentation)--;
660 A68_OPT (procedures)++;
661 indent (out, "}\n");
662 A68_OPT (cse_pointer) = 0;
663 }
664
665 //! @brief Code internal a68g mode.
666
667 char *internal_mode (MOID_T * m)
668 {
669 if (m == M_INT) {
670 return "M_INT";
671 } else if (m == M_REAL) {
672 return "M_REAL";
673 } else if (m == M_BOOL) {
674 return "M_BOOL";
675 } else if (m == M_CHAR) {
676 return "M_CHAR";
677 } else if (m == M_BITS) {
678 return "M_BITS";
679 } else {
680 return "M_ERROR";
681 }
682 }
683
684 //! @brief Compile denotation.
685
686 char *compile_denotation (NODE_T * p, FILE_T out)
687 {
688 if (primitive_mode (MOID (p))) {
689 static char fn[NAME_SIZE], N[NAME_SIZE];
690 int action = UNIC_MAKE_ALT;
691 comment_source (p, out);
692 fn[0] = '\0';
693 if (MOID (p) == M_INT) {
694 char *end;
695 UNSIGNED_T z = (UNSIGNED_T) a68_strtoi (NSYMBOL (p), &end, 10);
696 ASSERT (snprintf (N, NAME_SIZE, A68_LX "_", z) >= 0);
697 (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", N);
698 } else if (MOID (p) == M_REAL) {
699 A68_SP = 0;
700 PUSH_UNION (p, M_REAL);
701 push_unit (p);
702 INCREMENT_STACK_POINTER (p, SIZE (M_NUMBER) - (A68_UNION_SIZE + SIZE (M_REAL)));
703 PUSH_VALUE (p, A68_REAL_WIDTH + A68_EXP_WIDTH + 5, A68_INT);
704 PUSH_VALUE (p, A68_REAL_WIDTH, A68_INT);
705 PUSH_VALUE (p, A68_EXP_WIDTH + 1, A68_INT);
706 PUSH_VALUE (p, 3, A68_INT);
707 char *V = real (p);
708 char W[NAME_SIZE];
709 for (int k = 0; V[0] != '\0'; V++) {
710 if (IS_ALNUM (V[0])) {
711 W[k++] = TO_LOWER (V[0]);
712 W[k] = '\0';
713 }
714 if (V[0] == '.' || V[0] == '-') {
715 W[k++] = '_';
716 W[k] = '\0';
717 }
718 }
719 (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", W);
720 } else if (MOID (p) == M_BOOL) {
721 (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", NSYMBOL (SUB (p)));
722 } else if (MOID (p) == M_CHAR) {
723 ASSERT (snprintf (N, NAME_SIZE, "%02x_", NSYMBOL (SUB (p))[0]) >= 0);
724 (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_denotation"), "", N);
725 }
726 if (fn[0] != '\0') {
727 sign_in_name (fn, &action);
728 if (action == UNIC_EXISTS) {
729 return fn;
730 }
731 }
732 if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) {
733 if (action == UNIC_MAKE_ALT) {
734 (void) make_name (fn, moid_with_name ("", MOID (p), "_denotation_alt"), "", NUMBER (p));
735 }
736 write_fun_prelude (p, out, fn);
737 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "PUSH_VALUE (p, "));
738 inline_unit (p, out, L_YIELD);
739 undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p))));
740 write_fun_postlude (p, out, fn);
741 }
742 return fn;
743 } else {
744 return NO_TEXT;
745 }
746 }
747
748 char *compile_cast (NODE_T * p, FILE_T out)
749 {
750 if (folder_mode (MOID (p)) && basic_unit (p)) {
751 static char fn[NAME_SIZE];
752 comment_source (p, out);
753 (void) make_name (fn, moid_with_name ("", MOID (p), "_cast"), "", NUMBER (p));
754 A68_OPT (root_idf) = NO_DEC;
755 inline_unit (NEXT_SUB (p), out, L_DECLARE);
756 print_declarations (out, A68_OPT (root_idf));
757 inline_unit (NEXT_SUB (p), out, L_EXECUTE);
758 gen_push (NEXT_SUB (p), out);
759 return fn;
760 } else {
761 return NO_TEXT;
762 }
763 }
764
765 //! @brief Compile identifier.
766
767 char *compile_identifier (NODE_T * p, FILE_T out)
768 {
769 if (folder_mode (MOID (p))) {
770 static char fn[NAME_SIZE];
771 int action = UNIC_MAKE_ALT;
772 char N[NAME_SIZE];
773 // Some identifiers in standenv cannot be pushed.
774 // Examples are cputime, or clock that are procedures in disguise.
775 if (A68_STANDENV_PROC (TAX (p))) {
776 BOOL_T ok = A68_FALSE;
777 for (int k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
778 if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
779 ok = A68_TRUE;
780 }
781 }
782 if (!ok) {
783 return NO_TEXT;
784 }
785 }
786 // Push the identifier.
787 ASSERT (snprintf (N, NAME_SIZE, "%d_%d_" A68_LU, NUM (TABLE (TAX (p))), LEVEL (GINFO (p)), OFFSET (TAX (p))) >= 0);
788 comment_source (p, out);
789 fn[0] = '\0';
790 (void) make_unic_name (fn, moid_with_name ("", MOID (p), "_identifier"), "", N);
791 sign_in_name (fn, &action);
792 if (action == UNIC_EXISTS) {
793 return fn;
794 }
795 if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) {
796 if (action == UNIC_MAKE_ALT) {
797 (void) make_name (fn, moid_with_name ("", MOID (p), "_identifier_alt"), "", NUMBER (p));
798 }
799 write_fun_prelude (p, out, fn);
800 A68_OPT (root_idf) = NO_DEC;
801 inline_unit (p, out, L_DECLARE);
802 print_declarations (out, A68_OPT (root_idf));
803 inline_unit (p, out, L_EXECUTE);
804 gen_push (p, out);
805 write_fun_postlude (p, out, fn);
806 }
807 return fn;
808 } else {
809 return NO_TEXT;
810 }
811 }
812
813 //! @brief Compile dereference identifier.
814
815 char *compile_dereference_identifier (NODE_T * p, FILE_T out)
816 {
817 if (folder_mode (MOID (p))) {
818 static char fn[NAME_SIZE];
819 int action = UNIC_MAKE_ALT;
820 char N[NAME_SIZE];
821 NODE_T *q = SUB (p);
822 ASSERT (snprintf (N, NAME_SIZE, "%d_%d_" A68_LU, NUM (TABLE (TAX (q))), LEVEL (GINFO (q)), OFFSET (TAX (q))) >= 0);
823 comment_source (p, out);
824 fn[0] = '\0';
825 (void) make_unic_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier"), "", N);
826 sign_in_name (fn, &action);
827 if (action == UNIC_EXISTS) {
828 return fn;
829 }
830 if (action == UNIC_MAKE_NEW || action == UNIC_MAKE_ALT) {
831 if (action == UNIC_MAKE_ALT) {
832 (void) make_name (fn, moid_with_name ("deref_REF_", MOID (p), "_identifier_alt"), "", NUMBER (p));
833 }
834 write_fun_prelude (p, out, fn);
835 A68_OPT (root_idf) = NO_DEC;
836 inline_unit (p, out, L_DECLARE);
837 print_declarations (out, A68_OPT (root_idf));
838 inline_unit (p, out, L_EXECUTE);
839 gen_push (p, out);
840 write_fun_postlude (p, out, fn);
841 }
842 return fn;
843 } else {
844 return NO_TEXT;
845 }
846 }
847
848 //! @brief Compile formula.
849
850 char *compile_formula (NODE_T * p, FILE_T out)
851 {
852 if (folder_mode (MOID (p)) && basic_unit (p)) {
853 static char fn[NAME_SIZE];
854 comment_source (p, out);
855 (void) make_name (fn, moid_with_name ("", MOID (p), "_formula"), "", NUMBER (p));
856 write_fun_prelude (p, out, fn);
857 if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
858 if (MOID (p) == M_REAL || MOID (p) == M_COMPLEX) {
859 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_REAL * _st_ = (A68_REAL *) STACK_TOP;\n"));
860 }
861 }
862 A68_OPT (root_idf) = NO_DEC;
863 inline_unit (p, out, L_DECLARE);
864 print_declarations (out, A68_OPT (root_idf));
865 if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
866 if (folder_mode (MOID (p))) {
867 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "errno = 0;\n"));
868 }
869 }
870 inline_unit (p, out, L_EXECUTE);
871 gen_push (p, out);
872 if (OPTION_COMPILE_CHECK (&A68_JOB) && !constant_unit (p)) {
873 if (MOID (p) == M_INT) {
874 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_INT, NO_TEXT);\n"));
875 }
876 if (MOID (p) == M_REAL) {
877 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_REAL, NO_TEXT);\n"));
878 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (_st_));\n"));
879 }
880 if (MOID (p) == M_BITS) {
881 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_BITS, NO_TEXT);\n"));
882 }
883 if (MOID (p) == M_COMPLEX) {
884 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "MATH_RTE (p, errno != 0, M_COMPLEX, NO_TEXT);\n"));
885 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (&(_st_[0])));\n"));
886 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "CHECK_REAL (p, _VALUE_ (&(_st_[1])));\n"));
887 }
888 }
889 write_fun_postlude (p, out, fn);
890 return fn;
891 } else {
892 return NO_TEXT;
893 }
894 }
895
896 //! @brief Compile call.
897
898 char *compile_call (NODE_T * p, FILE_T out)
899 {
900 NODE_T *proc = SUB (p);
901 NODE_T *args = NEXT (proc);
902 NODE_T *idf = stems_from (proc, IDENTIFIER);
903 if (idf == NO_NODE) {
904 return NO_TEXT;
905 } else if (!(SUB_MOID (proc) == M_VOID || basic_mode (SUB_MOID (proc)))) {
906 return NO_TEXT;
907 } else if (DIM (MOID (proc)) == 0) {
908 return NO_TEXT;
909 } else if (A68_STANDENV_PROC (TAX (idf))) {
910 if (basic_call (p)) {
911 static char fun[NAME_SIZE];
912 comment_source (p, out);
913 (void) make_name (fun, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p));
914 write_fun_prelude (p, out, fun);
915 A68_OPT (root_idf) = NO_DEC;
916 inline_unit (p, out, L_DECLARE);
917 print_declarations (out, A68_OPT (root_idf));
918 inline_unit (p, out, L_EXECUTE);
919 gen_push (p, out);
920 write_fun_postlude (p, out, fun);
921 return fun;
922 } else {
923 return NO_TEXT;
924 }
925 } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) {
926 return NO_TEXT;
927 } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) {
928 return NO_TEXT;
929 } else if (!basic_argument (args)) {
930 return NO_TEXT;
931 } else {
932 static char fn[NAME_SIZE];
933 char fun[NAME_SIZE], pop[NAME_SIZE];
934 int size;
935 // Declare.
936 (void) make_name (fun, FUN, "", NUMBER (proc));
937 (void) make_name (pop, PUP, "", NUMBER (p));
938 comment_source (p, out);
939 (void) make_name (fn, moid_with_name ("", SUB_MOID (proc), "_call"), "", NUMBER (p));
940 write_fun_prelude (p, out, fn);
941 // Compute arguments.
942 size = 0;
943 A68_OPT (root_idf) = NO_DEC;
944 inline_arguments (args, out, L_DECLARE, &size);
945 (void) add_declaration (&A68_OPT (root_idf), "ADDR_T", 0, pop);
946 (void) add_declaration (&A68_OPT (root_idf), "A68_PROCEDURE", 1, fun);
947 (void) add_declaration (&A68_OPT (root_idf), "NODE_T", 1, "body");
948 print_declarations (out, A68_OPT (root_idf));
949 // Initialise.
950 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s = A68_SP;\n", pop));
951 inline_arguments (args, out, L_INITIALISE, &size);
952 get_stack (idf, out, fun, "A68_PROCEDURE");
953 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun));
954 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun));
955 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n"));
956 size = 0;
957 inline_arguments (args, out, L_EXECUTE, &size);
958 size = 0;
959 inline_arguments (args, out, L_YIELD, &size);
960 // Execute procedure.
961 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_SP = %s;\n", pop));
962 indent (out, "GENIE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n");
963 indent (out, "if (A68_FP == A68_MON (finish_frame_pointer)) {\n");
964 A68_OPT (indentation)++;
965 indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "change_masks (TOP_NODE (&A68_JOB), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n"));
966 A68_OPT (indentation)--;
967 indent (out, "}\n");
968 indent (out, "CLOSE_FRAME;\n");
969 write_fun_postlude (p, out, fn);
970 return fn;
971 }
972 }
973
