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 call to 'statement_type', for constant reference resolution fix.
 19                                                    END HISTORY COMMENTS */
 20 
 21 
 22 /*        This procedure parses on statements, and on units.  If the on unit
 23           is an unlabeled block, a call is made to procedure_parse with the
 24           block_type set to "on_unit".
 25 
 26           Written by:         J. D. Mills, 29 May 1968
 27           Re-written by:      P. Green 4 December 1970, for Version II
 28           Modified by:        R. A. Barnes 1 November 1973 for snap & system
 29           Modified by:        RAB 10 February 1977 for multiple condition names
 30           Modified on:        21 March 1980 by M. N. Davidoff to fix 1948 in which on units consisting of begin blocks which
 31                               are implicitly closed by an end statement with a closure label are parsed incorrectly.  This
 32                               procedure must pass closure label information back to its caller.
 33 */
 34 /* format: style3 */
 35 on_parse:
 36      procedure (k, entry_ptr, our_conditions, father_block, his_end_ptr);
 37 
 38 dcl       (j, k, type)        fixed bin (15);
 39 dcl       (entry_ptr, father_block, his_end_ptr, end_ptr, cblock, cond_ptr, label_ptr, statement_ptr)
 40                               ptr;
 41 dcl       (on, p, q, r, t)    ptr;
 42 
 43 dcl       pl1_stat_$condition_index
 44                               fixed bin (15) ext static;
 45 dcl       (conditions, our_conditions)
 46                               bit (12) aligned;
 47 
 48 dcl       action_index        (0:36) fixed bin (15) int static
 49                               init (0, 0, 0, 1, 0, 4, 2, 4, 4, 0, 2, 2, 2, 2, 0, 2, 0, 4, 0, 2, 4, 0, 2, 4, 2, 4, 4, 2, 2, 4,
 50                               0, 0, 3, 4, 0, 4, 2);
 51 
 52 dcl       io_condition        (8) char (16) varying int static
 53                               init ("undf", "undefinedfile", "endfile", "endpage", "key", "name", "record", "transmit");
 54 
 55 dcl       (binary, bit, null) builtin;
 56 
 57 %include parse;
 58 %include block;
 59 %include block_types;
 60 %include context_codes;
 61 %include declare_type;
 62 %include list;
 63 %include nodes;
 64 %include op_codes;
 65 %include operator;
 66 %include reference;
 67 %include statement;
 68 %include statement_types;
 69 %include symbol;
 70 %include token;
 71 %include token_list;
 72 %include token_types;
 73 ^L
 74 /* program */
 75 
 76           his_end_ptr = null;
 77           label_ptr = entry_ptr;
 78 
 79 /* create on unit block */
 80 
 81           cblock = create_block (on_unit, father_block);
 82 
 83 cond_loop:
 84           on = create_statement (on_statement, father_block, label_ptr, our_conditions);
 85                                                             /* create on statement in outer block. */
 86           if label_ptr ^= null
 87           then do;
 88                     call declare_label (father_block, on, label_ptr, by_explicit_context);
 89                     label_ptr = null;
 90                end;
 91 
 92           k = k + 1;
 93 
 94           if ^get_condition (cond_ptr)
 95           then go to error_recover;
 96 
 97           on -> statement.root, q = create_operator (enable_on, 3);
 98 
 99           if cond_ptr -> node.type = token_node
