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-18,Blackmore), approve(91-01-18,MCR8234),
 17      audit(91-12-05,Huen), install(92-04-24,MR12.5-1011):
 18      Change calls to 'lex' and 'statement_type', for constant reference
 19      resolution fix.
 20                                                    END HISTORY COMMENTS */
 21 
 22 
 23 /* Note well:       The declarations and all statements after the label
 24                     "get_next_statement" are copied from procedure_parse,
 25                     and any changes made to either must be made to both.
 26 
 27           Written on:         22 October 1970 by Paul Green for Version II
 28           Modified:           9 February 1978 by Richard Barnes to fix 1699
 29           Modified:           21 March 1980 by M. N. Davidoff to print warnings for multiple closure end statements and
 30                               to diagnose "do while(exp,exp);".
 31 */
 32 /* format: style3 */
 33 do_parse:
 34      proc (k, entry_ptr, our_conditions, father_block, his_end_ptr, our_entry_flag, our_return_flag, in_iterative_do);
 35 
 36 dcl       (do, ref, spec)     ptr;
 37 dcl       (p, q, entry_ptr, label_ptr, end_ptr, cur_block, father_block, his_end_ptr)
 38                               ptr;
 39 dcl       do_statement_node   ptr;
 40 dcl       (k, i, type)        fixed bin (15);
 41 dcl       (conditions, our_conditions)
 42                               bit (12) aligned;
 43 dcl       (our_entry_flag, entry_flag, return_flag, our_return_flag, in_iterative_do, iterative_do_entered)
 44                               bit (1) aligned;
 45 
 46 dcl       pl1_stat_$cur_statement
 47                               ptr ext static;
 48 
 49 dcl       (binary, bit, null) builtin;
 50 
 51 dcl       action_index        (0:36) fixed bin (15) int static
 52                               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,
 53                               0, 0, 10, 0, 0, 0, 10, 0, 10, 9);
 54 
 55 %include parse;
 56 %include token_list;
 57 %include block;
 58 %include op_codes;
 59 %include operator;
 60 %include statement;
 61 %include token;
 62 %include block_types;
 63 %include statement_types;
 64 %include token_types;
 65 %include list;
 66 %include label;
 67 %include reference;
 68 %include declare_type;
 69 ^L
 70 /* program */
 71 
 72           conditions = our_conditions;
 73           cur_block = father_block;
 74           return_flag = our_return_flag;
 75           entry_flag = our_entry_flag;
 76           iterative_do_entered = in_iterative_do;
 77 
 78           spec = null;
 79 
 80           pl1_stat_$cur_statement, p,
 81                do_statement_node = create_statement (do_statement, father_block, entry_ptr, conditions);
 82           if entry_ptr ^= null
 83           then call declare_label (father_block, p, entry_ptr, by_explicit_context);
 84 
 85           do, p -> statement.root = create_operator (do_fun, 3);
 86           i, k = k + 1;
 87           if t_table.type = semi_colon
 88           then goto get_next_statement;                     /* this is a "do;" statement */
 89 
 90 /* for iterative do statements we need a null statement with the same source id as the do statement preceding the do statement
 91    so that correct code will be generated in processing function references needing descriptors.  This fixes bug 1699. */
 92 
 93           p -> statement.root = null;
 94           p -> statement.statement_type = null_statement;
 95           pl1_stat_$cur_statement, p, do_statement_node = create_statement (do_statement, father_block, null, conditions);
 96           p -> statement.root = do;
 97 
 98 /* each <do specification> is represented by a do_spec operator */
 99 
