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 if_parse:
 24      procedure (k, entry_ptr, our_conditions, father_block, his_end_ptr, our_return_flag);
 25 
 26 /* This procedure parses if statements and else clauses.
 27    It always returns having called lex to look at the next statement. */
 28 
 29 /* Original by:     J. D. Mills         4 June 1968
 30    to pl1:                              26 July 1969
 31    Re-written by:   P. Green            25 October 1970 for Version II
 32 
 33    Modified:        29 May 1979 by R. A. Barnes to fix bug 1829 (WARNING 56 by
 34           if <expr> then stop; else ...)
 35    Modified 790823 by PG to perform goto optimization only if -optimize was specified.
 36 */
 37 
 38 /* Variables
 39 
 40    if               ptr to if statement.
 41    expr             ptr to if statement expression.
 42    loc              ptr to label used for jump around then body.
 43    location         ptr to token of loc.
 44    t                temporary ptr.                */
 45 
 46 /* builtins */
 47 
 48 dcl       (bit, binary, null, string, substr)
 49                               builtin;
 50 
 51 /* automatic */
 52 
 53 dcl       (k, then_type, type, n)
 54                               fixed bin (15);
 55 dcl       (t, if, do, entry_ptr, label_ptr, father_block, cblock, end_ptr, his_end_ptr, p, q, expr, loc, location)
 56                               ptr;
 57 dcl       (conditions, our_conditions)
 58                               bit (12) aligned;
 59 dcl       (our_return_flag, return_flag, else, then_goto_optimized)
 60                               bit (1) aligned;
 61 dcl       (bit_type, jump_if_false, jump_if_true)
 62                               bit (9);
 63 
 64 /* external static */
 65 
 66 dcl       (
 67           pl1_stat_$cur_statement
 68                               ptr,
 69           pl1_stat_$optimize  bit (1) aligned,
 70           pl1_stat_$profile   bit (1) aligned
 71           )                   external static;
 72 
 73 /* internal static */
 74 
 75 dcl       rel_to_jump         (4:9) bit (9) internal static initial ("001011001"b,
 76                                                             /* less_than        -> jump_if_ge */
 77                               "001011000"b,                 /* greater_than     -> jump_if_le */
 78                               "001010111"b,                 /* equal            -> jump_if_ne */
 79                               "001010110"b,                 /* not_equal        -> jump_if_eq */
 80                               "001010101"b,                 /* less_or_equal    -> jump_if_gt */
 81                               "001010100"b);                /* greater_or_equal -> jump_if_lt */
 82 
 83 dcl       action_index        (0:36) fixed bin (15) int static
 84                               init (0, 0, 0, 1, 0, 7, 5, 7, 7, 0, 2, 0, 5, 5, 0, 5, 0, 7, 6, 3, 7, 0, 4, 7, 5, 7, 7, 5, 0, 7,
 85                               0, 0, 4, 7, 0, 7, 5);
 86 
 87 /* include files */
 88 
 89 %include parse;
 90 %include token_list;
 91 %include token;
 92 %include token_types;
 93 %include op_codes;
 94 %include block;
 95 %include block_types;
 96 %include statement;
 97 %include statement_types;
 98 %include nodes;
 99 %include operator;
