1 /****^  ***********************************************************
 2         *                                                         *
 3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
 4         *                                                         *
 5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
 6         *                                                         *
 7         * Copyright (c) 1972 by Massachusetts Institute of        *
 8         * Technology and Honeywell Information Systems, Inc.      *
 9         *                                                         *
10         *********************************************************** */
11 
12 
13 
14 
15 /****^  HISTORY COMMENTS:
16   1) change(91-01-09,Blackmore), approve(91-01-09,MCR8234),
17      audit(91-12-05,Huen), install(92-04-24,MR12.5-1011):
18      Change calls to 'lex', 'lex$write_last_line', and 'statement_type', for
19      constant reference resolution fix.
20                                                    END HISTORY COMMENTS */
21 
22 
23 /*        Modified on:        2 October 1970 by PG for Version II.
24           Modified on:        24 October 1980 by M. N. Davidoff for -prefix.
25           Modified 831021 BIM to get a full symbol table by setting root -> block.get_data.
26 */
27 /* format: style3 */
28 parse:
29      procedure (root, source_string, prefix);
30 
31 /* parameter */
32 
33 dcl       root                ptr;
34 dcl       source_string       char (*);
35 dcl       1 prefix            aligned,
36             2 mask            bit (12),
37             2 conditions      bit (12);
38 
39 /* automatic */
40 
41 dcl       conditions          bit (12) aligned;
42 dcl       end_ptr             ptr;
43 dcl       entry_ptr           ptr;
44 dcl       index               fixed bin (15);
45 dcl       p                   ptr;
46 
47 /* builtin */
48 
49 dcl       (addr, binary, length, null)
50                               builtin;
51 
52 /* external static */
53 
54 dcl       pl1_stat_$compiler_created_index
55                               fixed bin external static;
56 dcl       pl1_stat_$error_memory
57                               bit (504) aligned external static;
58 dcl       pl1_stat_$one       pointer external static;
59 dcl       pl1_stat_$util_abort
60                               entry variable external static;
61 dcl       pl1_stat_$generate_symtab bit (1) aligned external static;
62 ^L
63 %include token_types;
64 %include statement_types;
65 %include block_types;
66 %include block;
67 %include parse;
68 ^L
69 /* program */
70 
71           pl1_stat_$compiler_created_index = 0;
72           pl1_stat_$error_memory = ""b;
73           pl1_stat_$util_abort = parse_error;
74           call error_$initialize_error;
75           end_ptr = reserve$clear ();
76           root, p = create_block (root_block, null);
77           p -> block.get_data = pl1_stat_$generate_symtab;
78           conditions = p -> block.prefix & ^prefix.mask | prefix.conditions;
79 
80           call lex$initialize_lex (addr (source_string), length (source_string));
81           pl1_stat_$one = create_token ("1", dec_integer);
82           call lex(p);
83 
84           index = 1;
85           entry_ptr, end_ptr = null;
86 
87           if statement_type (p, index, entry_ptr, conditions) = binary (procedure_statement, 9)
88           then do;
89                     call procedure_parse (index, entry_ptr, conditions, p, end_ptr, external_procedure, "0"b);
90                     if end_ptr ^= null
91                     then call parse_error (417, end_ptr);   /* unmatched labeled end statement */
92                end;
93           else call parse_error (180, null);                /* no procedure statement */
94 
95           call lex$write_last_line(p);
96      end parse;