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