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 /*        This procedure parses all statements occuring in begin blocks and procedures.
 24           It calls itself recursively to handle nested blocks.
 25 
 26 Note well: The declarations and all statements after the label "get_next_statement" are copied in do_parse, and any changes
 27           made to either must be made to both.
 28 
 29           written by j.d. mills on 24 may 1968
 30           re-written by R.A. Freiburghouse on Aug 7, 1970 for version II
 31           modified by R.A. Barnes Feb 13, 1977 for option on begin stmt
 32           Modified on: May 24 1979 by PCK to implement options(packed_decimal)
 33           Modified on: 18 March 1980 by M. N. Davidoff to fix bug 1825.  Procedure_parse no longer sets
 34                     pl1_stat_$cur_statement on end statements.  This is consistent with do_parse.  If procedure_parse
 35                     sets pl1_stat_$cur_statement on end statements, and there is a begin block in an else clause
 36                     with a multiple closure end statement, then a call to create_statement in if_parse will fail.
 37           Modified on: 21 March 1980 by M. N. Davidoff to print warnings for multiple closure end statements.
 38 */
 39 /* format: style3 */
 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 /* program */
 75 
 76           return_flag = our_return_flag;
 77           conditions = our_conditions;
 78 
 79           if block_type = on_unit                           /* on begin block */
 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 /* to prevent a fault which might occur if the first statement in the begin block required the inserting of another statement,
101    we make the first statement of the begin block be a null */
102 
103                     q = create_statement (null_statement, cur_block, null, conditions);
104                end;
105 
106           else do;                                          /* internal or external procedure block */
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);                              /* places current statement in token_list(3000); */
115 
116 get_statement_type:
117           conditions = cur_block -> block.prefix;
118 
119           k = 1;                                            /* first token */
120           type = statement_type (cur_block, k, label_ptr, conditions);
121           go to action (action_index (type));
122 
123 /*        ***************** Statements requiring individual parsing procedures. ******** */
124 
125 action (1):                                                 /* begin statement  */
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):                                                 /* declare statement */
135           call declare_parse (k, cur_block, label_ptr);
136           go to get_next_statement;
137 action (9):                                                 /* default statement */
138           call default_parse (k, cur_block, label_ptr);
139           go to get_next_statement;
140 
141 action (3):                                                 /* do statement     */
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):                                                 /* if statement     */
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;                    /* non-null if eof */
149           go to end_proc;
150 
151 action (6):                                                 /* on statement     */
152           call on_parse (k, label_ptr, conditions, cur_block, end_ptr);
153           go to compound_parse_return;
154 
155 action (7):                                                 /* proc statement   */
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 /*        ***************** Statements which may be in error. ***************** */
164 
165 action (8):                                                 /* entry & return statements */
166           if begin_entered
167           then if type = binary (entry_statement, 9, 0)     /* entry statement */
168                then do;
169                          call parse_error (411, null);      /* entry statement not allowed in begin block */
170                          go to get_next_statement;
171                     end;
172                else if return_flag
173                then do;
174                          call parse_error (412, null);      /* return statement not allowed in on-unit begin block */
175                          go to get_next_statement;
176                     end;
177 
178           if type = binary (entry_statement, 9, 0)          /* entry statement */
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 /*        ***************** Statements all parsed in statement_parse.********************** */
186 
187 
188 action (0):
189           call statement_parse (k, label_ptr, conditions, cur_block, type);
190           go to get_next_statement;
191 
192 /*        ***************** Statement processed in line. ******************************* */
193 
194 action (4):                                                 /* end statement    */
195           k = k + 1;
196           if t_table.type = identifier
197           then do;
198                     end_ptr = token_list (k);               /* end <identifier>; */
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                                /* if "end <identifier>" closes block, */
212           then do;                                          /* check for a match at beginning. */
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;              /* match; ends us only */
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;                  /* no match, ends this block and outer block(s), */
224                     entry_ptr = label_ptr;                  /* any prefix labels get passed back up.  */
225                     return;
226                end;
227 
228 ck_labels:
229           his_end_ptr = null;                               /* "end;" -- ends this block only, even if labels exist. */
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 /* parses begin stmt after "begin" */
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);       /* bad syntax in options */
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                                                             /* invalid option */
262                               k = k + 1;
263                          end;
264                end;
265 
266           if t_table.type ^= semi_colon
267           then call parse_error (410, null);                /* illegal syntax in begin block */
268      end begin_parse;
269 
270      end procedure_parse;