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