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 defined_reference: proc(blk,stmnt,input_tree,subs,s,context) returns(ptr);
 12 
 13 /* Modified 780713 by PG for unsigned */
 14 /* Modified 790419 by PCK to implement 4-bit decimal */
 15 
 16 dcl       (blk,stmnt,tree,subs,new_subs,p,s,br,bs,a,input_tree,off,father_s) ptr;
 17 dcl       (t,k,n,i,nsubs,ndims,nsubs_minus_ndims) fixed bin(15);
 18 dcl       (father_dims,listdims(128)) fixed bin(15);
 19 dcl       (co,coff) fixed bin(31);
 20 dcl       cunits fixed bin(3);
 21 
 22 dcl       op_table(4) bit(9) aligned initial(mod_bit,""b,mod_byte,mod_half);
 23 dcl       dims_processed bit(1) aligned;
 24 
 25 dcl       pl1_stat_$eis_mode bit(1) aligned ext static,
 26           pl1_stat_$check_ansi bit(1) aligned ext static,
 27 
 28           pl1_stat_$root external static ptr;
 29 
 30 dcl       (addr,null,fixed,string,substr) builtin;
 31 ^L
 32           this_context = "0"b;
 33           t,k,n = 0;
 34                     /* t is used by string_overlay: it says bit/char
 35                        k is the number of asterisks observed by isubs_or_stars
 36                        n is the number of the last isub or asterisk
 37                             observed by isubs_or_stars
 38                     */
 39 
 40           tree = copy_expression((input_tree));
 41           br = copy_expression(s->symbol.equivalence);
 42 
 43           father_s=s;
 44           do while(father_s->symbol.member);
 45           father_s=father_s->symbol.father;
 46           end;
 47 
 48           if father_s->symbol.dimensioned then father_dims=father_s->symbol.array->array.number_of_dimensions;
 49           else father_dims=0;
 50 
 51 
 52 
 53 
 54           if ^lookup((s->symbol.block_node),stmnt,br,bs,this_context)
 55           then      if br->node.type = token_node
 56                     then do;
 57                               call semantic_translator$error(77,br);
 58                               bs = create_symbol((pl1_stat_$root->block.son),br,by_implication);
 59                               call declare(bs);
 60                               bs->symbol.allocate = "1"b;
 61                     end;
 62                     else      call print(175);
 63           else      if br->node.type=reference_node         /* lookup replaces the symbol field */
 64                     then do;
 65                               br->reference.symbol = bs->symbol.token;
 66                               br->reference.length = copy_expression(s->symbol.equivalence->reference.length);
 67                               br->reference.offset = copy_expression(s->symbol.equivalence->reference.offset);
 68                               br->reference.qualifier = copy_expression(s->symbol.equivalence->reference.qualifier);
 69                     end;
 70 
 71           if bs->node.type ^= symbol_node then call print(176);
 72           if pl1_stat_$check_ansi
 73           then      if bs->symbol.based
 74                     then      call semantic_translator$error(173,s);
 75           if bs->symbol.defined | bs->symbol.constant then call print(176);
 76 
 77           /* the following line is present so that defined variables can
 78               be processed by the code generator program which generates the
 79                run-time symbol table */
 80 
 81           s -> symbol.reference -> reference.qualifier = bs -> symbol.reference;
 82           call propagate_bit(bs,aliasable_bit);
 83           if def_context.left_side then call propagate_bit(bs,set_bit);
 84 
 85           a = s->symbol.array;
 86           if a ^= null
 87           then ndims = a->array.number_of_dimensions;
 88           else ndims = 0;
 89 
 90           dims_processed = "0"b;
 91           if subs ^= null
 92           then      do;
 93                     nsubs = subs->list.number;
 94                     if s->symbol.dimensioned
 95                     then      do;
 96                               tree->reference.array_ref = "0"b;
 97                               if nsubs < ndims then call print(81);
 98                               if nsubs > ndims & ^s->symbol.entry then call print(82);
 99                               if ^isubs_or_stars()
