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-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 //! 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 {
226 return A68_TRUE;
227 }
228 default:
229 {
230 return A68_FALSE;
231 }
232 }
233 }
234
235 //! @brief Whether formal bounds.
236
237 BOOL_T is_formal_bounds (NODE_T * p)
238 {
239 if (p == NO_NODE) {
240 return A68_TRUE;
241 } else {
242 switch (ATTRIBUTE (p)) {
243 case OPEN_SYMBOL:
244 case CLOSE_SYMBOL:
245 case SUB_SYMBOL:
246 case BUS_SYMBOL:
247 case COMMA_SYMBOL:
248 case COLON_SYMBOL:
249 case DOTDOT_SYMBOL:
250 case INT_DENOTATION:
251 case IDENTIFIER:
252 case OPERATOR:
253 {
254 return (BOOL_T) (is_formal_bounds (SUB (p)) && is_formal_bounds (NEXT (p)));
255 }
256 default:
257 {
258 return A68_FALSE;
259 }
260 }
261 }
262 }
263
264 //! @brief Whether token terminates a unit.
265
266 BOOL_T is_unit_terminator (NODE_T * p)
267 {
268 switch (ATTRIBUTE (p)) {
269 case BUS_SYMBOL:
270 case CLOSE_SYMBOL:
271 case END_SYMBOL:
272 case SEMI_SYMBOL:
273 case EXIT_SYMBOL:
274 case COMMA_SYMBOL:
275 case THEN_BAR_SYMBOL:
276 case ELSE_BAR_SYMBOL:
277 case THEN_SYMBOL:
278 case ELIF_SYMBOL:
279 case ELSE_SYMBOL:
280 case FI_SYMBOL:
281 case IN_SYMBOL:
282 case OUT_SYMBOL:
283 case OUSE_SYMBOL:
284 case ESAC_SYMBOL:
285 case EDOC_SYMBOL:
286 case OCCA_SYMBOL:
287 {
288 return A68_TRUE;
289 }
290 }
291 return A68_FALSE;
292 }
293
294 //! @brief Whether token is a unit-terminator in a loop clause.
295
296 BOOL_T is_loop_keyword (NODE_T * p)
297 {
298 switch (ATTRIBUTE (p)) {
299 case FOR_SYMBOL:
300 case FROM_SYMBOL:
301 case BY_SYMBOL:
302 case TO_SYMBOL:
303 case DOWNTO_SYMBOL:
304 case WHILE_SYMBOL:
305 case DO_SYMBOL:
306 {
307 return A68_TRUE;
308 }
309 }
310 return A68_FALSE;
311 }
312
313 //! @brief Get good attribute.
314
315 int get_good_attribute (NODE_T * p)
316 {
317 switch (ATTRIBUTE (p)) {
318 case UNIT:
319 case TERTIARY:
320 case SECONDARY:
321 case PRIMARY:
322 {
323 return get_good_attribute (SUB (p));
324 }
325 default:
326 {
327 return ATTRIBUTE (p);
328 }
329 }
330 }
331
332 //! @brief Preferably don't put intelligible diagnostic here.
333
334 BOOL_T dont_mark_here (NODE_T * p)
335 {
336 switch (ATTRIBUTE (p)) {
337 case ACCO_SYMBOL:
338 case ALT_DO_SYMBOL:
339 case ALT_EQUALS_SYMBOL:
340 case ANDF_SYMBOL:
341 case ASSERT_SYMBOL:
342 case ASSIGN_SYMBOL:
343 case ASSIGN_TO_SYMBOL:
344 case AT_SYMBOL:
345 case BEGIN_SYMBOL:
346 case BITS_SYMBOL:
347 case BOLD_COMMENT_SYMBOL:
348 case BOLD_PRAGMAT_SYMBOL:
349 case BOOL_SYMBOL:
350 case BUS_SYMBOL:
351 case BY_SYMBOL:
352 case BYTES_SYMBOL:
353 case CASE_SYMBOL:
354 case CHANNEL_SYMBOL:
355 case CHAR_SYMBOL:
356 case CLOSE_SYMBOL:
357 case CODE_SYMBOL:
358 case COLON_SYMBOL:
359 case COLUMN_SYMBOL:
360 case COMMA_SYMBOL:
361 case COMPLEX_SYMBOL:
362 case COMPL_SYMBOL:
363 case DIAGONAL_SYMBOL:
364 case DO_SYMBOL:
365 case DOTDOT_SYMBOL:
366 case DOWNTO_SYMBOL:
367 case EDOC_SYMBOL:
368 case ELIF_SYMBOL:
369 case ELSE_BAR_SYMBOL:
370 case ELSE_SYMBOL:
371 case EMPTY_SYMBOL:
372 case END_SYMBOL:
373 case ENVIRON_SYMBOL:
374 case EQUALS_SYMBOL:
375 case ESAC_SYMBOL:
376 case EXIT_SYMBOL:
377 case FALSE_SYMBOL:
378 case FILE_SYMBOL:
379 case FI_SYMBOL:
380 case FLEX_SYMBOL:
381 case FORMAT_DELIMITER_SYMBOL:
382 case FORMAT_SYMBOL:
383 case FOR_SYMBOL:
384 case FROM_SYMBOL:
385 case GO_SYMBOL:
386 case GOTO_SYMBOL:
387 case HEAP_SYMBOL:
388 case IF_SYMBOL:
389 case IN_SYMBOL:
390 case INT_SYMBOL:
391 case ISNT_SYMBOL:
392 case IS_SYMBOL:
393 case LOC_SYMBOL:
394 case LONG_SYMBOL:
395 case MAIN_SYMBOL:
396 case MODE_SYMBOL:
397 case NIL_SYMBOL:
398 case OCCA_SYMBOL:
399 case OD_SYMBOL:
400 case OF_SYMBOL:
401 case OPEN_SYMBOL:
402 case OP_SYMBOL:
403 case ORF_SYMBOL:
404 case OUSE_SYMBOL:
405 case OUT_SYMBOL:
406 case PAR_SYMBOL:
407 case PIPE_SYMBOL:
408 case POINT_SYMBOL:
409 case PRIO_SYMBOL:
410 case PROC_SYMBOL:
411 case REAL_SYMBOL:
412 case REF_SYMBOL:
413 case ROWS_SYMBOL:
414 case ROW_SYMBOL:
415 case SEMA_SYMBOL:
416 case SEMI_SYMBOL:
417 case SHORT_SYMBOL:
418 case SKIP_SYMBOL:
419 case SOUND_SYMBOL:
420 case STRING_SYMBOL:
421 case STRUCT_SYMBOL:
422 case STYLE_I_COMMENT_SYMBOL:
423 case STYLE_II_COMMENT_SYMBOL:
424 case STYLE_I_PRAGMAT_SYMBOL:
425 case SUB_SYMBOL:
426 case THEN_BAR_SYMBOL:
427 case THEN_SYMBOL:
428 case TO_SYMBOL:
429 case TRANSPOSE_SYMBOL:
430 case TRUE_SYMBOL:
431 case UNION_SYMBOL:
432 case UNTIL_SYMBOL:
433 case VOID_SYMBOL:
434 case WHILE_SYMBOL:
435 case SERIAL_CLAUSE:
436 case ENQUIRY_CLAUSE:
437 case INITIALISER_SERIES:
438 case DECLARATION_LIST:
439 {
440 return A68_TRUE;
441 }
442 }
443 return A68_FALSE;
444 }
445
446 void a68_parser (void)
447 {
448 // Tokeniser.
449 int renum;
450 FILE_SOURCE_OPENED (&A68_JOB) = A68_TRUE;
451 announce_phase ("initialiser");
452 A68_PARSER (error_tag) = (TAG_T *) new_tag ();
453 init_parser ();
454 if (ERROR_COUNT (&A68_JOB) == 0) {
455 int frame_stack_size_2 = A68 (frame_stack_size);
456 int expr_stack_size_2 = A68 (expr_stack_size);
457 int heap_size_2 = A68 (heap_size);
458 int handle_pool_size_2 = A68 (handle_pool_size);
459 BOOL_T ok;
460 announce_phase ("tokeniser");
461 ok = lexical_analyser ();
462 if (!ok || errno != 0) {
463 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
464 return;
465 }
466 // Maybe the program asks for more memory through a PRAGMAT. We restart.
467 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)) {
468 announce_phase ("tokeniser");
469 free_syntax_tree (TOP_NODE (&A68_JOB));
470 discard_heap ();
471 init_before_tokeniser ();
472 SOURCE_SCAN (&A68_JOB)++;
473 ok = lexical_analyser ();
474 verbosity ();
475 }
476 if (!ok || errno != 0) {
477 diagnostics_to_terminal (TOP_LINE (&A68_JOB), A68_ALL_DIAGNOSTICS);
478 return;
479 }
480 ASSERT (close (FILE_SOURCE_FD (&A68_JOB)) == 0);
481 FILE_SOURCE_OPENED (&A68_JOB) = A68_FALSE;
482 prune_echoes (OPTION_LIST (&A68_JOB));
483 TREE_LISTING_SAFE (&A68_JOB) = A68_TRUE;
484 renum = 0;
485 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
486 }
487 // Now the default precision of LONG LONG modes is fixed.
488 if (long_mp_digits () == 0) {
489 set_long_mp_digits (LONG_LONG_MP_DIGITS);
490 }
491 // Final initialisations.
492 if (ERROR_COUNT (&A68_JOB) == 0) {
493 if (OPTION_REGRESSION_TEST (&A68_JOB)) {
494 bufcpy (A68 (a68_cmd_name), "a68g", BUFFER_SIZE);
495 io_close_tty_line ();
496 WRITE (STDERR_FILENO, "[");
497 WRITE (STDERR_FILENO, FILE_INITIAL_NAME (&A68_JOB));
498 WRITE (STDERR_FILENO, "]\n");
499 }
500 A68_STANDENV = NO_TABLE;
501 init_postulates ();
502 A68 (mode_count) = 0;
503 make_special_mode (&M_HIP, A68 (mode_count)++);
504 make_special_mode (&M_UNDEFINED, A68 (mode_count)++);
505 make_special_mode (&M_ERROR, A68 (mode_count)++);
506 make_special_mode (&M_VACUUM, A68 (mode_count)++);
507 make_special_mode (&M_C_STRING, A68 (mode_count)++);
508 make_special_mode (&M_COLLITEM, A68 (mode_count)++);
509 make_special_mode (&M_SOUND_DATA, A68 (mode_count)++);
510 }
511 // Refinement preprocessor.
512 if (ERROR_COUNT (&A68_JOB) == 0) {
513 announce_phase ("preprocessor");
514 get_refinements ();
515 if (ERROR_COUNT (&A68_JOB) == 0) {
516 put_refinements ();
517 }
518 renum = 0;
519 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
520 verbosity ();
521 }
522 // Top-down parser.
523 if (ERROR_COUNT (&A68_JOB) == 0) {
524 announce_phase ("parser phase 1");
525 check_parenthesis (TOP_NODE (&A68_JOB));
526 if (ERROR_COUNT (&A68_JOB) == 0) {
527 if (OPTION_BRACKETS (&A68_JOB)) {
528 substitute_brackets (TOP_NODE (&A68_JOB));
529 }
530 A68 (symbol_table_count) = 0;
531 A68_STANDENV = new_symbol_table (NO_TABLE);
532 LEVEL (A68_STANDENV) = 0;
533 top_down_parser (TOP_NODE (&A68_JOB));
534 }
535 renum = 0;
536 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
537 verbosity ();
538 }
539 // Standard environment builder.
540 if (ERROR_COUNT (&A68_JOB) == 0) {
541 announce_phase ("standard environ builder");
542 TABLE (TOP_NODE (&A68_JOB)) = new_symbol_table (A68_STANDENV);
543 make_standard_environ ();
544 STANDENV_MOID (&A68_JOB) = TOP_MOID (&A68_JOB);
545 verbosity ();
546 }
547 // Bottom-up parser.
548 if (ERROR_COUNT (&A68_JOB) == 0) {
549 announce_phase ("parser phase 2");
550 preliminary_symbol_table_setup (TOP_NODE (&A68_JOB));
551 bottom_up_parser (TOP_NODE (&A68_JOB));
552 renum = 0;
553 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
554 verbosity ();
555 }
556 if (ERROR_COUNT (&A68_JOB) == 0) {
557 announce_phase ("parser phase 3");
558 bottom_up_error_check (TOP_NODE (&A68_JOB));
559 victal_checker (TOP_NODE (&A68_JOB));
560 if (ERROR_COUNT (&A68_JOB) == 0) {
561 finalise_symbol_table_setup (TOP_NODE (&A68_JOB), 2);
562 NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3;
563 reset_symbol_table_nest_count (TOP_NODE (&A68_JOB));
564 fill_symbol_table_outer (TOP_NODE (&A68_JOB), TABLE (TOP_NODE (&A68_JOB)));
565 set_nest (TOP_NODE (&A68_JOB), NO_NODE);
566 set_proc_level (TOP_NODE (&A68_JOB), 1);
567 }
568 renum = 0;
569 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
570 verbosity ();
571 }
572 // Mode table builder.
573 if (ERROR_COUNT (&A68_JOB) == 0) {
574 announce_phase ("mode table builder");
575 make_moid_list (&A68_JOB);
576 verbosity ();
577 }
578 CROSS_REFERENCE_SAFE (&A68_JOB) = A68_TRUE;
579 // Symbol table builder.
580 if (ERROR_COUNT (&A68_JOB) == 0) {
581 announce_phase ("symbol table builder");
582 collect_taxes (TOP_NODE (&A68_JOB));
583 verbosity ();
584 }
585 // Post parser.
586 if (ERROR_COUNT (&A68_JOB) == 0) {
587 announce_phase ("parser phase 4");
588 rearrange_goto_less_jumps (TOP_NODE (&A68_JOB));
589 verbosity ();
590 }
591 // Mode checker.
592 if (ERROR_COUNT (&A68_JOB) == 0) {
593 announce_phase ("mode checker");
594 mode_checker (TOP_NODE (&A68_JOB));
595 verbosity ();
596 }
597 // Coercion inserter.
598 if (ERROR_COUNT (&A68_JOB) == 0) {
599 announce_phase ("coercion enforcer");
600 coercion_inserter (TOP_NODE (&A68_JOB));
601 widen_denotation (TOP_NODE (&A68_JOB));
602 get_max_simplout_size (TOP_NODE (&A68_JOB));
603 set_moid_sizes (TOP_MOID (&A68_JOB));
604 assign_offsets_table (A68_STANDENV);
605 assign_offsets (TOP_NODE (&A68_JOB));
606 assign_offsets_packs (TOP_MOID (&A68_JOB));
607 renum = 0;
608 renumber_nodes (TOP_NODE (&A68_JOB), &renum);
609 verbosity ();
610 }
611 // Application checker.
612 if (ERROR_COUNT (&A68_JOB) == 0) {
613 announce_phase ("application checker");
614 mark_moids (TOP_NODE (&A68_JOB));
615 mark_auxilliary (TOP_NODE (&A68_JOB));
616 jumps_from_procs (TOP_NODE (&A68_JOB));
617 warn_for_unused_tags (TOP_NODE (&A68_JOB));
618 verbosity ();
619 }
620 // Scope checker.
621 if (ERROR_COUNT (&A68_JOB) == 0) {
622 announce_phase ("static scope checker");
623 tie_label_to_serial (TOP_NODE (&A68_JOB));
624 tie_label_to_unit (TOP_NODE (&A68_JOB));
625 bind_routine_tags_to_tree (TOP_NODE (&A68_JOB));
626 bind_format_tags_to_tree (TOP_NODE (&A68_JOB));
627 scope_checker (TOP_NODE (&A68_JOB));
628 verbosity ();
629 }
630 }
631
632 //! @brief Renumber nodes.
633
634 void renumber_nodes (NODE_T * p, int *n)
635 {
636 for (; p != NO_NODE; FORWARD (p)) {
637 NUMBER (p) = (*n)++;
638 renumber_nodes (SUB (p), n);
639 }
640 }
641
642 //! @brief Register nodes.
643
644 void register_nodes (NODE_T * p)
645 {
646 for (; p != NO_NODE; FORWARD (p)) {
647 A68 (node_register)[NUMBER (p)] = p;
648 register_nodes (SUB (p));
649 }
650 }
651
652 //! @brief New_node_info.
653
654 NODE_INFO_T *new_node_info (void)
655 {
656 NODE_INFO_T *z = (NODE_INFO_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (NODE_INFO_T));
657 A68 (new_node_infos)++;
658 PROCEDURE_LEVEL (z) = 0;
659 CHAR_IN_LINE (z) = NO_TEXT;
660 SYMBOL (z) = NO_TEXT;
661 PRAGMENT (z) = NO_TEXT;
662 PRAGMENT_TYPE (z) = 0;
663 LINE (z) = NO_LINE;
664 return z;
665 }
666
667 //! @brief New_genie_info.
668
669 GINFO_T *new_genie_info (void)
670 {
671 GINFO_T *z = (GINFO_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (GINFO_T));
672 A68 (new_genie_infos)++;
673 UNIT (&PROP (z)) = NO_PPROC;
674 SOURCE (&PROP (z)) = NO_NODE;
675 PARTIAL_PROC (z) = NO_MOID;
676 PARTIAL_LOCALE (z) = NO_MOID;
677 IS_COERCION (z) = A68_FALSE;
678 IS_NEW_LEXICAL_LEVEL (z) = A68_FALSE;
679 NEED_DNS (z) = A68_FALSE;
680 PARENT (z) = NO_NODE;
681 OFFSET (z) = NO_BYTE;
682 CONSTANT (z) = NO_CONSTANT;
683 LEVEL (z) = 0;
684 ARGSIZE (z) = 0;
685 SIZE (z) = 0;
686 COMPILE_NAME (z) = NO_TEXT;
687 COMPILE_NODE (z) = 0;
688 return z;
689 }
690
691 //! @brief New_node.
692
693 NODE_T *new_node (void)
694 {
695 NODE_T *z = (NODE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (NODE_T));
696 A68 (new_nodes)++;
697 STATUS (z) = NULL_MASK;
698 CODEX (z) = NULL_MASK;
699 TABLE (z) = NO_TABLE;
700 INFO (z) = NO_NINFO;
701 GINFO (z) = NO_GINFO;
702 ATTRIBUTE (z) = 0;
703 ANNOTATION (z) = 0;
704 MOID (z) = NO_MOID;
705 NEXT (z) = NO_NODE;
706 PREVIOUS (z) = NO_NODE;
707 SUB (z) = NO_NODE;
708 NEST (z) = NO_NODE;
709 NON_LOCAL (z) = NO_TABLE;
710 TAX (z) = NO_TAG;
711 SEQUENCE (z) = NO_NODE;
712 PACK (z) = NO_PACK;
713 return z;
714 }
715
716 //! @brief New_symbol_table.
717
718 TABLE_T *new_symbol_table (TABLE_T * p)
719 {
720 TABLE_T *z = (TABLE_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (TABLE_T));
721 NUM (z) = A68 (symbol_table_count);
722 LEVEL (z) = A68 (symbol_table_count)++;
723 NEST (z) = A68 (symbol_table_count);
724 ATTRIBUTE (z) = 0;
725 AP_INCREMENT (z) = 0;
726 INITIALISE_FRAME (z) = A68_TRUE;
727 PROC_OPS (z) = A68_TRUE;
728 INITIALISE_ANON (z) = A68_TRUE;
729 PREVIOUS (z) = p;
730 OUTER (z) = NO_TABLE;
731 IDENTIFIERS (z) = NO_TAG;
732 OPERATORS (z) = NO_TAG;
733 PRIO (z) = NO_TAG;
734 INDICANTS (z) = NO_TAG;
735 LABELS (z) = NO_TAG;
736 ANONYMOUS (z) = NO_TAG;
737 JUMP_TO (z) = NO_NODE;
738 SEQUENCE (z) = NO_NODE;
739 return z;
740 }
741
742 //! @brief New_moid.
743
744 MOID_T *new_moid (void)
745 {
746 MOID_T *z = (MOID_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (MOID_T));
747 A68 (new_modes)++;
748 ATTRIBUTE (z) = 0;
749 NUMBER (z) = 0;
750 DIM (z) = 0;
751 USE (z) = A68_FALSE;
752 HAS_ROWS (z) = A68_FALSE;
753 SIZE (z) = 0;
754 DIGITS (z) = 0;
755 SIZEC (z) = 0;
756 DIGITSC (z) = 0;
757 PORTABLE (z) = A68_TRUE;
758 DERIVATE (z) = A68_FALSE;
759 NODE (z) = NO_NODE;
760 PACK (z) = NO_PACK;
761 SUB (z) = NO_MOID;
762 EQUIVALENT_MODE (z) = NO_MOID;
763 SLICE (z) = NO_MOID;
764 TRIM (z) = NO_MOID;
765 DEFLEXED (z) = NO_MOID;
766 NAME (z) = NO_MOID;
767 MULTIPLE_MODE (z) = NO_MOID;
768 NEXT (z) = NO_MOID;
769 return z;
770 }
771
772 //! @brief New_pack.
773
774 PACK_T *new_pack (void)
775 {
776 PACK_T *z = (PACK_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (PACK_T));
777 MOID (z) = NO_MOID;
778 TEXT (z) = NO_TEXT;
779 NODE (z) = NO_NODE;
780 NEXT (z) = NO_PACK;
781 PREVIOUS (z) = NO_PACK;
782 SIZE (z) = 0;
783 OFFSET (z) = 0;
784 return z;
785 }
786
787 //! @brief New_tag.
788
789 TAG_T *new_tag (void)
790 {
791 TAG_T *z = (TAG_T *) get_fixed_heap_space ((size_t) SIZE_ALIGNED (TAG_T));
792 STATUS (z) = NULL_MASK;
793 CODEX (z) = NULL_MASK;
794 TAG_TABLE (z) = NO_TABLE;
795 MOID (z) = NO_MOID;
796 NODE (z) = NO_NODE;
797 UNIT (z) = NO_NODE;
798 VALUE (z) = NO_TEXT;
799 A68_STANDENV_PROC (z) = 0;
800 PROCEDURE (z) = NO_GPROC;
801 SCOPE (z) = PRIMAL_SCOPE;
802 SCOPE_ASSIGNED (z) = A68_FALSE;
803 PRIO (z) = 0;
804 USE (z) = A68_FALSE;
805 IN_PROC (z) = A68_FALSE;
806 HEAP (z) = A68_FALSE;
807 SIZE (z) = 0;
808 OFFSET (z) = 0;
809 YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE;
810 LOC_ASSIGNED (z) = A68_FALSE;
811 NEXT (z) = NO_TAG;
812 BODY (z) = NO_TAG;
813 PORTABLE (z) = A68_TRUE;
814 NUMBER (z) = ++A68_PARSER (tag_number);
815 return z;
816 }
817
818 //! @brief Make special, internal mode.
819
820 void make_special_mode (MOID_T ** n, int m)
821 {
822 (*n) = new_moid ();
823 ATTRIBUTE (*n) = 0;
824 NUMBER (*n) = m;
825 PACK (*n) = NO_PACK;
826 SUB (*n) = NO_MOID;
827 EQUIVALENT (*n) = NO_MOID;
828 DEFLEXED (*n) = NO_MOID;
829 NAME (*n) = NO_MOID;
830 SLICE (*n) = NO_MOID;
831 TRIM (*n) = NO_MOID;
832 ROWED (*n) = NO_MOID;
833 }
834
835 //! @brief Whether x matches c; case insensitive.
836
837 BOOL_T match_string (char *x, char *c, char alt)
838 {
839 BOOL_T match = A68_TRUE;
840 while ((IS_UPPER (c[0]) || IS_DIGIT (c[0]) || c[0] == '-') && match) {
841 match = (BOOL_T) (match & (TO_LOWER (x[0]) == TO_LOWER ((c++)[0])));
842 if (!(x[0] == NULL_CHAR || x[0] == alt)) {
843 x++;
844 }
845 }
846 while (x[0] != NULL_CHAR && x[0] != alt && c[0] != NULL_CHAR && match) {
847 match = (BOOL_T) (match & (TO_LOWER ((x++)[0]) == TO_LOWER ((c++)[0])));
848 }
849 return (BOOL_T) (match ? (x[0] == NULL_CHAR || x[0] == alt) : A68_FALSE);
850 }
851
852 //! @brief Whether attributes match in subsequent nodes.
853
854 BOOL_T whether (NODE_T * p, ...)
855 {
856 va_list vl;
857 int a;
858 va_start (vl, p);
859 while ((a = va_arg (vl, int)) != STOP)
860 {
861 if (p != NO_NODE && a == WILDCARD) {
862 FORWARD (p);
863 } else if (p != NO_NODE && (a == KEYWORD)) {
864 if (find_keyword_from_attribute (A68 (top_keyword), ATTRIBUTE (p)) != NO_KEYWORD) {
865 FORWARD (p);
866 } else {
867 va_end (vl);
868 return A68_FALSE;
869 }
870 } else if (p != NO_NODE && (a >= 0 ? a == ATTRIBUTE (p) : (-a) != ATTRIBUTE (p))) {
871 FORWARD (p);
872 } else {
873 va_end (vl);
874 return A68_FALSE;
875 }
876 }
877 va_end (vl);
878 return A68_TRUE;
879 }
880
881 //! @brief Whether one of a series of attributes matches a node.
882
883 BOOL_T is_one_of (NODE_T * p, ...)
884 {
885 if (p != NO_NODE) {
886 va_list vl;
887 int a;
888 BOOL_T match = A68_FALSE;
889 va_start (vl, p);
890 while ((a = va_arg (vl, int)) != STOP)
891 {
892 match = (BOOL_T) (match | (BOOL_T) (IS (p, a)));
893 }
894 va_end (vl);
895 return match;
896 } else {
897 return A68_FALSE;
898 }
899 }
900
901 //! @brief Isolate nodes p-q making p a branch to p-q.
902
903 void make_sub (NODE_T * p, NODE_T * q, int t)
904 {
905 NODE_T *z = new_node ();
906 ABEND (p == NO_NODE || q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
907 *z = *p;
908 if (GINFO (p) != NO_GINFO) {
909 GINFO (z) = new_genie_info ();
910 }
911 PREVIOUS (z) = NO_NODE;
912 if (p == q) {
913 NEXT (z) = NO_NODE;
914 } else {
915 if (NEXT (p) != NO_NODE) {
916 PREVIOUS (NEXT (p)) = z;
917 }
918 NEXT (p) = NEXT (q);
919 if (NEXT (p) != NO_NODE) {
920 PREVIOUS (NEXT (p)) = p;
921 }
922 NEXT (q) = NO_NODE;
923 }
924 SUB (p) = z;
925 ATTRIBUTE (p) = t;
926 }
927
928 //! @brief Find symbol table at level 'i'.
929
930 TABLE_T *find_level (NODE_T * n, int i)
931 {
932 if (n == NO_NODE) {
933 return NO_TABLE;
934 } else {
935 TABLE_T *s = TABLE (n);
936 if (s != NO_TABLE && LEVEL (s) == i) {
937 return s;
938 } else if ((s = find_level (SUB (n), i)) != NO_TABLE) {
939 return s;
940 } else if ((s = find_level (NEXT (n), i)) != NO_TABLE) {
941 return s;
942 } else {
943 return NO_TABLE;
944 }
945 }
946 }
947
948 //! @brief Whether 'p' is top of lexical level.
949
950 BOOL_T is_new_lexical_level (NODE_T * p)
951 {
952 switch (ATTRIBUTE (p)) {
953 case ALT_DO_PART:
954 case BRIEF_ELIF_PART:
955 case BRIEF_OUSE_PART:
956 case BRIEF_CONFORMITY_OUSE_PART:
957 case CHOICE:
958 case CLOSED_CLAUSE:
959 case CONDITIONAL_CLAUSE:
960 case DO_PART:
961 case ELIF_PART:
962 case ELSE_PART:
963 case FORMAT_TEXT:
964 case CASE_CLAUSE:
965 case CASE_CHOICE_CLAUSE:
966 case CASE_IN_PART:
967 case CASE_OUSE_PART:
968 case OUT_PART:
969 case ROUTINE_TEXT:
970 case SPECIFIED_UNIT:
971 case THEN_PART:
972 case UNTIL_PART:
973 case CONFORMITY_CLAUSE:
974 case CONFORMITY_CHOICE:
975 case CONFORMITY_IN_PART:
976 case CONFORMITY_OUSE_PART:
977 case WHILE_PART:
978 {
979 return A68_TRUE;
980 }
981 default:
982 {
983 return A68_FALSE;
984 }
985 }
986 }
987
988 //! @brief Some_node.
989
990 NODE_T *some_node (char *t)
991 {
992 NODE_T *z = new_node ();
993 INFO (z) = new_node_info ();
994 GINFO (z) = new_genie_info ();
995 NSYMBOL (z) = t;
996 return z;
997 }