100 %include list;
101 %include label;
102 %include declare_type;
103 ^L
104 /* program */
105 
106           then_goto_optimized, else = "0"b;
107           end_ptr = null;
108           cblock = father_block;
109           return_flag = our_return_flag;
110           conditions = our_conditions;
111 
112           pl1_stat_$cur_statement, if = create_statement (if_statement, cblock, entry_ptr, conditions);
113 
114           if entry_ptr ^= null
115           then call declare_label (cblock, if, entry_ptr, by_explicit_context);
116 
117           k = k + 1;
118           expr = expression_parse (k, cblock);
119 
120           if expr = null
121           then do;
122                     call parse_error (432, null);
123                     loc = null;
124 
125                     do while ("1"b);
126                          if t_table.type = semi_colon
127                          then do;
128                                    label_ptr = null;
129                                    type = binary (null_statement);
130                                    go to action (0);
131                               end;
132 
133                          if t_table.string = "then"
134                          then do;
135                                    k = k + 1;
136                                    go to get_statement_type;
137                               end;
138                          k = k + 1;
139                     end;
140                end;
141 
142           bit_type = ""b;
143 
144           if expr -> node.type = operator_node
145           then bit_type = expr -> operator.op_code;
146 
147           if substr (bit_type, 1, 5) = "00100"b             /* relational class */
148           then do;                                          /* change relational to jump op */
149                     jump_if_false, expr -> operator.op_code = rel_to_jump (binary (substr (bit_type, 6, 4), 4));
150                     jump_if_true = bit_type | "000010000"b;
151                end;
152           else do;
153                     q = create_operator (jump_false, 2);
154                     q -> operator.operand (2) = expr;
155                     expr = q;
156                     jump_if_true = jump_true;
157                     jump_if_false = jump_false;
158                end;
159 
160           loc = create_label (cblock, null, by_compiler);   /* label is used to jump around then clause */
161           expr -> operand (1) = loc;
162           if -> statement.root = expr;
163           location = loc -> label.token;
164 
165           if t_table.string = "then"
166           then k = k + 1;
167           else call parse_error (431, null);
168 
169 get_statement_type:
170           conditions = cblock -> block.prefix;
171           then_type, type = statement_type (cblock, k, label_ptr, conditions);
172           go to action (action_index (type));
173 
174 /*        ***************** Statements requiring individual parsing procedures. ******** */
175 
176 action (1):                                                 /* begin statement */
177           call procedure_parse (k, label_ptr, conditions, cblock, end_ptr, begin_block, return_flag);
178           go to end_up;
179 
180 action (2):                                                 /* do statement    */
181           call do_parse (k, label_ptr, conditions, cblock, end_ptr, return_flag, return_flag, "0"b);
182           go to end_up;
183 
184 action (3):                                                 /* if statement    */
185           call if_parse (k, label_ptr, conditions, cblock, end_ptr, return_flag);
186           go to if_end_up;
187 
188 action (4):                                                 /* on statement    */
189           call on_parse (k, label_ptr, conditions, cblock, end_ptr);
190           go to end_up;
191 
192 /*        ***************** Statements in error. *************************************** */
193 
194 action (5):                                                 /* declare,end,entry,format,procedure & possibly return stmts */
195           if type = binary (return_statement, 9)
196           then if return_flag
197                then n = 412;
198                else go to action (0);
199           else n = 430;
200           call parse_error (n, null);
201           go to end_up;
202 
203 /*        ***************** Statements all parsed in statement_parse. ****************** */
204 
205 action (0):
206           call statement_parse (k, label_ptr, conditions, cblock, type);
207           go to end_up;
208 
209 /*        ***************** Statements processed in-line ******************************* */
210 
211 action (6):                                                 /* go to statement in then clause */
212           if label_ptr ^= null | conditions ^= cblock -> block.prefix | ^pl1_stat_$optimize
213           then go to action (0);
214 
215           if t_table.string = "goto"
216           then k = k + 1;
217           else do;
218                     k = k + 1;
219 
220                     if t_table.string ^= "to"
221                     then call parse_error (446, null);
222                     else k = k + 1;
223                end;
224 
225           if expr = null
226           then expr = create_operator ((jump_if_true), 2);
227           else expr -> op_code = jump_if_true;
228 
229           expr -> operand (1) = reference_parse (k, cblock);
230 
231           if expr -> operand (1) = null
232           then call print (446);
233           else if t_table.type ^= semi_colon
234           then call parse_error (1, null);
235 
236           then_goto_optimized = "1"b;
237           goto end_up;
238 
239 action (7):
240           call io_statement_parse (k, label_ptr, conditions, cblock, end_ptr, return_flag, bit (binary (type, 9)));
241           goto end_up;
242 
243 end_up:
244           if end_ptr = null
245           then call lex(cblock);                            /* ^=null ==> end of block */
246 
247 /* If the statement following the if statement has a label on it, e.g.
248           if e1 then label: ....
249    we have to insert a null statement with 0 statement id before it.  This is
250    done to prevent problems if the semantic translator has to expand the
251    labelled statement into several statements.  This must also
252    be done if the profile option is used. */
253 
254 if_end_up:
255           q = if -> statement.next;
256           if q ^= null
257           then if q -> statement.labels ^= null | (^else & pl1_stat_$profile)
258                then do;
259                          q = create_statement (null_statement, if, null, conditions);
260                          string (q -> statement.source_id) = "0"b;
261                     end;
262 
263           if else
264           then go to process_else_clause;                   /* second time thru */
265 
266           if ^then_goto_optimized
267           then do;
268 
269 /* following code is executed after the then clause is parsed. */
270 
271                     q = create_statement (null_statement, cblock, null, conditions);
272 
273 /* following code sets the id of the statement holding
274    the label to the id of the statement preceding it.  This is
275    done so that the following statement can be expanded into several
276    statements.  We can't just set id of statement to 0 because that
277    fouls up the optimizer */
278 
279                     string (q -> statement.source_id) = string (q -> statement.back -> statement.source_id);
280 
281                     if loc ^= null
282                     then do;
283                               t, q -> statement.labels = create_list (2);
284                               loc -> label.statement = q;
285                               t -> list.element (2) = location;
286                          end;
287                     else go to exit;
288                end;
289 
290           if end_ptr ^= null                                /* unsatisfied labelled END statement */
291           then go to exit;
292 
293           k = 1;
294           if t_table.string ^= "else"
295           then go to exit;                                  /* no else clause; return */
296 
297           k = k + 1;
298           if t_table.type ^= left_parn
299           then go to call_st1;
300 
301 /*  else  (  */
302 
303           if token_list (k + 3) -> token.type ^= colon
304           then go to call_st1;                              /* could be assignment or condition prefix list */
305 
306 /*  else  (  <anything>  )  :  */
307 
308           k = k + 1;
309 
310           if t_table.type = identifier                      /* it's a CPL in an else clause */
311           then do;
312                     k = 2;
313                     else = "1"b;                            /* this is the case that statement type */
314                     go to call_st;                          /* can't handle.  */
315                end;
316 
317 /* it must be a label array named "else" ! */
318 
319 call_st1:
320           k = 1;
321 call_st:
322           conditions = cblock -> block.prefix;
323           type = statement_type (cblock, k, label_ptr, conditions);
324 
325           if type = binary (else_clause, 9)
326           then do;
327                     if else
328                     then call print (150);                  /* no if stmnt before else */
329 
330                     else = "1"b;
331                     k = k + 1;
332                     go to call_st;
333                end;
334 
335           if ^else
336           then go to exit;
337 
338 /* Now that we know we have an else clause, we check the type of statement
339    in it--certain combinations may be optimized slightly.   */
340 
341           if type ^= binary (goto_statement, 9) | label_ptr ^= null | conditions ^= cblock -> block.prefix
342                | ^pl1_stat_$optimize
343           then go to action (action_index (type));
344 
345           if then_goto_optimized
346           then go to action (0);
347 
348           if t_table.string = "goto"
349           then k = k + 1;
350           else do;
351                     k = k + 1;
352 
353                     if t_table.string ^= "to"
354                     then call parse_error (446, null);
355                     else k = k + 1;
356                end;
357 
358           expr -> operator.op_code = jump_if_false;
359           expr -> operand (1) = reference_parse (k, cblock);
360 
361           if expr -> operand (1) = null
362           then call print (446);
363           else if t_table.type ^= semi_colon
364           then call parse_error (1, null);
365                                                             /* delete null statement. */
366           q -> statement.back -> statement.next = null;     /* since this is the last statement on the chain. */
367           cblock -> block.end_main = q -> statement.back;   /* reset block ptr */
368           loc -> label.statement = null;
369 
370           if end_ptr = null
371           then call lex(cblock);
372 
373           goto exit;
374 
375 /* following code is executed after the else clause is parsed. */
376 
377 /* When control reaches here, the tree is as follows:
378 
379   if->      ----  if_statement
380             |           |
381             |           |
382             |     then body
383             |           |
384             |           |     q->  - - - - - - go to statement
385             |           |                         |
386    t->      ----> null statement                  |
387                         |                         |
388                         |                         |
389                         |                         |
390                     else body                     |
391                         |                         |
392   p->                   |    < - - - - - - - - null statement
393 
394    We must insert a goto statement after the "then" body which
395    transfers control around the else body. This action is not done
396    if the then body does not exist, or if it is a return statement
397    or a stop statement.  This action is also not done if the "then"
398    body is a noniterative do-group whose end statement has only one
399    label (which therefore must be compiler created), and which has
400    a return statement, a goto statement, or a stop statement preceding
401    the end statement.         */
402 
403 process_else_clause:
404           t = loc -> label.statement;
405           if t = null
406           then go to exit;
407 
408           if (then_type = binary (return_statement, 9)) | (then_type = binary (stop_statement, 9))
409           then go to exit;
410 
411           p = t -> statement.back;
412           bit_type = p -> statement.statement_type;
413 
414           if (bit_type = return_statement) | (bit_type = goto_statement) | (bit_type = stop_statement)
415           then go to exit;
416 
417           if then_type = binary (do_statement, 9)
418           then do;
419                     do = if -> statement.next;
420                     do while (do -> statement.statement_type ^= do_statement);
421                                                             /* skip any null stmts */
422                          do = do -> statement.next;         /* to get to the do stmt */
423                     end;
424                     if do -> statement.root -> operator.operand (3) = null
425                                                             /* if no do_spec operator */
426                     then if p -> statement.labels -> list.element (1) = null
427                                                             /* if one label */
428                          then do;                           /* we know p -> end stmt */
429                                    bit_type = p -> statement.back -> statement.statement_type;
430                                    if (bit_type = return_statement) | (bit_type = goto_statement)
431                                         | (bit_type = stop_statement)
432                                    then go to exit;
433                               end;
434                end;
435 
436           if label_ptr = null & type = binary (null_statement, 9)
437           then go to exit;
438 
439           q = create_statement (goto_statement, p, null, conditions);
440 
441 /* we have to set the id of the goto and the null statement following
442    it to be the same as the id of the last statement in the then group.
443    This is necessary to prevent difficulties if the semantic translator
444    has to expand the first statement of else group into several statements */
445 
446           string (t -> statement.source_id), string (q -> statement.source_id) = string (p -> statement.source_id);
447 
448           t, q -> statement.root = create_operator (jump, 1);
449           q, t -> operand (1) = create_label (cblock, null, by_compiler);
450 
451 /* make a label for the newly created jump operator */
452 
453           p = create_statement (null_statement, cblock, null, conditions);
454 
455 /* following code sets the id of the statement holding
456    the label to the id of the statement before it.  This is
457    done so that the following statement can be expanded into several
458    statements.  We can't just set id of statement to 0 because
459    that fouls up the optimizer */
460 
461           string (p -> statement.source_id) = string (p -> statement.back -> statement.source_id);
462 
463           q -> label.statement = p;
464           t, p -> statement.labels = create_list (2);       /* again, t is a temporary ptr. */
465           t -> list.element (2) = q -> label.token;         /* fish out name from label node */
466 
467 exit:
468           entry_ptr = label_ptr;
469           his_end_ptr = end_ptr;
470           return;
471 
472 print:
473      proc (m);
474 
475 dcl       m                   fixed bin (15);
476 
477           call parse_error (m, null);
478           if -> statement.root = null;
479           if -> statement.statement_type = null_statement;
480 
481      end print;
482 
483      end /* if_parse */;