100           spec, do -> operand (3) = create_operator (do_spec, 6);
101           ref = reference_parse (k, cur_block);
102 
103           if ref = null
104           then call print (406);
105 
106           if token_list (i) -> token.string = "while"
107           then if t_table.type = semi_colon
108                then do;                                     /* this is a "do while(...)" clause */
109 
110 /* pick up expression from reference node */
111 
112                          if ref -> reference.offset -> list.number ^= 1
113                          then call parse_error (405, null);
114 
115                          spec -> operand (5) = ref -> reference.offset -> list.element (1);
116                          ref -> reference.offset = null;    /* don't free expression */
117                          call free_node (ref);
118                          go to get_next_statement;
119                     end;
120                else if t_table.type = comma
121                then call print (406);
122 
123           do -> operand (2) = ref;
124 
125           if t_table.type ^= assignment
126           then call print (407);
127 
128           k = k + 1;
129 
130 spec_loop:
131           spec -> operand (1) = expression_parse (k, cur_block);
132           if spec -> operand (1) = null
133           then call print (408);
134 
135 to_by_loop:
136           if t_table.string = "to"
137           then do;
138                     k = k + 1;
139                     if spec -> operand (2) ^= null
140                     then call print (409);
141                     spec -> operand (2) = expression_parse (k, cur_block);
142                     if spec -> operand (2) = null
143                     then call print (418);
144                     iterative_do_entered = "1"b;
145                end;
146 
147           if t_table.string = "by"
148           then do;
149                     k = k + 1;
150                     if spec -> operand (3) ^= null
151                     then call print (419);
152                     spec -> operand (3) = expression_parse (k, cur_block);
153                     if spec -> operand (3) = null
154                     then call print (424);
155                     iterative_do_entered = "1"b;
156                     go to to_by_loop;
157                end;
158 
159           if t_table.string = "repeat"
160           then do;
161                     k = k + 1;
162                     if spec -> operand (2) ^= null | spec -> operand (3) ^= null
163                     then call print (433);
164                     spec -> operand (4) = expression_parse (k, cur_block);
165                     if spec -> operand (4) = null
166                     then call print (429);
167                     iterative_do_entered = "1"b;
168                end;
169 
170           if t_table.string = "while"
171           then do;
172                     k = k + 1;
173                     if t_table.type ^= left_parn
174                     then call parse_error (404, null);
175                     else k = k + 1;
176                     spec -> operand (5) = expression_parse (k, cur_block);
177                     if spec -> operand (5) = null
178                     then call print (426);
179                     if t_table.type ^= right_parn
180                     then call parse_error (405, null);
181                     else k = k + 1;
182                end;
183 
184           if t_table.type = comma
185           then do;
186                     k = k + 1;
187                     spec -> operand (6), spec = create_operator (do_spec, 6);
188                     go to spec_loop;
189                end;
190 
191           if t_table.type ^= semi_colon
192           then call print (425);
193 
194 get_next_statement:
195           call lex(cur_block);
196 
197 get_statement_type:
198           conditions = cur_block -> block.prefix;
199           k = 1;                                            /* first token */
200           type = statement_type (cur_block, k, label_ptr, conditions);
201           go to action (action_index (type));
202 
203 /*        ***************** Statements requiring individual parsing procedures. ******** */
204 
205 action (10):                                                /* io statements */
206           call io_statement_parse (k, label_ptr, conditions, cur_block, end_ptr, return_flag, bit (binary (type, 9, 0)));
207           goto compound_parse_return;
208 
209 action (1):                                                 /* begin statement  */
210           call procedure_parse (k, label_ptr, conditions, cur_block, end_ptr, begin_block, return_flag);
211           go to compound_parse_return;
212 
213 action (2):                                                 /* declare statement */
214           call declare_parse (k, cur_block, label_ptr);
215           go to get_next_statement;
216 
217 action (9):                                                 /* default statement */
218           call default_parse (k, cur_block, label_ptr);
219           go to get_next_statement;
220 
221 action (3):                                                 /* do statement     */
222           call do_parse (k, label_ptr, conditions, cur_block, end_ptr, entry_flag, return_flag, iterative_do_entered);
223           go to compound_parse_return;
224 
225 action (5):                                                 /* if statement     */
226           call if_parse (k, label_ptr, conditions, cur_block, end_ptr, return_flag);
227           if end_ptr = null
228           then go to get_statement_type;
229           go to end_proc;
230 
231 action (6):                                                 /* on statement     */
232           call on_parse (k, label_ptr, conditions, cur_block, end_ptr);
233           go to compound_parse_return;
234 
235 action (7):                                                 /* proc statement   */
236           call procedure_parse (k, label_ptr, conditions, cur_block, end_ptr, internal_procedure, "0"b);
237 
238 compound_parse_return:
239           if end_ptr = null
240           then go to get_next_statement;
241           go to end_proc;
242 
243 /*        ***************** Statements which may be in error. ************************** */
244 
245 action (8):                                                 /* entry statement  */
246           if iterative_do_entered | entry_flag
247           then do;
248                     call parse_error (413 - 2 * binary (entry_flag, 1), null);
249                     go to get_next_statement;
250                end;
251 
252           k = k + 1;
253           call process_entry (k, entry_statement, cur_block, label_ptr, conditions);
254           go to get_next_statement;
255 
256 /*        ***************** Statements all parsed in statement_parse.******************* */
257 
258 
259 action (0):
260           call statement_parse (k, label_ptr, conditions, cur_block, type);
261           go to get_next_statement;
262 
263 /*        ***************** Statement processed in line. ******************************* */
264 
265 action (4):                                                 /* end statement    */
266           k = k + 1;
267           if t_table.type = identifier
268           then do;
269                     end_ptr = token_list (k);
270                     k = k + 1;
271                end;
272           else end_ptr = null;
273           if t_table.type ^= semi_colon
274           then call parse_error (416, token_list (k));
275 
276 end_proc:
277           conditions = cur_block -> block.prefix;
278           q = create_statement (end_statement, cur_block, null, conditions);
279 
280           if end_ptr ^= null
281           then do;
282                     do p = entry_ptr repeat p -> list.element (1) while (p ^= null);
283                          if end_ptr = p -> list.element (2)
284                          then go to ck_labels;
285                     end;
286 
287                     if type = binary (end_statement, 9)
288                     then call parse_error (377, null);
289 
290                     call error (384, do_statement_node, null);
291 
292                     his_end_ptr = end_ptr;                  /* ends this block and previous blocks */
293                     entry_ptr = label_ptr;                  /* any prefix labels get passed back up.  */
294                     go to finish;
295                end;
296 
297 ck_labels:
298           his_end_ptr = null;                               /* ended this block only, even if we were given labels */
299           if label_ptr ^= null
300           then do;
301                     call declare_label (cur_block, q, label_ptr, by_explicit_context);
302                     q -> statement.labels = label_ptr;
303                end;
304 
305 finish:                                                     /* close the do statement with a label */
306           p = create_label (cur_block, null, by_compiler);
307           do -> operand (1) = p;
308           p -> label.statement = q;
309           ref = create_list (2);
310           ref -> list.element (2) = p -> label.token;
311           ref -> list.element (1) = q -> statement.labels;
312           q -> statement.labels = ref;
313           return;
314 
315 print:
316      proc (m);                                              /* prints error messages */
317 
318 dcl       m                   fixed bin (15);
319 
320           call parse_error (m, null);
321           if spec ^= null
322           then do;
323                     spec -> operand (1), spec -> operand (2), spec -> operand (3), spec -> operand (4), spec -> operand (5),
324                          spec -> operand (6) = null;
325                end;
326           go to get_next_statement;
327 
328      end print;
329 
330      end do_parse;