100                               then      do;
101                                         tree = subscripter(blk,stmnt,tree,subs,s);
102                                         dims_processed = "1"b;
103                                         end;
104                               end;
105                     else if isubs_or_stars() then call print(183);
106                     end;
107           else      do;
108                     nsubs = 0;
109                     if isubs_or_stars() & ^s->symbol.dimensioned then call print(183);
110                     end;
111 
112 
113 /* add the offsets of the defined reference to those of the base */
114 
115           if father_s->symbol.position
116           then do;
117 
118                     if n>0 then call print(177);  /* isubs_or_stars AND position */
119                     if ^(string_overlay(father_s)&string_overlay(bs)) then call print(178);
120                     father_s->symbol.overlayed, s->symbol.overlayed = "1"b;
121                     p = father_s -> symbol.initial;                   /* the position value */
122                     if p -> node.type = token_node
123                     then if p -> token.type & is_arith_constant
124                          then do;
125                               co = token_to_binary(p) - 1;
126                               p = null;
127                               goto l1;
128                               end;
129 
130                     co = 0;
131                     p = copy_expression((p));
132 
133                     this_context = "0"b;
134                     a = create_operator(sub,3);
135                     a->operand(2) = p;
136                     a->operand(3) = declare_constant$integer(1);
137                     p = a;
138                     p = expression_semantics((s->symbol.block_node),stmnt,p,this_context);
139                     if def_this_context.aggregate then call print(185);
140                     p = convert(p,integer_type);
141 l1:
142                     off = tree->reference.offset;
143                     coff = tree->reference.c_offset;
144                     cunits = tree->reference.units;
145 
146                     call offset_adder(off,coff,cunits,(tree->reference.modword_in_offset),p,co,(t),"0"b,tree->reference.fo_in_qual);
147 
148                     tree->reference.offset = off;
149                     tree->reference.c_offset = coff;
150                     tree->reference.units = cunits;
151                     tree->reference.modword_in_offset = "0"b;
152           end;
153 
154           else      do;
155                     if match(father_s,bs) then goto build_ref;
156                     if n>0 then call print(179);  /* isubs_or stars AND non-matching */
157                     if string_overlay(father_s) & string_overlay(bs)
158                          then father_s->symbol.overlayed, s->symbol.overlayed = "1"b;
159                          else call print(179);
160           end;
161 
162 /* build the return reference */
163 
164 build_ref:
165           if pl1_stat_$check_ansi
166           then      if s->symbol.varying
167                     then      call semantic_translator$error(174,s);
168 
169           this_context = "0"b;
170           def_this_context.evaluate_offset = "1"b;
171           def_this_context.f_offset_to_be_added = "1"b;
172           br = expression_semantics((s->symbol.block_node),stmnt,br,this_context);
173           if bs->symbol.reference=br then br=copy_expression((br));
174           if br->reference.units ^= 0
175           then do;
176                     off = tree->reference.offset;
177                     coff = tree->reference.c_offset;
178                     cunits = tree->reference.units;
179 
180                     call offset_adder(off,coff,cunits,(tree->reference.modword_in_offset),
181                                       (br->reference.offset),(br->reference.c_offset),(br->reference.units),(br->reference.modword_in_offset),
182                                       tree->reference.fo_in_qual);
183 
184                     tree->reference.offset = off;
185                     tree->reference.c_offset = coff;
186                     tree->reference.units = cunits;
187                     tree->reference.modword_in_offset = "0"b;
188           end;
189 
190           tree->reference.qualifier = br;
191           tree->reference.fo_in_qual = br->reference.fo_in_qual;
192           tree->reference.defined_ref = "1"b;
193           tree->reference.shared,br->reference.shared = "0"b;
194           tree->reference.ref_count,br->reference.ref_count = 1;
195 
196           if ^dims_processed
197           then      do;
198                     if nsubs > ndims
199                     then      do;
200                               nsubs_minus_ndims=nsubs-ndims;
201                               new_subs = create_list(nsubs_minus_ndims);
202                               do i = 1 to nsubs_minus_ndims;
203                                         new_subs->element(i) =subs->element(i);
204                               end;
205                               subs=new_subs;
206                               end;
207                     else      subs=null;
208                     end;
209 
210           br->reference.offset = null;
211           br->reference.units,br->reference.c_offset = 0;
212           br->reference.modword_in_offset = "0"b;
213 
214           /* since br represents an address, prevent it from being commoned by the optimizer */
215 
216           br->reference.inhibit = "1"b;
217 
218           if        ^pl1_stat_$eis_mode
219           then if   tree->reference.offset ^= null
220           then if   tree->reference.units < word_
221           then do;
222                     p = tree->reference.offset;
223                     if p->node.type=operator_node
224                     then      if p->operator.op_code=mod_bit
225                               |  p->operator.op_code=mod_byte
226                               |  p->operator.op_code=mod_half
227                               then      goto ret;
228 
229                     p = create_operator(op_table(tree->reference.units),3);
230                     p->operand(3) = tree->reference.offset;
231                     tree->reference.offset = p;
232           end;
233 
234 ret:
235           return(tree);
236 ^L
237 /* subroutine to match the defined item's father against its base to determine the
238    suitability for isub or simple defining.  */
239 
240 match: proc(a,b) returns(bit(1) aligned);
241 
242 dcl       (a,b,p,q) ptr;
243 
244           /* expanded 4-18-73 PAB for number of member dimensions */
245           /* the extents should perhaps be checked at compile-and-or-run-time */
246 
247           dcl (pp,qq) ptr;
248 
249 
250           if string(a->symbol.data_type)^=string(b->symbol.data_type)
251           then      goto fail;
252 
253           if a->symbol.aligned ^= b->symbol.aligned
254           then      goto fail;
255 
256           if a -> symbol.unsigned ^= b -> symbol.unsigned
257           then      go to fail;
258 
259           if a->symbol.c_dcl_size ^= b->symbol.c_dcl_size
260           then do;
261                     if a->symbol.array=null
262                     then      goto fail;
263 
264                     if a->symbol.array->array.c_element_size^=b->symbol.c_dcl_size
265                     then      goto fail;
266           end;
267 
268           if a->symbol.scale ^= b->symbol.scale
269           then      goto fail;
270 
271           if a->symbol.structure
272           then do;
273                     p = a->symbol.son;
274                     q = b->symbol.son;
275 
276                     do while(p^=null);
277                               if q = null then go to fail;
278 
279                               pp=p->symbol.array;
280                               qq=q->symbol.array;
281                               if (pp^=null | qq^=null )
282                               then do;
283                                         if qq=null
284                                         then      goto fail;
285 
286                                         if pp=null
287                                         then      if ^p->symbol.structure
288                                                   then      if qq->array.own_number_of_dimensions^=0
289                                                             then      goto fail;
290                                                             else      ;
291                                                   else      ;
292                                         else      if pp->array.own_number_of_dimensions
293                                                   ^= qq->array.own_number_of_dimensions
294                                                   then      goto fail;
295                               end;
296 
297                               if ^match(p,q) then go to fail;
298                               p = p->symbol.brother;
299                               q = q->symbol.brother;
300                     end;
301 
302                     if q ^= null then go to fail;
303           end;
304 
305           return("1"b);
306 
307 fail:
308           return("0"b);
309           end match;
310 
311 /* ^L */
312 %include string_overlay;
313 ^L
314 /* subroutine to find or find and replace all Isubs or asterisks with subscripts from the defined reference */
315 
316 isubs_or_stars: proc returns(bit(1) aligned);
317 
318 dcl       p ptr;
319 dcl       i fixed bin(15);
320 
321                     /* extended 4-18-73 PAB
322                        to check that enough asterisks or isubs appear
323                        and to check that the two are not mixed
324                        and to check that the asterisks appear only at level 1 */
325 
326 
327           n = 0;
328 
329           do i=1 to father_dims;
330           listdims(i)=0;
331           end;
332 
333 
334           if br->node.type=reference_node
335           then do;
336                     p = br->reference.offset;
337                     if p^=null
338                     then do i = 1 to p->list.number;
339                               call find(p->list.element(i));
340                     end;
341           end;
342 
343           if n=0 then return("0"b);
344           if father_dims=0 then return("1"b);               /* no isubs or asterisks expected */
345 
346           if k>0 then if k^= father_dims then call print(181);        /* asterisks appear - there must be exactly enough of them */
347           if k>0 then
348                     do i=1 to father_dims;                  /* asterisks appear - no isubs may appear */
349                     if listdims(i)^=0 then call print(181);
350                     end;
351           else      do i=1 to father_dims;                  /* no asterisks appear - exactly enough isubs must appear */
352                     if listdims(i)=0 then call print(181);
353                     end;
354 
355           return("1"b);
356 
357 find: proc(p);
358 
359 dcl       p ptr unal,
360           (e,q) ptr;
361 dcl       i fixed bin(15);
362 dcl       recursif fixed bin(15);
363 
364           recursif=1;
365           goto find_common;
366 
367 find_r:   entry(p);           /* recursive entrypoint - not allowed to "see" asterisks */
368           recursif=2;
369 
370 find_common:
371           e = p;
372 
373           if e = null then return;
374 
375           if e->node.type = operator_node
376           then do;
377                     do i = 1 to e->operator.number;
378                               call find_r(e->operand(i));
379                     end;
380                     return;
381           end;
382 
383           if e->node.type = reference_node
384           then do;
385                     call find_r(e->reference.qualifier);
386                     call find_r(e->reference.offset);
387                     call find_r(e->reference.length);
388                     return;
389           end;
390 
391           if e->node.type=list_node
392                               /* subscripts and arguments in expressions in the
393                                  subscripts of the base reference appear as
394                                  refp->ref.offset->list   */
395           then do;
396                     do i=1 to e->list.number;
397                     call find_r(e->list.element(i));
398                     end;
399                     return;
400           end;
401 
402           if e->node.type = token_node
403           then do;
404                     if e->token.type = asterisk
405                               then do;
406                                         if recursif=2 then return;    /* don't recognize
407                                                                          an asterisk except at
408                                                                          level 1 */
409                                         k = k+1;
410                                         n = k;
411                                    end;
412                               else do;
413                                         if e->token.type ^= isub then return;
414                                         n = decbin(substr(e->token.string,1,e->token.size-3));
415                                         listdims(n)=1;
416                                         s->symbol.isub = "1"b;
417                                    end;
418 
419                     if n > father_dims then call print(181);
420                     if substr(stmnt->statement.prefix,7,1)  /* subscriptrange */
421                     |  subs=null
422                     then do;
423                               q = a->array.bounds;
424                               do i = 1 to n-1;
425                               q = q->bound.next;
426                               end;
427                               if q->bound.lower=null
428                               then      q->bound.lower = declare_constant$integer((q->bound.c_lower));
429                               if subs=null
430                               then      e = q->bound.lower;
431                               else do;
432                                         if q->bound.upper = null
433                                         then q->bound.upper = declare_constant$integer((q->bound.c_upper));
434                                         e = create_operator(bound_ck,4);
435                                         e->operand(1) = declare_temporary(integer_type,default_fix_bin_p,0,null);
436                                         e->operand(2) = subs->list.element(subs->list.number+1-n);
437                                         e->operand(3) = q->bound.lower;
438                                         e->operand(4) = q->bound.upper;
439                               end;
440                     end;
441                     else      e = subs->list.element(subs->list.number+1-n);
442 
443                     /* if isub subscripts are not processed now they will be found        */
444                     /* hanging off of the base-reference as tokens, and processed within  */
445                     /* the block the base reference is declared in, rather than the       */
446                     /* block in which they are found!!! (bug1395) -- RHS 8/75             */
447 
448                     /* isub must be converted to integer!! -- RAB 6/77                    */
449 
450                     e = expression_semantics(blk,stmnt,e,this_context);
451                     e = convert$to_integer(e,integer_type);
452           end;
453 
454           p = e;
455 
456           end find;
457 
458           end isubs_or_stars;
459 ^L
460 /* subroutine to print an error message and abort this statement.  */
461 
462 print: proc(m);
463 
464 dcl       m fixed bin(15);
465 
466           call semantic_translator$abort(m,s);
467           end print;
468 ^L
469 %include semant;
470 %include symbol;
471 
472 %include symbol_bits;
473 
474 %include block;
475 
476 %include reference;
477 %include semantic_bits;
478 
479 %include token;
480 
481 %include statement;
482 
483 %include array;
484 
485 %include list;
486 
487 %include operator;
488 
489 %include op_codes;
490 
491 %include token_types;
492 
493 %include nodes;
494 
495 %include system;
496 
497 %include declare_type;
498 
499 %include boundary;
500 
501           end defined_reference;