1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 /*        Modified: 781219 by RAB to fix 1806 (ERROR 316 for star_extent exprs) */
 12 /*        Modified: 17 Mar 1980 by PCK to implement by name assignment          */
 13 
 14 expand_infix: proc(blk,stmnt,tree,context) returns(ptr);
 15 
 16 dcl       (blk,stmnt,tree,a,b,p,r,first) ptr;
 17 dcl       loop5 ptr init(null);
 18 dcl       (i,n,k) fixed bin(15);
 19 dcl       opcode bit(9) aligned;
 20 
 21 dcl       pl1_stat_$LHS ptr ext static;
 22 
 23 dcl       (null,string,substr) builtin;
 24 ^L
 25           n = tree->operator.number;
 26           this_context = "0"b;
 27           def_this_context.by_name_assignment = def_context.by_name_assignment;
 28           a = tree->operand(n-1);
 29           b = tree->operand(n);
 30           if n=3 then first = tree->operand(1); else first = null;
 31           opcode = tree->op_code;
 32 
 33           if a->node.type = reference_node
 34           then      a = process(a,this_context);
 35 
 36           if b->node.type = reference_node
 37           then      b = process(b,this_context);
 38 
 39           if a->node.type=operator_node
 40           then      if a->op_code^=loop
 41                     &  a->op_code^=join
 42                     then      if a->op_code ^= std_call
 43                               then      a = simplify_scalar(a);
 44                               else      a = process(a,"0"b);
 45 
 46           if b->node.type=operator_node
 47           then      if b->op_code^=loop
 48                     &  b->op_code^=join
 49                     then      if b->op_code ^= std_call
 50                               then      b = simplify_scalar(b);
 51                               else      b = process(b,"0"b);
 52 
 53           if a->node.type ^= operator_node
 54           then do;
 55                     k = 2;
 56                     r = walk(b);
 57                     goto ret;
 58           end;
 59 
 60           if b->node.type ^= operator_node
 61           then do;
 62                     k = 3;
 63                     r = walk(a);
 64                     goto ret;
 65           end;
 66 
 67                               /*   Both operands are operators, now check for promotions from structures to
 68                                    arrays of structures   */
 69 
 70           if a->op_code=loop & b->op_code=join
 71           then do;
 72                     do p = a repeat p->operand(1) while(p->operand(1)->op_code=loop);
 73                     end;
 74 
 75                     p->operand(1) = match((p->operand(1)),b);
 76 
 77                     r = a;
 78                     goto ret;
 79           end;
 80 
 81           if a->op_code=join & b->op_code=loop
 82           then do;
 83                     do p = b repeat p->operand(1) while(p->operand(1)->op_code=loop);
 84                     end;
 85 
 86                     p->operand(1) = match(a,(p->operand(1)));
 87 
 88                     r = b;
 89                     goto ret;
 90           end;
 91 
 92           r = match(a,b);
 93 
 94 ret:
 95           if r->op_code=loop
 96           &  loop5^=null
 97           then do;
 98                     do p = loop5 repeat p->element(1) while(p^=null);
 99                               p->element(2) = share_expression((p->element(2)));