100           then q -> operand (1) = cond_ptr;
101           else do;
102                     q -> operand (2) = cond_ptr -> reference.offset -> list.element (1);
103                     q -> operand (1), cond_ptr = cond_ptr -> reference.symbol;
104                end;
105 
106           pl1_stat_$condition_index = pl1_stat_$condition_index + 1;
107           q -> operator.operand (3) = cblock;
108 
109           if t_table.type = comma
110           then go to cond_loop;
111 
112 /* create entry sequence */
113 
114           q = create_statement (procedure_statement, cblock, null, (12)"0"b);
115           q -> statement.root = create_operator (std_entry, 0);
116           q -> statement.labels = create_list (2);
117           t = create_token (cond_ptr -> token.string || "." || bindec$vs ((pl1_stat_$condition_index)), identifier);
118           p = create_symbol (father_block, t, by_compiler);
119           p -> symbol.entry, p -> symbol.internal, p -> symbol.constant = "1"b;
120           p -> symbol.equivalence = cblock;
121           p -> symbol.initial = q;
122           q -> statement.labels -> list.element (2) = p -> symbol.reference;
123 
124           if t_table.string = "snap"
125           then do;
126 
127 /* Save k and find token following first reference-like formation.  The cases are these:
128 
129              for j>k+1:
130                     on error snap(.......) :      snap - (condition prefix)
131                     on error snap(.......) XX     no_snap
132                     on error snap->......         no_snap
133 
134              for j=k+1:
135                     on error snap=                no_snap
136                     on error snap,                no_snap
137                     on error snap:                no_snap - BUG moreover
138                     on error snap XX              snap
139 */
140 
141                     j = k;
142                     r = reference_parse (j, cblock);
143 
144                     if (j <= k + 1 | token_list (j) -> token.type = colon) & token_list (j) -> token.type ^= comma
145                          & token_list (j) -> token.type ^= colon & token_list (j) -> token.type ^= assignment
146                     then do;
147                               on -> statement.snap = "1"b;
148                               k = k + 1;
149                          end;
150 
151                     call free_node (r);
152                end;
153 
154           conditions = father_block -> block.prefix;        /* default conditions for imbedded statement. */
155           type = statement_type (cblock, k, label_ptr, conditions);
156 
157           q -> statement.prefix, cblock -> block.prefix = conditions;
158           if label_ptr ^= null
159           then do;
160                     call parse_error (421, null);           /* no labels in on-unit. */
161                     label_ptr = null;
162                end;
163 
164           go to action (action_index (type));
165 
166 /* ************** IO statements ************************ */
167 
168 action (4):
169           call io_statement_parse (k, label_ptr, conditions, cblock, end_ptr, "1"b, bit (binary (type, 9, 0)));
170           goto end_up;
171 
172 /*        ************* Begin statement ************************************************ */
173 
174 action (1):
175           call procedure_parse (k, label_ptr, conditions, cblock, his_end_ptr, on_unit, "1"b /* no return statements */);
176           return;
177 
178 /*        ************* Illegal statements ********************************************* */
179 
180 action (2):
181           call parse_error (423, null);                     /*  illegal statement in on-unit. */
182           go to end_up;
183 
184 /*        ************* Statements all parsed in statement_parse *********************** */
185 
186 action (0):
187           call statement_parse (k, label_ptr, conditions, cblock, type);
188           go to end_up;
189 
190 /*        ************* System on-unit ************************************************* */
191 
192 action (3):
193           on -> statement.system = "1"b;
194 
195           if token_list (k + 1) -> token.type ^= semi_colon
196           then call parse_error (422, token_list (k + 1));
197 
198 end_up:
199           p = create_statement (end_statement, cblock, null, conditions);
200           p -> statement.root = create_operator (std_return, 0);
201 
202           return;
203 ^L
204 revert:
205      entry (k, statement_ptr, father_block);
206 
207 dcl       opcode              bit (9) aligned;
208 
209           on = statement_ptr;
210 
211           if statement_ptr -> statement.statement_type = revert_statement
212           then opcode = revert_on;
213           else opcode = signal_on;
214 
215           k = k + 1;
216 
217           if get_condition (cond_ptr)
218           then do;
219                     on -> statement.root, q = create_operator (opcode, 2);
220 
221                     if cond_ptr -> node.type = token_node
222                     then q -> operand (1) = cond_ptr;
223                     else do;
224                               q -> operand (1) = cond_ptr -> reference.symbol;
225                               q -> operand (2) = cond_ptr -> reference.offset -> list.element (1);
226                          end;
227                end;
228           else goto error_recover;
229 
230           return;
231 
232 error_recover:
233           on -> statement.root = null;
234           on -> statement.statement_type = null_statement;
235           return;
236 ^L
237 get_condition:
238      proc (ref) returns (bit (1) aligned);
239 
240 dcl       (ref, t)            ptr,
241           kc                  fixed binary;
242 
243           kc = k;
244 
245           if t_table.string = "cond" | t_table.string = "condition"
246           then do;
247                     k = k + 1;
248                     if t_table.type = left_parn
249                     then do;
250                               if token_list (k + 1) -> token.type ^= identifier
251                               then goto err420;
252                               if token_list (k + 2) -> token.type ^= right_parn
253                               then goto err420;
254                               kc = k + 1;
255                               k = k + 3;
256                          end;
257                     t, ref = token_list (kc);
258                end;
259           else do;
260                     do j = 1 to 8 while (io_condition (j) ^= t_table.string);
261                     end;
262                     if j < 9
263                     then do;
264                               ref = reference_parse (k, father_block);
265                               if ref = null
266                               then go to err420;
267 
268                               if ref -> node.type ^= reference_node
269                               then go to err420;
270 
271                               if ref -> reference.qualifier ^= null | ref -> reference.length ^= null
272                               then go to err420;
273 
274                               if ref -> reference.offset -> list.number ^= 1
275                               then go to err420;
276 
277                               call context ((ref -> reference.offset -> list.element (1)), father_block, file_name_context);
278                               t = ref -> reference.symbol;  /* ptr to token node */
279                          end;
280                     else do;
281                               t, ref = token_list (kc);
282                               k = k + 1;
283                          end;
284                end;
285 
286           call context (t, father_block, condition_context);
287           return ("1"b);
288 
289 err420:
290           call parse_error (420, null);
291           return ("0"b);
292      end get_condition;
293 
294      end on_parse;