1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26 Note
27
28
29
30
31
32
33
34
35
36
37
38
39
40 procedure_parse:
41 proc (k, entry_ptr, our_conditions, father_block, his_end_ptr, block_type, our_return_flag);
42
43 dcl block_type bit (9) aligned;
44 dcl (p, q, entry_ptr, label_ptr, end_ptr, cur_block, father_block, his_end_ptr)
45 ptr;
46 dcl (k, type) fixed bin (15);
47 dcl (conditions, our_conditions)
48 bit (12) aligned;
49 dcl (begin_entered, return_flag, our_return_flag)
50 bit (1) aligned;
51
52 dcl pl1_stat_$cur_statement
53 ptr ext static;
54 dcl pl1_stat_$check_ansi
55 bit (1) aligned ext static;
56 dcl (binary, bit, null) builtin;
57
58 dcl action_index (0:36) fixed bin (15) int static
59 init (0, 0, 0, 1, 0, 10, 2, 10, 10, 0, 3, 0, 4, 8, 0, 10, 0, 10, 0, 5, 10, 0, 6, 10, 7, 10, 10,
60 8, 0, 10, 0, 0, 0, 10, 0, 10, 9);
61
62 %include parse;
63 %include token_list;
64 %include block;
65 %include declare_type;
66 %include op_codes;
67 %include statement;
68 %include token;
69 %include block_types;
70 %include statement_types;
71 %include token_types;
72 %include list;
73 ^L
74
75
76 return_flag = our_return_flag;
77 conditions = our_conditions;
78
79 if block_type = on_unit
80 then do;
81 begin_entered = "1"b;
82 cur_block = father_block;
83 cur_block -> block.prefix = conditions;
84 call begin_parse;
85 end;
86
87 else if block_type = begin_block
88 then do;
89 begin_entered = "1"b;
90
91 pl1_stat_$cur_statement, p = create_statement (begin_statement, father_block, entry_ptr, our_conditions);
92 if entry_ptr ^= null
93 then call declare_label (father_block, p, entry_ptr, by_explicit_context);
94
95 p -> statement.root, cur_block = create_block (block_type, father_block);
96 cur_block -> block.prefix = conditions;
97
98 call begin_parse;
99
100
101
102
103 q = create_statement (null_statement, cur_block, null, conditions);
104 end;
105
106 else do;
107 begin_entered = "0"b;
108 cur_block = create_block (block_type, father_block);
109 cur_block -> block.prefix = conditions;
110 call process_entry (k + 1, procedure_statement, cur_block, entry_ptr, conditions);
111 end;
112
113 get_next_statement:
114 call lex(cur_block);
115
116 get_statement_type:
117 conditions = cur_block -> block.prefix;
118
119 k = 1;
120 type = statement_type (cur_block, k, label_ptr, conditions);
121 go to action (action_index (type));
122
123
124
125 action (1):
126 call procedure_parse (k, label_ptr, conditions, cur_block, end_ptr, begin_block, return_flag);
127 go to compound_parse_return;
128
129 action (10):
130 call io_statement_parse (k, label_ptr, conditions, cur_block, end_ptr, return_flag, bit (binary (type, 9, 0)));
131 goto compound_parse_return;
132
133
134 action (2):
135 call declare_parse (k, cur_block, label_ptr);
136 go to get_next_statement;
137 action (9):
138 call default_parse (k, cur_block, label_ptr);
139 go to get_next_statement;
140
141 action (3):
142 call do_parse (k, label_ptr, conditions, cur_block, end_ptr, begin_entered, return_flag, "0"b);
143 go to compound_parse_return;
144
145 action (5):
146 call if_parse (k, label_ptr, conditions, cur_block, end_ptr, return_flag);
147 if end_ptr = null
148 then go to get_statement_type;
149 go to end_proc;
150
151 action (6):
152 call on_parse (k, label_ptr, conditions, cur_block, end_ptr);
153 go to compound_parse_return;
154
155 action (7):
156 call procedure_parse (k, label_ptr, conditions, cur_block, end_ptr, internal_procedure, "0"b);
157
158 compound_parse_return:
159 if end_ptr = null
160 then go to get_next_statement;
161 go to end_proc;
162
163
164
165 action (8):
166 if begin_entered
167 then if type = binary (entry_statement, 9, 0)
168 then do;
169 call parse_error (411, null);
170 go to get_next_statement;
171 end;
172 else if return_flag
173 then do;
174 call parse_error (412, null);
175 go to get_next_statement;
176 end;
177
178 if type = binary (entry_statement, 9, 0)
179 then do;
180 k = k + 1;
181 call process_entry (k, entry_statement, cur_block, label_ptr, conditions);
182 go to get_next_statement;
183 end;
184
185
186
187
188 action (0):
189 call statement_parse (k, label_ptr, conditions, cur_block, type);
190 go to get_next_statement;
191
192
193
194 action (4):
195 k = k + 1;
196 if t_table.type = identifier
197 then do;
198 end_ptr = token_list (k);
199 k = k + 1;
200 end;
201 else end_ptr = null;
202 if t_table.type ^= semi_colon
203 then call parse_error (416, token_list (k));
204
205 end_proc:
206 conditions = cur_block -> block.prefix;
207
208 q = create_statement (end_statement, cur_block, null, conditions);
209 q -> statement.root = create_operator (std_return, 0);
210
211 if end_ptr ^= null
212 then do;
213 do p = entry_ptr repeat p -> list.element (1) while (p ^= null);
214 if end_ptr = p -> list.element (2)
215 then go to ck_labels;
216 end;
217
218 if type = binary (end_statement, 9)
219 then call parse_error (377, null);
220
221 call error (384, (cur_block -> block.main), null);
222
223 his_end_ptr = end_ptr;
224 entry_ptr = label_ptr;
225 return;
226 end;
227
228 ck_labels:
229 his_end_ptr = null;
230 if label_ptr ^= null
231 then do;
232 call declare_label (cur_block, q, label_ptr, by_explicit_context);
233 q -> statement.labels = label_ptr;
234 end;
235
236 return;
237 ^L
238
239
240 begin_parse:
241 proc;
242
243 k = k + 1;
244 if t_table.type = identifier & t_table.string = "options"
245 then do;
246 if pl1_stat_$check_ansi
247 then call parse_error (355, token_list (k));
248 k = k + 1;
249 if t_table.type ^= left_parn
250 then call parse_error (38, null);
251 else do;
252 k = k + 1;
253 if t_table.string = "non_quick"
254 then do;
255 cur_block -> block.why_nonquick.options_non_quick = "1"b;
256 cur_block -> block.no_stack = "0"b;
257 k = k + 1;
258 end;
259 if t_table.type ^= right_parn
260 then call parse_error (348, token_list (k));
261
262 k = k + 1;
263 end;
264 end;
265
266 if t_table.type ^= semi_colon
267 then call parse_error (410, null);
268 end begin_parse;
269
270 end procedure_parse;