100                     end;
101 
102                     if r->operand(5)=null
103                     then      r->operand(5) = loop5;
104                     else do;
105                               do p = r->operand(5) repeat p->element(1) while(p->element(1)^=null);
106                               end;
107 
108                               p->element(1) = loop5;
109                     end;
110           end;
111 
112           return(r);
113 
114 process: proc(p,context) returns(ptr);
115 
116 dcl       context bit(36) aligned;
117 dcl       (p,q) ptr;
118 
119           if p -> node.type = reference_node
120           then      q = p;
121           else      q = p->operand(1);
122 
123           if q->reference.symbol->symbol.structure
124           |  q->reference.array_ref
125           then      return(expand_primitive(blk,stmnt,q,context));
126           else      return(simplify_scalar(p));
127 
128           end process;
129 ^L
130 /* subroutine to walk down the loop and join ops and create infix operators
131    to incorporate a  scalar expression into an aggregate expression.  */
132 
133 walk: proc(e) returns(ptr);
134 
135 dcl       e ptr;
136 dcl       i fixed bin(15);
137 
138           if e->node.type = operator_node
139           then      if e->op_code = loop
140                     then do;
141                               e->operand(1) = walk((e->operand(1)));
142                               return(e);
143                     end;
144 
145                     else      if e->op_code = join
146                               then do;
147                                         do i = 1 to e->operator.number;
148                                                   e->operand(i) = walk((e->operand(i)));
149                                         end;
150                                         return(e);
151                               end;
152 
153           if k=2
154           then      return(match(share_expression(a),e));
155           else      return(match(e,share_expression(b)));
156 
157           end walk;
158 ^L
159 /* subroutine to match to aggregate expressions and combine them.  */
160 
161 match: proc(aa,bb) returns(ptr);
162 
163 dcl       (a,b,aa,bb,p) ptr;
164 dcl       i fixed bin(15);
165 
166           a = aa;
167           b = bb;
168 
169           if a->node.type ^= operator_node then go to scalar_a;
170           if a->op_code ^= loop & a->op_code ^= join then go to scalar_a;
171           if b->node.type ^= operator_node then go to scalar_b;
172           if b->op_code ^= loop & b->op_code ^= join then go to scalar_b;
173 
174           if a->op_code^=b->op_code then goto fail;
175 
176           if a->op_code=loop
177           then do;                      /* both operands are arrays.  */
178                     if ^compare_expression((a->operand(4)),(b->operand(4)))
179                     then do;
180                               if  a->operand(4)->node.type=reference_node
181                               then if  a->operand(4)->reference.symbol->symbol.constant
182                               then if  b->operand(4)->node.type=reference_node
183                               then if  b->operand(4)->reference.symbol->symbol.constant
184                               then      goto fail;
185 
186                               p = create_operator(bound_ck,4);
187                               p->operator.processed = "1"b;
188                               p->operand(1)=declare_temporary(integer_type,default_fix_bin_p,0,null);
189                               p->operand(2) = a->operand(4);
190                               p->operand(3) = b->operand(4);
191                               p->operand(4) = share_expression((p->operand(3)));
192                               a->operand(4) = p;
193                     end;
194 
195                     a->operand(1) = match((a->operand(1)),(b->operand(1)));
196 
197                     if b->operand(5)^=null
198                     then      if a->operand(5)=null
199                               then      a->operand(5) = b->operand(5);
200                               else do;
201                                         do p = a->operand(5) repeat p->element(1) while(p->element(1)^=null);
202                                         end;
203 
204                                         p->element(1) = b->operand(5);
205                               end;
206 
207                     return(a);
208           end;
209 
210           if a->operator.number ^= b->operator.number then go to fail;
211 
212           do i = 1 to a->operator.number;
213                     a->operand(i) = match((a->operand(i)),(b->operand(i)));
214           end;
215 
216           return(a);
217 
218 scalar_a:
219           if b->node.type = operator_node
220           then      if b->op_code = loop | b->op_code = join
221                     then      go to fail;
222 
223           go to combine;
224 
225 scalar_b:
226           if a->node.type = operator_node
227           then      if a->op_code = loop | a->op_code = join
228                     then      go to fail;
229 
230 combine:
231           p = create_operator(opcode,n);
232           p->operand(n-1) = a;
233           p->operand(n)   = b;
234                               /*   May be called from builtin   */
235           if first^=null
236           then      p->operand(1) = first;
237           else      p = operator_semantics(blk,stmnt,p,"0"b);
238 
239           return(p);
240 
241 fail:
242           call semantic_translator$abort(79,null);
243 
244           end match;
245 ^L
246 /* subroutine to remove a scalar sub-expression so that it is evaluated only once.   */
247 
248 simplify_scalar:    proc(pp) returns(ptr);
249 
250 dcl       (e,pp,p,q,st,sy,LHS_sy,r,ret_ptr) ptr;
251 
252           p = pp;
253 
254           if p->node.type=operator_node
255           then do;
256                                         /*   the std_call operator may have already been extracted   */
257                     if stmnt->statement.back->statement.root=p
258                     then      st = stmnt;
259                     else      st = create_statement(assignment_statement,(stmnt->statement.back),
260                                         null,(stmnt->statement.prefix));
261 
262 
263                     st->statement.root = p;
264 
265                     /* new symbol necessary to prevent optimizer's losing
266                        temporary due to commoning of operator */
267 
268                     q = create_symbol(blk,null,by_compiler);
269                     r = q->symbol.reference;
270 
271                     r->reference = p->operand(1)->reference;
272                     q->symbol = r->reference.symbol->symbol;
273                     q->symbol.next = null;
274                     q->symbol.reference = r;
275                     r->reference.symbol = q;
276 
277                     r->reference.shared = "0"b;
278                     r->reference.ref_count = 1;
279 
280                     if p->op_code=std_call
281                     then do;
282                               r->reference.ref_count = 2;
283 
284                               e = p->operand(3)->operand(2);
285                               e->element(e->list.number) = r;
286                     end;
287 
288                     p->operand(1) = r;
289 
290                     ret_ptr = r;
291 
292                     goto ret1;
293           end;
294 
295           if p->node.type = label_node
296           then      return(p);
297 
298           if p->reference.offset^=null
299           |  p->reference.length^=null
300           |  p->reference.qualifier^=null
301           then      goto create;
302 
303           if p->reference.symbol->node.type = label_node
304           then      goto ret0;
305 
306           if p->reference.symbol->symbol.constant
307           then      goto ret0;
308 
309           if p->reference.symbol->symbol.temporary
310           then do;
311                     p->reference.ref_count = p->reference.ref_count - 1;
312                     ret_ptr = p;
313                     go to ret1;
314           end;
315 
316           LHS_sy = pl1_stat_$LHS;
317           if LHS_sy=null
318           then      goto ret0;
319 
320           sy = p->reference.symbol;
321 
322           if LHS_sy->symbol.based
323           |  LHS_sy->symbol.defined
324           |  LHS_sy->symbol.parameter
325           then do;
326                     if sy->symbol.member
327                     &  LHS_sy->symbol.structure
328                     then      goto create;
329 
330                     if string(sy->symbol.attributes.data_type)=string(LHS_sy->symbol.attributes.data_type)
331                     then      goto create;
332                     else      goto ret0;
333           end;
334 
335           if sy->symbol.dimensioned
336           &  sy=LHS_sy
337           then      goto create;
338 
339           if sy->symbol.member
340           then do q = sy repeat q->symbol.father while(q^=null);
341                     if q=LHS_sy
342                     then      goto create;
343           end;
344 
345           goto ret0;
346 
347 create:
348           st = create_statement(assignment_statement,(stmnt->statement.back),null,(stmnt->statement.prefix));
349           r = create_operator(assign,2);
350           sy = create_symbol(null,null,by_compiler);
351           sy->symbol.temporary = "1"b;
352           sy->symbol.reference->reference.shared = "0"b;
353           sy->symbol.reference->reference.ref_count = 1;
354 
355           r->operand(1) = sy->symbol.reference;
356           r->operand(2) = p;
357 
358           st->statement.root = expression_semantics(blk,st,r,"0"b);
359 
360           ret_ptr = r->operand(1);
361 
362 ret1:
363           /* this keeps temps from being released until after loop ends */
364 
365           if loop5=null
366           then do;
367                     loop5 = create_list(2);
368                     loop5->element(2) = ret_ptr;
369           end;
370           else do;
371                     q = create_list(2);
372                     q->element(2) = ret_ptr;
373                     q->element(1) = loop5;
374                     loop5 = q;
375           end;
376 
377           return(ret_ptr);
378 
379 ret0:
380           if ^ p -> reference.shared
381           then      p->reference.ref_count = p->reference.ref_count - 1;
382 
383           return(p);
384 
385           end simplify_scalar;
386 ^L
387 %include semant;
388 %include declare_type;
389 %include list;
390 %include nodes;
391 %include op_codes;
392 %include operator;
393 %include reference;
394 %include semantic_bits;
395 %include statement;
396 %include statement_types;
397 %include symbol;
398 %include system;
399 
400           end expand_infix;