parser.c
1 //! @file parser.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-2025 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 //! Mailloux-type Algol 68 parser driver.
25
26 // The Algol 68 grammar is a two level (Van Wijngaarden, "VW") grammar
27 // that incorporates, as syntactical rules, the semantical rules in
28 // other languages. Examples are correct use of symbols, modes and scope.
29 //
30 // This code constitutes an effective "VW Algol 68 parser". A pragmatic
31 // approach was chosen since in the early days of Algol 68, many "ab initio"
32 // implementations failed, probably because techniques to parse a language
33 // like Algol 68 had yet to be invented.
34 //
35 // This is a Mailloux-type parser, in the sense that it scans a "phrase" for
36 // definitions needed for parsing. Algol 68 allows for tags to be used
37 // before they are defined, which gives freedom in top-down programming.
38 //
39 // B. J. Mailloux. On the implementation of Algol 68.
40 // Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968].
41 //
42 // Technically, Mailloux's approach renders the two-level grammar LALR.
43 //
44 // First part of the parser is the scanner. The source file is read,
45 // is tokenised, and if needed a refinement preprocessor elaborates a stepwise
46 // refined program. The result is a linear list of tokens that is input for the
47 // parser, that will transform the linear list into a syntax tree.
48 //
49 // Algol68G tokenises all symbols before the bottom-up parser is invoked.
50 // This means that scanning does not use information from the parser.
51 // The scanner does of course some rudimentary parsing. Format texts can have
52 // enclosed clauses in them, so we record information in a stack as to know
53 // what is being scanned. Also, the refinement preprocessor implements a
54 // (trivial) grammar.
55 //
56 // The scanner supports two stropping regimes: "bold" (or "upper") and "quote".
57 // Examples of both:
58 //
59 // bold stropping: BEGIN INT i = 1, j = 1; print (i + j) END
60 //
61 // quote stropping: 'BEGIN' 'INT' I = 1, J = 1; PRINT (I + J) 'END'
62 //
63 // Quote stropping was used frequently in the (excusez-le-mot) punch-card age.
64 // Hence, bold stropping is the default. There also existed point stropping,
65 // but that has not been implemented here.
66 //
67 // Next part of the parser is a recursive-descent type to check parenthesis.
68 // Also a first set-up is made of symbol tables, needed by the bottom-up parser.
69 // Next part is the bottom-up parser, that parses without knowing modes while
70 // parsing and reducing. It can therefore not exchange "[]" with "()" as was
71 // blessed by the Revised Report. This is solved by treating CALL and SLICE as
72 // equivalent for the moment and letting the mode checker sort it out later.
73 //
74 // Parsing progresses in various phases to avoid spurious diagnostics from a
75 // recovering parser. Every phase "tightens" the grammar more.
76 // An error in any phase makes the parser quit when that phase ends.
77 // The parser is forgiving in case of superfluous semicolons.
78 //
79 // These are the parser phases:
80 //
81 // (1) Parenthesis are checked to see whether they match. Then, a top-down
82 // parser determines the basic-block structure of the program
83 // so symbol tables can be set up that the bottom-up parser will consult
84 // as you can define things before they are applied.
85 //
86 // (2) A bottom-up parser resolves the structure of the program.
87 //
88 // (3) After the symbol tables have been finalised, a small rearrangement of the
89 // tree may be required where JUMPs have no GOTO. This leads to the
90 // non-standard situation that JUMPs without GOTO can have the syntactic
91 // position of a PRIMARY, SECONDARY or TERTIARY. The bottom-up parser also
92 // does not check VICTAL correctness of declarers. This is done separately.
93 // Also structure of format texts is checked separately.
94 //
95 // The parser sets up symbol tables and populates them as far as needed to parse
96 // the source. After the bottom-up parser terminates succesfully, the symbol tables
97 // are completed.
98 //
99 // (4) Next, modes are collected and rules for well-formedness and structural
100 // equivalence are applied. Then the symbol-table is completed now moids are
101 // all known.
102 //
103 // (5) Next phases are the mode checker and coercion inserter. The syntax tree is
104 // traversed to determine and check all modes, and to select operators. Then
105 // the tree is traversed again to insert coercions.
106 //
107 // (6) A static scope checker detects where objects are transported out of scope.
108 // At run time, a dynamic scope checker will check that what the static scope
109 // checker cannot see.
110
111 #include "a68g.h"
112 #include "a68g-parser.h"
113 #include "a68g-mp.h"
114 #include "a68g-postulates.h"
115 #include "a68g-prelude.h"
116
117 //! @brief First initialisations.
118
119 void init_before_tokeniser (void)
120 {
121 // Heap management set-up.
122 errno = 0;
123 init_heap ();
124 A68 (top_keyword) = NO_KEYWORD;
125 A68 (top_token) = NO_TOKEN;
126 TOP_NODE (&A68_JOB) = NO_NODE;
127 TOP_MOID (&A68_JOB) = NO_MOID;
128 TOP_LINE (&A68_JOB) = NO_LINE;
129 STANDENV_MOID (&A68_JOB) = NO_MOID;
130 set_up_tables ();
131 // Various initialisations.
132 ERROR_COUNT (&A68_JOB) = WARNING_COUNT (&A68_JOB) = 0;
133 ABEND (errno != 0, ERROR_ALLOCATION, __func__);
134 errno = 0;
135 }
136
137 void init_parser (void)
138 {
139 A68_PARSER (stop_scanner) = A68_FALSE;
140 A68_PARSER (read_error) = A68_FALSE;
141 A68_PARSER (no_preprocessing) = A68_FALSE;
142 }
143
144 //! @brief Is_ref_refety_flex.
145
146 BOOL_T is_ref_refety_flex (MOID_T * m)
147 {
148 if (IS_REF_FLEX (m)) {
149 return A68_TRUE;
150 } else if (IS_REF (m)) {
151 return is_ref_refety_flex (SUB (m));
152 } else {
153 return A68_FALSE;
154 }
155 }
156
157 //! @brief Count number of operands in operator parameter list.
158
159 int count_operands (NODE_T * p)
160 {
161 if (p != NO_NODE) {
162 if (IS (p, DECLARER)) {
163 return count_operands (NEXT (p));
164 } else if (IS (p, COMMA_SYMBOL)) {
165 return 1 + count_operands (NEXT (p));
166 } else {
167 return count_operands (NEXT (p)) + count_operands (SUB (p));
168 }
169 } else {
170 return 0;
171 }
172 }
173
174 //! @brief Count formal bounds in declarer in tree.
175
176 int count_formal_bounds (NODE_T * p)
177 {
178 if (p == NO_NODE) {
179 return 0;
180 } else {
181 if (IS (p, COMMA_SYMBOL)) {
182 return 1;
183 } else {
184 return count_formal_bounds (NEXT (p)) + count_formal_bounds (SUB (p));
185 }
186 }
187 }
188
189 //! @brief Count pictures.
190
191 void count_pictures (NODE_T * p, int *k)
192 {
193 for (; p != NO_NODE; FORWARD (p)) {
194 if (IS (p, PICTURE)) {
195 (*k)++;
196 }
197 count_pictures (SUB (p), k);
198 }
199 }
200
201 //! @brief Whether token cannot follow semicolon or EXIT.
202
203 BOOL_T is_semicolon_less (NODE_T * p)
204 {
205 switch (ATTRIBUTE (p)) {
206 case BUS_SYMBOL:
207 case CLOSE_SYMBOL:
208 case END_SYMBOL:
209 case SEMI_SYMBOL:
210 case EXIT_SYMBOL:
211 case THEN_BAR_SYMBOL:
212 case ELSE_BAR_SYMBOL:
213 case THEN_SYMBOL:
214 case ELIF_SYMBOL:
215 case ELSE_SYMBOL:
216 case FI_SYMBOL:
217 case IN_SYMBOL:
218 case OUT_SYMBOL:
219 case OUSE_SYMBOL:
220 case ESAC_SYMBOL:
221 case EDOC_SYMBOL:
222 case OCCA_SYMBOL:
223 case OD_SYMBOL:
224 case UNTIL_SYMBOL: {
225 return A68_TRUE;
226 }
227 default: {
228 return A68_FALSE;
229 }
230 }
231 }
232
233 //! @brief Whether formal bounds.
234
235 BOOL_T is_formal_bounds (NODE_T * p)
236 {
237 if (p == NO_NODE) {
238 return A68_TRUE;
239 } else {
240 switch (ATTRIBUTE (p)) {
241 case OPEN_SYMBOL:
242 case CLOSE_SYMBOL:
243 case SUB_SYMBOL:
244 case BUS_SYMBOL:
245 case COMMA_SYMBOL:
246 case COLON_SYMBOL:
247 case DOTDOT_SYMBOL:
248 case INT_DENOTATION:
249 case IDENTIFIER:
250 case OPERATOR: {
251 return (BOOL_T) (is_formal_bounds (SUB (p)) && is_formal_bounds (NEXT (p)));
252 }
253 default: {
254 return A68_FALSE;
255 }
256 }
257 }
258 }
259
260 //! @brief Whether token terminates a unit.
261
262 BOOL_T is_unit_terminator (NODE_T * p)
263 {
264 switch (ATTRIBUTE (p)) {
265 case BUS_SYMBOL:
266 case CLOSE_SYMBOL:
267 case END_SYMBOL:
268 case SEMI_SYMBOL:
269 case EXIT_SYMBOL:
270 case COMMA_SYMBOL:
271 case THEN_BAR_SYMBOL:
272 case ELSE_BAR_SYMBOL:
273 case THEN_SYMBOL:
274 case ELIF_SYMBOL:
275 case ELSE_SYMBOL:
276 case FI_SYMBOL:
277 case IN_SYMBOL:
278 case OUT_SYMBOL:
279 case OUSE_SYMBOL:
280 case ESAC_SYMBOL:
281 case EDOC_SYMBOL:
282 case OCCA_SYMBOL: {
283 return A68_TRUE;
284 }
285 }
286 return A68_FALSE;
287 }
288
289 //! @brief Whether token is a unit-terminator in a loop clause.
290
291 BOOL_T is_loop_keyword (NODE_T * p)
292 {
293 switch (ATTRIBUTE (p)) {
294 case FOR_SYMBOL:
295 case FROM_SYMBOL:
296 case BY_SYMBOL:
297 case TO_SYMBOL:
298 case DOWNTO_SYMBOL:
299 case WHILE_SYMBOL:
300 case DO_SYMBOL: {
301 return A68_TRUE;
302 }
303 }
304 return A68_FALSE;
305 }
306
307 //! @brief Get good attribute.
308
309 int get_good_attribute (NODE_T * p)
310 {
311 switch (ATTRIBUTE (p)) {
312 case UNIT:
313 case TERTIARY:
314 case SECONDARY:
315 case PRIMARY:
316 case ENCLOSED_CLAUSE: {
317 return get_good_attribute (SUB (p));
318 }
319 case DECLARER: {
320 if (IS (SUB (p), INDICANT)) {
321 return ATTRIBUTE (SUB_SUB (p));
322 } else {
323 return DECLARER;
324 }
325 }
326 case DECLARATION_LIST: {
327 if (SUB (p) != NO_NODE) {
328 return ATTRIBUTE (SUB (p));
329 } else {
330 return ATTRIBUTE (p);
331 }
332 }
333 default: {
334 return ATTRIBUTE (p);
335 }
336 }
337 }
338
339 //! @brief Intelligible diagnostic from syntax tree branch.
340
341 char *phrase_to_text (NODE_T * p, NODE_T ** w)
342 {
343 #define MAX_TERMINALS 10
344 int count = 0;
345 BOOL_T put_space = A68_FALSE;
346 static BUFFER buffer;
347 buffer[0] = NULL_CHAR;
348 while (p != NO_NODE && count < MAX_TERMINALS) {
349 if (LINE_NUMBER (p) > 0) {
350 int gatt = get_good_attribute (p);
351 char *z = non_terminal_string (A68 (input_line), gatt);
352 // Where to put the error message?
353 // The actual content of a diagnostic is not as important
354 // as accurately indicating *were* the problem is!
355 if (w != NO_REF) {
356 if (count == 0 || (*w) == NO_NODE) {
357 *w = p;
358 } else if (dont_mark_here (*w)) {
359 *w = p;
360 }
361 }
362 switch (gatt) {
363 case SEMI_SYMBOL:
364 case COMMA_SYMBOL:
365 case CLOSE_SYMBOL:
366 case BUS_SYMBOL: {
367 // Next symbol may have leading space.
368 put_space = A68_TRUE;
369 break;
370 }
371 case OPEN_SYMBOL:
372 case SUB_SYMBOL: {
373 if (put_space) {
374 a68g_bufcat (buffer, " ", BUFFER_SIZE);
375 }
376 // Next symbol has no leading space.
377 put_space = A68_FALSE;
378 break;
379 }
380 default: {
381 if (put_space) {
382 a68g_bufcat (buffer, " ", BUFFER_SIZE);
383 }
384 // Next symbol may have leading space.
385 put_space = A68_TRUE;
386 break;
387 }
388 }
389 // Attribute or symbol.
390 if (z != NO_TEXT) {
391 switch (gatt) {
392 case DENOTATION:
393 case IDENTIFIER: {
394 ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s '%s'", z, NSYMBOL (p)) >= 0);
395 break;
396 }
397 case OPERATOR: {
398 ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", NSYMBOL (p)) >= 0);
399 break;
400 }
401 case DECLARER:
402 case COLON_SYMBOL: {
403 ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", z) >= 0);
404 break;
405 }
406 default: {
407 if (SUB (p) == NO_NODE && NSYMBOL (p) != NO_TEXT) {
408 ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", NSYMBOL (p)) >= 0);
409 } else {
410 ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", z) >= 0);
411 }
412 break;
413 }
414 }
415 } else if (NSYMBOL (p) != NO_TEXT) {
416 ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "%s", NSYMBOL (p)) >= 0);
417 } else {
418 ASSERT (a68g_bufprt (A68 (edit_line), SNPRINTF_SIZE, "...") >= 0);
419 }
420 a68g_bufcat (buffer, A68 (edit_line), BUFFER_SIZE);
421 count++;
422 }
423 FORWARD (p);
424 }
425 if (p != NO_NODE && count == MAX_TERMINALS) {
426 a68g_bufcat (buffer, " ... ", BUFFER_SIZE);
427 }
428 return buffer;
429 }
430
431 //! @brief Preferably don't put intelligible diagnostic here.
432
433 BOOL_T dont_mark_here (NODE_T * p)
434 {
435 switch (ATTRIBUTE (p)) {
436 case ACCO_SYMBOL:
437 case ALT_DO_SYMBOL:
438 case ALT_EQUALS_SYMBOL:
439 case ANDF_SYMBOL:
440 case ASSERT_SYMBOL:
441 case ASSIGN_SYMBOL:
442 case ASSIGN_TO_SYMBOL:
443 case AT_SYMBOL:
444 case BEGIN_SYMBOL:
445 case BITS_SYMBOL:
446 case BOLD_COMMENT_SYMBOL:
447 case BOLD_PRAGMAT_SYMBOL:
448 case BOOL_SYMBOL:
449 case BUS_SYMBOL:
450 case BY_SYMBOL:
451 case BYTES_SYMBOL:
452 case CASE_SYMBOL:
453 case CHANNEL_SYMBOL:
454 case CHAR_SYMBOL:
455 case CLOSE_SYMBOL:
456 case CODE_SYMBOL:
457 case COLON_SYMBOL:
458 case COLUMN_SYMBOL:
459 case COMMA_SYMBOL:
460 case COMPLEX_SYMBOL:
461 case COMPL_SYMBOL:
462 case DIAGONAL_SYMBOL:
463 case DO_SYMBOL:
464 case DOTDOT_SYMBOL:
465 case DOWNTO_SYMBOL:
466 case EDOC_SYMBOL:
467 case ELIF_SYMBOL:
468 case ELSE_BAR_SYMBOL:
469 case ELSE_SYMBOL:
470 case EMPTY_SYMBOL:
471 case END_SYMBOL:
472 case ENVIRON_SYMBOL:
473 case EQUALS_SYMBOL:
474 case ESAC_SYMBOL:
475 case EXIT_SYMBOL:
476 case FALSE_SYMBOL:
477 case FILE_SYMBOL:
478 case FI_SYMBOL:
479 case FLEX_SYMBOL:
480 case FORMAT_DELIMITER_SYMBOL:
481 case FORMAT_SYMBOL:
482 case FOR_SYMBOL:
483 case FROM_SYMBOL:
484 case GO_SYMBOL:
485 case GOTO_SYMBOL:
486 case HEAP_SYMBOL:
487 case IF_SYMBOL:
488 case IN_SYMBOL:
489 case INT_SYMBOL:
490 case ISNT_SYMBOL:
491 case IS_SYMBOL:
492 case LOC_SYMBOL:
493 case LONG_SYMBOL:
494 case MAIN_SYMBOL:
495 case MODE_SYMBOL:
496 case NIL_SYMBOL:
497 case OCCA_SYMBOL:
498 case OD_SYMBOL:
499 case OF_SYMBOL:
500 case OPEN_SYMBOL:
501 case OP_SYMBOL:
502 case ORF_SYMBOL:
503 case OUSE_SYMBOL:
504 case OUT_SYMBOL:
505 case PAR_SYMBOL:
506 case PIPE_SYMBOL:
507 case POINT_SYMBOL:
508 case PRIO_SYMBOL:
509 case PROC_SYMBOL:
510 case REAL_SYMBOL:
511 case REF_SYMBOL:
512 case ROWS_SYMBOL:
513 case ROW_SYMBOL:
514 case SEMA_SYMBOL:
515 case SEMI_SYMBOL:
516 case SHORT_SYMBOL:
517 case SKIP_SYMBOL:
518 case SOUND_SYMBOL:
519 case STRING_SYMBOL:
520 case STRUCT_SYMBOL:
521 case STYLE_I_COMMENT_SYMBOL:
522 case STYLE_II_COMMENT_SYMBOL:
523 case STYLE_I_PRAGMAT_SYMBOL:
524 case SUB_SYMBOL:
525 case THEN_BAR_SYMBOL:
526 case THEN_SYMBOL:
527 case TO_SYMBOL:
528 case TRANSPOSE_SYMBOL:
529 case TRUE_SYMBOL:
530 case UNION_SYMBOL:
531 case UNTIL_SYMBOL:
532 case VOID_SYMBOL:
533 case WHILE_SYMBOL:
534 case SERIAL_CLAUSE:
535 case ENQUIRY_CLAUSE:
536 case INITIALISER_SERIES:
537 case DECLARATION_LIST: {
538 return A68_TRUE;
539 }
540 }
541 return A68_FALSE;
542 }
543
544 void a68g_parser (void)
545 {
546 // Tokeniser.
547 FILE_SOURCE_OPENED (&A68_JOB) = A68_TRUE;
548 announce_phase ("initialiser");
549 A68_PARSER (error_tag) = (TAG_T *) new_tag ();
550 init_parser ();
551 if (ERROR_COUNT (&A68_JOB) == 0) {
552 int frame_stack_size_2 = A68 (frame_stack_size);
553 int expr_stack_size_2 = A68 (expr_stack_size);
554 int heap_size_2 = A68 (heap_size);
555 int handle_pool_size_2 = A68 (handle_pool_size);
556 BOOL_T ok;
557 announce_phase ("tokeniser");
558 ok = lexical_analyser ();
559 if (!ok || errno != 0) {
560 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
561 return;
562 }
563 // Maybe the program asks for more memory through a PRAGMAT. We restart.
564 if (frame_stack_size_2 != A68 (frame_stack_size) || expr_stack_size_2 != A68 (expr_stack_size) || heap_size_2 != A68 (heap_size) || handle_pool_size_2 != A68 (handle_pool_size)) {
565 announce_phase ("tokeniser");
566 free_syntax_tree (TOP_NODE (&A68_JOB));
567 discard_heap ();
568 init_before_tokeniser ();
569 SOURCE_SCAN (&A68_JOB)++;
570 ok = lexical_analyser ();
571 verbosity ();
572 }
573 if (!ok || errno != 0) {
574 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
575 return;
576 }
577 ASSERT (close (FILE_SOURCE_FD (&A68_JOB)) == 0);
578 FILE_SOURCE_OPENED (&A68_JOB) = A68_FALSE;
579 prune_echoes (OPTION_LIST (&A68_JOB));
580 TREE_LISTING_SAFE (&A68_JOB) = A68_TRUE;
581 int renum = 0;
582 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
583 }
584 // Now the default precision of LONG LONG modes is fixed.
585 if (long_mp_digits () == 0) {
586 set_long_mp_digits (LONG_LONG_MP_DIGITS);
587 }
588 // Final initialisations.
589 if (ERROR_COUNT (&A68_JOB) == 0) {
590 if (OPTION_REGRESSION_TEST (&A68_JOB)) {
591 a68g_bufcpy (A68 (a68g_cmd_name), "a68g", BUFFER_SIZE);
592 io_close_tty_line ();
593 WRITE (A68_STDERR, "[");
594 WRITE (A68_STDERR, FILE_INITIAL_NAME (&A68_JOB));
595 WRITE (A68_STDERR, "]\n");
596 }
597 A68_STANDENV = NO_TABLE;
598 init_postulates ();
599 A68 (mode_count) = 0;
600 make_special_mode (&M_HIP, A68 (mode_count)++);
601 make_special_mode (&M_UNDEFINED, A68 (mode_count)++);
602 make_special_mode (&M_ERROR, A68 (mode_count)++);
603 make_special_mode (&M_VACUUM, A68 (mode_count)++);
604 make_special_mode (&M_C_STRING, A68 (mode_count)++);
605 make_special_mode (&M_COLLITEM, A68 (mode_count)++);
606 make_special_mode (&M_SOUND_DATA, A68 (mode_count)++);
607 }
608 // Refinement preprocessor.
609 if (ERROR_COUNT (&A68_JOB) == 0) {
610 announce_phase ("preprocessor");
611 get_refinements ();
612 if (ERROR_COUNT (&A68_JOB) == 0) {
613 put_refinements ();
614 }
615 int renum = 0;
616 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
617 verbosity ();
618 }
619 // Top-down parser.
620 if (ERROR_COUNT (&A68_JOB) == 0) {
621 announce_phase ("parser phase 1");
622 check_parenthesis (TOP_NODE (&A68_JOB));
623 if (ERROR_COUNT (&A68_JOB) == 0) {
624 if (OPTION_BRACKETS (&A68_JOB)) {
625 substitute_brackets (TOP_NODE (&A68_JOB));
626 }
627 A68 (symbol_table_count) = 0;
628 A68_STANDENV = new_symbol_table (NO_TABLE);
629 LEVEL (A68_STANDENV) = 0;
630 top_down_parser (TOP_NODE (&A68_JOB));
631 }
632 int renum = 0;
633 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
634 verbosity ();
635 }
636 // Standard environment builder.
637 if (ERROR_COUNT (&A68_JOB) == 0) {
638 announce_phase ("standard environ builder");
639 TABLE (TOP_NODE (&A68_JOB)) = new_symbol_table (A68_STANDENV);
640 make_standard_environ ();
641 STANDENV_MOID (&A68_JOB) = TOP_MOID (&A68_JOB);
642 verbosity ();
643 }
644 // Bottom-up parser.
645 if (ERROR_COUNT (&A68_JOB) == 0) {
646 announce_phase ("parser phase 2");
647 preliminary_symbol_table_setup (TOP_NODE (&A68_JOB));
648 bottom_up_parser (TOP_NODE (&A68_JOB));
649 int renum = 0;
650 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
651 verbosity ();
652 }
653 if (ERROR_COUNT (&A68_JOB) == 0) {
654 announce_phase ("parser phase 3");
655 bottom_up_error_check (TOP_NODE (&A68_JOB));
656 victal_checker (TOP_NODE (&A68_JOB));
657 if (ERROR_COUNT (&A68_JOB) == 0) {
658 finalise_symbol_table_setup (TOP_NODE (&A68_JOB), 2);
659 NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3;
660 reset_symbol_table_nest_count (TOP_NODE (&A68_JOB));
661 fill_symbol_table_outer (TOP_NODE (&A68_JOB), TABLE (TOP_NODE (&A68_JOB)));
662 set_nest (TOP_NODE (&A68_JOB), NO_NODE);
663 set_proc_level (TOP_NODE (&A68_JOB), 1);
664 }
665 int renum = 0;
666 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
667 verbosity ();
668 }
669 // Mode table builder.
670 if (ERROR_COUNT (&A68_JOB) == 0) {
671 announce_phase ("mode table builder");
672 make_moid_list (&A68_JOB);
673 verbosity ();
674 }
675 CROSS_REFERENCE_SAFE (&A68_JOB) = A68_TRUE;
676 // Symbol table builder.
677 if (ERROR_COUNT (&A68_JOB) == 0) {
678 announce_phase ("symbol table builder");
679 collect_taxes (TOP_NODE (&A68_JOB));
680 verbosity ();
681 }
682 // Post parser.
683 if (ERROR_COUNT (&A68_JOB) == 0) {
684 announce_phase ("parser phase 4");
685 rearrange_goto_less_jumps (TOP_NODE (&A68_JOB));
686 verbosity ();
687 }
688 // Mode checker.
689 if (ERROR_COUNT (&A68_JOB) == 0) {
690 announce_phase ("mode checker");
691 mode_checker (TOP_NODE (&A68_JOB));
692 verbosity ();
693 }
694 // Coercion inserter.
695 if (ERROR_COUNT (&A68_JOB) == 0) {
696 announce_phase ("coercion enforcer");
697 coercion_inserter (TOP_NODE (&A68_JOB));
698 widen_denotation (TOP_NODE (&A68_JOB));
699 get_max_simplout_size (TOP_NODE (&A68_JOB));
700 set_moid_sizes (TOP_MOID (&A68_JOB));
701 assign_offsets_table (A68_STANDENV);
702 assign_offsets (TOP_NODE (&A68_JOB));
703 assign_offsets_packs (TOP_MOID (&A68_JOB));
704 int renum = 0;
705 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
706 verbosity ();
707 }
708 // Application checker.
709 if (ERROR_COUNT (&A68_JOB) == 0) {
710 announce_phase ("application checker");
711 mark_moids (TOP_NODE (&A68_JOB));
712 mark_auxilliary (TOP_NODE (&A68_JOB));
713 jumps_from_procs (TOP_NODE (&A68_JOB));
714 warn_for_unused_tags (TOP_NODE (&A68_JOB));
715 verbosity ();
716 }
717 // Scope checker.
718 if (ERROR_COUNT (&A68_JOB) == 0) {
719 announce_phase ("static scope checker");
720 tie_label_to_serial (TOP_NODE (&A68_JOB));
721 tie_label_to_unit (TOP_NODE (&A68_JOB));
722 bind_routine_tags_to_tree (TOP_NODE (&A68_JOB));
723 bind_format_tags_to_tree (TOP_NODE (&A68_JOB));
724 scope_checker (TOP_NODE (&A68_JOB));
725 verbosity ();
726 }
727 }
728
729 //! @brief Renumber nodes.
730
731 void renumber_nodes (NODE_T * p, int *n)
732 {
733 for (; p != NO_NODE; FORWARD (p)) {
734 NUMBER (p) = (*n)++;
735 renumber_nodes (SUB (p), n);
736 }
737 }
738
739 //! @brief Register nodes.
740
741 void register_nodes (NODE_T * p)
742 {
743 for (; p != NO_NODE; FORWARD (p)) {
744 A68 (node_register)[NUMBER (p)] = p;
745 register_nodes (SUB (p));
746 }
747 }
748
749 //! @brief New_node_info.
750
751 NODE_INFO_T *new_node_info (void)
752 {
753 NODE_INFO_T *z = (NODE_INFO_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (NODE_INFO_T));
754 A68 (new_node_infos)++;
755 PROCEDURE_LEVEL (z) = 0;
756 CHAR_IN_LINE (z) = NO_TEXT;
757 SYMBOL (z) = NO_TEXT;
758 PRAGMENT (z) = NO_TEXT;
759 PRAGMENT_TYPE (z) = 0;
760 LINE (z) = NO_LINE;
761 return z;
762 }
763
764 //! @brief New_genie_info.
765
766 GINFO_T *new_genie_info (void)
767 {
768 GINFO_T *z = (GINFO_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (GINFO_T));
769 A68 (new_genie_infos)++;
770 UNIT (&PROP (z)) = NO_PPROC;
771 SOURCE (&PROP (z)) = NO_NODE;
772 PARTIAL_PROC (z) = NO_MOID;
773 PARTIAL_LOCALE (z) = NO_MOID;
774 IS_COERCION (z) = A68_FALSE;
775 IS_NEW_LEXICAL_LEVEL (z) = A68_FALSE;
776 NEED_DNS (z) = A68_FALSE;
777 PARENT (z) = NO_NODE;
778 OFFSET (z) = NO_BYTE;
779 CONSTANT (z) = NO_CONSTANT;
780 LEVEL (z) = 0;
781 ARGSIZE (z) = 0;
782 SIZE (z) = 0;
783 COMPILE_NAME (z) = NO_TEXT;
784 COMPILE_NODE (z) = 0;
785 return z;
786 }
787
788 //! @brief New_node.
789
790 NODE_T *new_node (void)
791 {
792 NODE_T *z = (NODE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (NODE_T));
793 A68 (new_nodes)++;
794 STATUS (z) = NULL_MASK;
795 CODEX (z) = NULL_MASK;
796 TABLE (z) = NO_TABLE;
797 INFO (z) = NO_NINFO;
798 GINFO (z) = NO_GINFO;
799 ATTRIBUTE (z) = 0;
800 ANNOTATION (z) = 0;
801 MOID (z) = NO_MOID;
802 NEXT (z) = NO_NODE;
803 PREVIOUS (z) = NO_NODE;
804 SUB (z) = NO_NODE;
805 NEST (z) = NO_NODE;
806 NON_LOCAL (z) = NO_TABLE;
807 TAX (z) = NO_TAG;
808 SEQUENCE (z) = NO_NODE;
809 PACK (z) = NO_PACK;
810 return z;
811 }
812
813 //! @brief New_symbol_table.
814
815 TABLE_T *new_symbol_table (TABLE_T * p)
816 {
817 TABLE_T *z = (TABLE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (TABLE_T));
818 NUM (z) = A68 (symbol_table_count);
819 LEVEL (z) = A68 (symbol_table_count)++;
820 NEST (z) = A68 (symbol_table_count);
821 ATTRIBUTE (z) = 0;
822 AP_INCREMENT (z) = 0;
823 INITIALISE_FRAME (z) = A68_TRUE;
824 PROC_OPS (z) = A68_TRUE;
825 INITIALISE_ANON (z) = A68_TRUE;
826 PREVIOUS (z) = p;
827 OUTER (z) = NO_TABLE;
828 IDENTIFIERS (z) = NO_TAG;
829 OPERATORS (z) = NO_TAG;
830 PRIO (z) = NO_TAG;
831 INDICANTS (z) = NO_TAG;
832 LABELS (z) = NO_TAG;
833 ANONYMOUS (z) = NO_TAG;
834 JUMP_TO (z) = NO_NODE;
835 SEQUENCE (z) = NO_NODE;
836 return z;
837 }
838
839 //! @brief New_moid.
840
841 MOID_T *new_moid (void)
842 {
843 MOID_T *z = (MOID_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (MOID_T));
844 A68 (new_modes)++;
845 ATTRIBUTE (z) = 0;
846 NUMBER (z) = 0;
847 DIM (z) = 0;
848 USE (z) = A68_FALSE;
849 HAS_ROWS (z) = A68_FALSE;
850 SIZE (z) = 0;
851 DIGITS (z) = 0;
852 SIZE_COMPL (z) = 0;
853 DIGITS_COMPL (z) = 0;
854 PORTABLE (z) = A68_TRUE;
855 DERIVATE (z) = A68_FALSE;
856 NODE (z) = NO_NODE;
857 PACK (z) = NO_PACK;
858 SUB (z) = NO_MOID;
859 EQUIVALENT_MODE (z) = NO_MOID;
860 SLICE (z) = NO_MOID;
861 TRIM (z) = NO_MOID;
862 DEFLEXED (z) = NO_MOID;
863 NAME (z) = NO_MOID;
864 MULTIPLE_MODE (z) = NO_MOID;
865 NEXT (z) = NO_MOID;
866 return z;
867 }
868
869 //! @brief New_pack.
870
871 PACK_T *new_pack (void)
872 {
873 PACK_T *z = (PACK_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (PACK_T));
874 MOID (z) = NO_MOID;
875 TEXT (z) = NO_TEXT;
876 NODE (z) = NO_NODE;
877 NEXT (z) = NO_PACK;
878 PREVIOUS (z) = NO_PACK;
879 SIZE (z) = 0;
880 OFFSET (z) = 0;
881 return z;
882 }
883
884 //! @brief New_tag.
885
886 TAG_T *new_tag (void)
887 {
888 TAG_T *z = (TAG_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (TAG_T));
889 STATUS (z) = NULL_MASK;
890 CODEX (z) = NULL_MASK;
891 TAG_TABLE (z) = NO_TABLE;
892 MOID (z) = NO_MOID;
893 NODE (z) = NO_NODE;
894 UNIT (z) = NO_NODE;
895 VALUE (z) = NO_TEXT;
896 A68_STANDENV_PROC (z) = 0;
897 PROCEDURE (z) = NO_GPROC;
898 SCOPE (z) = PRIMAL_SCOPE;
899 SCOPE_ASSIGNED (z) = A68_FALSE;
900 PRIO (z) = 0;
901 USE (z) = A68_FALSE;
902 IN_PROC (z) = A68_FALSE;
903 HEAP (z) = A68_FALSE;
904 SIZE (z) = 0;
905 OFFSET (z) = 0;
906 YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE;
907 LOC_ASSIGNED (z) = A68_FALSE;
908 NEXT (z) = NO_TAG;
909 BODY (z) = NO_TAG;
910 PORTABLE (z) = A68_TRUE;
911 NUMBER (z) = ++A68_PARSER (tag_number);
912 return z;
913 }
914
915 //! @brief Make special, internal mode.
916
917 void make_special_mode (MOID_T ** n, int m)
918 {
919 (*n) = new_moid ();
920 ATTRIBUTE (*n) = 0;
921 NUMBER (*n) = m;
922 PACK (*n) = NO_PACK;
923 SUB (*n) = NO_MOID;
924 EQUIVALENT (*n) = NO_MOID;
925 DEFLEXED (*n) = NO_MOID;
926 NAME (*n) = NO_MOID;
927 SLICE (*n) = NO_MOID;
928 TRIM (*n) = NO_MOID;
929 ROWED (*n) = NO_MOID;
930 }
931
932 //! @brief Whether x matches c; case insensitive.
933
934 BOOL_T match_string (char *x, char *c, char alt)
935 {
936 BOOL_T match = A68_TRUE;
937 while ((IS_UPPER (c[0]) || IS_DIGIT (c[0]) || c[0] == '-') && match) {
938 match = (BOOL_T) (match & (TO_LOWER (x[0]) == TO_LOWER ((c++)[0])));
939 if (!(x[0] == NULL_CHAR || x[0] == alt)) {
940 x++;
941 }
942 }
943 while (x[0] != NULL_CHAR && x[0] != alt && c[0] != NULL_CHAR && match) {
944 match = (BOOL_T) (match & (TO_LOWER ((x++)[0]) == TO_LOWER ((c++)[0])));
945 }
946 return (BOOL_T) (match ? (x[0] == NULL_CHAR || x[0] == alt) : A68_FALSE);
947 }
948
949 //! @brief Whether attributes match in subsequent nodes.
950
951 BOOL_T whether (NODE_T * p, ...)
952 {
953 va_list vl;
954 va_start (vl, p);
955 int a;
956 while ((a = va_arg (vl, int)) != STOP)
957 {
958 if (p != NO_NODE && a == WILDCARD) {
959 FORWARD (p);
960 } else if (p != NO_NODE && (a == KEYWORD)) {
961 if (find_keyword_from_attribute (A68 (top_keyword), ATTRIBUTE (p)) != NO_KEYWORD) {
962 FORWARD (p);
963 } else {
964 va_end (vl);
965 return A68_FALSE;
966 }
967 } else if (p != NO_NODE && (a >= 0 ? a == ATTRIBUTE (p) : (-a) != ATTRIBUTE (p))) {
968 FORWARD (p);
969 } else {
970 va_end (vl);
971 return A68_FALSE;
972 }
973 }
974 va_end (vl);
975 return A68_TRUE;
976 }
977
978 //! @brief Whether one of a series of attributes matches a node.
979
980 BOOL_T is_one_of (NODE_T * p, ...)
981 {
982 if (p != NO_NODE) {
983 va_list vl;
984 va_start (vl, p);
985 BOOL_T match = A68_FALSE;
986 int a;
987 while ((a = va_arg (vl, int)) != STOP)
988 {
989 match = (BOOL_T) (match | (BOOL_T) (IS (p, a)));
990 }
991 va_end (vl);
992 return match;
993 } else {
994 return A68_FALSE;
995 }
996 }
997
998 //! @brief Isolate nodes p-q making p a branch to p-q.
999
1000 void make_sub (NODE_T * p, NODE_T * q, int t)
1001 {
1002 NODE_T *z = new_node ();
1003 ABEND (p == NO_NODE || q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1004 *z = *p;
1005 if (GINFO (p) != NO_GINFO) {
1006 GINFO (z) = new_genie_info ();
1007 }
1008 PREVIOUS (z) = NO_NODE;
1009 if (p == q) {
1010 NEXT (z) = NO_NODE;
1011 } else {
1012 if (NEXT (p) != NO_NODE) {
1013 PREVIOUS (NEXT (p)) = z;
1014 }
1015 NEXT (p) = NEXT (q);
1016 if (NEXT (p) != NO_NODE) {
1017 PREVIOUS (NEXT (p)) = p;
1018 }
1019 NEXT (q) = NO_NODE;
1020 }
1021 SUB (p) = z;
1022 ATTRIBUTE (p) = t;
1023 }
1024
1025 //! @brief Find symbol table at level 'i'.
1026
1027 TABLE_T *find_level (NODE_T * n, int i)
1028 {
1029 if (n == NO_NODE) {
1030 return NO_TABLE;
1031 } else {
1032 TABLE_T *s = TABLE (n);
1033 if (s != NO_TABLE && LEVEL (s) == i) {
1034 return s;
1035 } else if ((s = find_level (SUB (n), i)) != NO_TABLE) {
1036 return s;
1037 } else if ((s = find_level (NEXT (n), i)) != NO_TABLE) {
1038 return s;
1039 } else {
1040 return NO_TABLE;
1041 }
1042 }
1043 }
1044
1045 //! @brief Whether 'p' is top of lexical level.
1046
1047 BOOL_T is_new_lexical_level (NODE_T * p)
1048 {
1049 switch (ATTRIBUTE (p)) {
1050 case ALT_DO_PART:
1051 case BRIEF_ELIF_PART:
1052 case BRIEF_OUSE_PART:
1053 case BRIEF_CONFORMITY_OUSE_PART:
1054 case CHOICE:
1055 case CLOSED_CLAUSE:
1056 case CONDITIONAL_CLAUSE:
1057 case DO_PART:
1058 case ELIF_PART:
1059 case ELSE_PART:
1060 case FORMAT_TEXT:
1061 case CASE_CLAUSE:
1062 case CASE_CHOICE_CLAUSE:
1063 case CASE_IN_PART:
1064 case CASE_OUSE_PART:
1065 case OUT_PART:
1066 case ROUTINE_TEXT:
1067 case SPECIFIED_UNIT:
1068 case THEN_PART:
1069 case UNTIL_PART:
1070 case CONFORMITY_CLAUSE:
1071 case CONFORMITY_CHOICE:
1072 case CONFORMITY_IN_PART:
1073 case CONFORMITY_OUSE_PART:
1074 case WHILE_PART: {
1075 return A68_TRUE;
1076 }
1077 default: {
1078 return A68_FALSE;
1079 }
1080 }
1081 }
1082
1083 //! @brief Some_node.
1084
1085 NODE_T *some_node (char *t)
1086 {
1087 NODE_T *z = new_node ();
1088 INFO (z) = new_node_info ();
1089 GINFO (z) = new_genie_info ();
1090 NSYMBOL (z) = t;
1091 return z;
1092 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
