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 declare_structure: proc(ps);
 12 
 13 /* Modified 780724 by PG to call validate before copying storage_class of adam. */
 14 /* Modified 790419 by PCK to implement 4-bit decimal */
 15 
 16 dcl       (adam,base,bit_offset,allocate,ps,s,d,b,off,q) ptr;
 17 dcl       n fixed bin(15);
 18 dcl       coff fixed bin(31);
 19 dcl       cdesc bit(1);
 20 
 21 dcl       pl1_stat_$eis_mode bit(1) aligned ext static;
 22 
 23 dcl       (min,max,null,fixed,divide,string,substr) builtin;
 24 
 25 %include semant;
 26 %include symbol;
 27 %include array;
 28 %include block;
 29 %include reference;
 30 %include operator;
 31 %include statement;
 32 %include op_codes;
 33 %include nodes;
 34 %include statement_types;
 35 %include boundary;
 36 %include list;
 37 %include system;
 38 ^L
 39           s = ps;
 40           b = s->symbol.block_node;
 41           adam = s;
 42 
 43 /* Scan the structure to:
 44           1. propagate the refer and exp_extent bits upward.
 45           2. determine the boundary required by each member.
 46           3. determine the boundary required by the structure.
 47           4. determine the packing of the structure.
 48           5. Validate the structure and each of its members.
 49           6. Apply the father's alignment attributes to the sons.
 50           7. Copy the level 1 defined structure's base ref to the members.
 51           8. Copy the level 1 storage class to the members.
 52                                                                                 */
 53           cdesc = s->symbol.parameter | s->symbol.return_value | s->symbol.controlled;
 54 
 55           if cdesc
 56           then      s->symbol.descriptor = declare_descriptor$param((s->symbol.block_node),null,s,null,"1"b);
 57 
 58           call structure_scan(s);
 59 
 60 /* set base to the locator value used to reference the level 1 structure.
 61    and set bit_offset the the proper bit_pointer value to use for packed members.         */
 62 
 63           allocate,bit_offset,base = null;
 64 
 65           if        s->symbol.auto
 66           then if   s->symbol.exp_extents
 67           then do;
 68                     base = declare_pointer(b);
 69                     allocate = create_operator(allot_auto,2);
 70                     allocate->operand(1) = base;
 71           end;
 72 
 73           if s->symbol.based
 74           then do;
 75                     base = s->symbol.reference->reference.qualifier;
 76                     if s->symbol.unaligned & s->symbol.packed
 77                     then      if pl1_stat_$eis_mode
 78                               then      s->symbol.reference->reference.fo_in_qual = "1"b;
 79                               else      bit_offset = create_operator(bit_pointer,2);
 80           end;
 81 
 82           if s->symbol.parameter
 83           then do;
 84                     if ^s->symbol.allocated
 85                     then do;
 86                               base = create_operator(param_ptr,3);
 87                               base->operand(2) = declare_constant$integer(fixed(s->symbol.location));
 88                               base->operand(3) = b;
 89                     end;
 90                     else      base = declare_pointer(b);
 91 
 92                     if s->symbol.unaligned & s->symbol.packed
 93                     then      if pl1_stat_$eis_mode
 94                               then      s->symbol.reference->reference.fo_in_qual = "1"b;
 95                               else do;
 96                                         bit_offset = create_operator(bit_pointer,2);
 97                                         bit_offset->operand(2) = base;
 98                               end;
 99           end;
100 
101 /* Set the qualifier field of the structure's reference node.  */
102 
103           s->symbol.reference->reference.qualifier = base;
104 
105 /* set the padded bit for references to the level one structure.      */
106 
107           if s->symbol.packed
108           then do;
109                     s->symbol.reference->reference.padded_ref =
110                               ^(s->symbol.based|s->symbol.parameter|s->symbol.defined);
111 
112                     if s->symbol.reference->reference.padded_ref
113                     then      s->symbol.boundary = max(s->symbol.boundary,word_);
114           end;
115 
116 /* If this is a packed unaligned structure set the offset to include the bit_pointer.  */
117 
118           if bit_offset ^= null
119           then do;
120                     s->symbol.reference->reference.offset = bit_offset;
121                     s->symbol.reference->reference.units = bit_;
122           end;
123 
124 /* Set the aliasable bit */
125 
126           if s -> symbol.based | s -> symbol.parameter | s -> symbol.defined | s -> symbol.external
127           then s -> symbol.aliasable = "1"b;
128 
129 /* scan the structure again and:
130 
131           1. compute each member's size and offset.
132           2. determine the level 1 structure's size.
133           3. make each member based on the level 1 structure's base pointer.
134           4. initialize each member.
135           5. set each members padded bit.
136           6. process each entry variable's descriptor list and return descriptor.
137           7. give each member the storage class bits of the level one structure.
138                                                                                 */
139 
140           call get_structure_size(s);
141 
142           s->symbol.reference->reference.c_length = 0;
143 
144 /* Make sure the value will fit in a segment */
145 
146           if s -> symbol.c_word_size > max_words_per_variable
147           then call semantic_translator$error (357,s);
148 
149 /* If this has constant extents and requires a descriptor, declare_descriptor
150    must be called after all the extents are calculated in order to actually
151    declare the constant descriptor.  If the descriptor template used for
152    entry definitions has not been built, declare_descriptor must also be
153    called. */
154 
155           if cdesc
156           then      if s->symbol.descriptor = null
157                     then s->symbol.descriptor = declare_descriptor((s->symbol.block_node),null,s,null,"1"b);
158                     else if s->symbol.parameter
159                          then if s->symbol.descriptor->reference.symbol->symbol.descriptor = null
160                               then s->symbol.descriptor = declare_descriptor((s->symbol.block_node),null,s,null,"1"b);
161 
162 
163 /* If this was automatic with variable extents, fill in the size field of the allot_auto operator */
164 
165           if allocate^=null
166           then do;
167                     allocate->operand(2) = copy_expression(s->symbol.word_size);
168 
169                     q = create_statement$prologue(assignment_statement,b,null,(b->block.prefix));
170                     q->statement.root = allocate;
171           end;
172 
173           call initialize(s);
174 
175           return;
176 ^L
177 /* subroutine to:
178           1. propagate the refer, exp_extent, star_extent bits upward.
179           2. determine the boundary required by each structure member.
180           3. determine the boundary required by each structure.
181           4. determine the packing of the structure.
182           5. Validate the structure and each of its members.
183           6. Apply the father's alignment attributes to the sons.
184           7. Compute the logical level numbers of the sons.
185                                                                       */
186 structure_scan: proc(ps);
187 
188 dcl       (ps,d,s) ptr;
189 
190           s = ps;
191 
192           if s->symbol.member
193           then do;
194                     s->symbol.level = s->symbol.father->symbol.level+1;         /* set logical level */
195 
196                     if ^(s -> symbol.aligned | s -> symbol.unaligned)
197                     then do;
198                               s -> symbol.aligned = s -> symbol.father -> symbol.aligned;
199                               s -> symbol.unaligned = s -> symbol.father -> symbol.unaligned;
200                          end;
201                end;
202 
203           if s -> symbol.son = null
204           then do;
205                     call validate (s);
206                     if s -> symbol.member
207                     then do;
208                               string(s->symbol.storage_class) = string(adam->symbol.storage_class);
209                               s->symbol.equivalence = adam->symbol.equivalence;
210                     end;
211                     call get_size(s);
212                     return;
213                end;
214 
215           s->symbol.structure,s->symbol.packed = "1"b;
216 
217           do d = s->symbol.son repeat d->symbol.brother while(d^=null);
218                     call structure_scan(d);
219                     s->symbol.packed = s->symbol.packed & d->symbol.packed;
220                     s->symbol.boundary = max(s->symbol.boundary,d->symbol.boundary);
221                     s->symbol.refer_extents = s->symbol.refer_extents | d->symbol.refer_extents;
222                     s->symbol.exp_extents = s->symbol.exp_extents |d->symbol.exp_extents;
223                     s->symbol.star_extents = s->symbol.star_extents | d->symbol.star_extents;
224           end;
225 
226           call validate(s);
227 
228           if s -> symbol.member
229           then do;
230                     string(s->symbol.storage_class) = string(adam->symbol.storage_class);
231                     s->symbol.equivalence = adam->symbol.equivalence;
232                end;
233 
234           if s -> symbol.aligned
235           then do;
236                     s -> symbol.boundary = max(s -> symbol.boundary,word_);
237                     s -> symbol.packed = "0"b;
238                end;
239 
240           if s->symbol.dimensioned
241           then      s->symbol.array->array.element_boundary = s->symbol.boundary;
242 
243           end structure_scan;
244 ^L
245 /* subroutine to:
246           1.  compute each member's offset.
247           2. determine the level 1 structure's size.
248           3. make each member based on the level 1 structure's base pointer.
249           4. make each member's offset include the proper bit pointer.
250           5. initialize each member.
251           6. set each members's padded bit.
252           7. process each entry vairable's descriptor list and return descriptor.
253                                                                                           */
254 get_structure_size: proc(ps);
255 
256 dcl       (ps,s,d,f,r,q,p,fsize,rv,t) ptr;
257 dcl       (i,j,k) fixed bin(3);
258 dcl        fc_size fixed bin(31);
259 
260 dcl       opcodes(4) bit(9) aligned initial(bit_to_char,bit_to_word,char_to_word,half_to_word);
261 
262 dcl       opcode_index(4,7) fixed bin(15) internal static init(0,0,1,0,2,2,2,
263                                                                0,0,0,0,0,0,0,
264                                                                0,0,0,0,3,3,3,
265                                                                0,0,0,0,4,4,4);
266 
267 dcl       round_const(4,7) fixed bin(15) int static initial(0,0,9,0,36,36,36,
268                                                             0,0,0,0, 0, 0, 0,
269                                                             0,0,0,0, 4, 4, 4,
270                                                             0,0,0,0, 2, 2, 2);
271 
272 dcl       mod_const(6:7) fixed bin(15) int static initial(2,4);
273 
274 dcl       mod_ops(6:7) bit(9) aligned  initial(word_to_mod2,word_to_mod4);
275 
276 dcl       offset_ops(4) bit(9) aligned initial(mod_bit,""b,mod_byte,mod_half);
277 
278           s = ps;
279           j = s->symbol.boundary;
280           f = s->symbol.reference;
281           fc_size = 0;
282           fsize = null;
283 
284           do d = s->symbol.son repeat d->symbol.brother while(d^=null);
285                     string(d->symbol.storage_class) = string(s->symbol.storage_class);
286                     d->symbol.aliasable = adam->symbol.aliasable;
287                     d->symbol.equivalence = adam->symbol.equivalence;
288                     r = d->symbol.reference;
289                     r->reference.qualifier = base;
290                     if pl1_stat_$eis_mode
291                          then r -> reference.fo_in_qual = adam -> symbol.reference -> reference.fo_in_qual;
292                     i = d->symbol.boundary;
293 
294 /* If this members boundary requirement is less stringent than the boundary
295    forced upon it by the preceeding member, no rounding is needed and the
296    actual boundary of the member will be up graded to that determined by the
297    preceeding member.         */
298 
299                     if i<=j
300                     then do;
301                               d->symbol.boundary = j;
302                               go to get_offset;
303                     end;
304 
305 /* If the current boundary is less than word then round it to that needed by this member. */
306 
307                     if j < word_
308                     then do;
309                               if fsize = null
310                               then fc_size = divide(fc_size+round_const(j,i)-1,round_const(j,i),31,0);
311                               else do;
312                                         q = create_operator(opcodes(opcode_index(j,i)),2);
313                                         q->operand(2) = fsize;
314                                         fsize = q;
315                               end;
316                     end;
317 
318 /* If this member needs a mod boundary perform a mod operation on the current boundary.   */
319 
320                     if i > word_
321                     then do;
322                               if fsize = null
323                               then fc_size = divide(fc_size+mod_const(i)-1,mod_const(i),31,0)*mod_const(i);
324                               else do;
325                                         q = create_operator(mod_ops(i),2);
326                                         q->operand(2) = fsize;
327                                         fsize = q;
328                               end;
329                     end;
330 
331 /* set the units of the current boundary equal to the boundary requirement of this member.          */
332 
333                     j = i;
334 
335 
336 /* get this members offset by adding the fathers offset to the fathers current size.*/
337 
338 get_offset:
339                     t = f->reference.offset;
340 
341                     if        t ^= null
342                     then if   t -> node.type = operator_node
343                     then if   substr(t -> op_code,1,5) = substr(mod_bit,1,5)
344                     then      t = t -> operand(3);
345 
346                     r->reference.offset = t;
347                     r->reference.c_offset = f->reference.c_offset;
348                     k,r->reference.units = f->reference.units;
349 
350                     off = r->reference.offset;
351                     coff = r->reference.c_offset;
352 
353                     call offset_adder(off,coff,k,"0"b,(fsize),(fc_size),j,"0"b,r->reference.fo_in_qual);
354 
355                     r->reference.offset = off;
356                     r->reference.c_offset = coff;
357 
358                     if r->reference.c_offset = 0 & r->reference.offset = null
359                     then      r->reference.units = 0;
360                     else      r->reference.units = min(k,word_);
361 
362 /* If the offset is variable and the units are less than word and the offset is an expression
363    containing anything otherthan a simple bit_pointer, then create the proper mod operator
364    at the top of the expression.        */
365 
366                     if        ^pl1_stat_$eis_mode
367                     then if   r->reference.offset ^= null
368                     then if   r->reference.units < word_
369                     then do;
370                               q = r->reference.offset;
371 
372                               if q->node.type = operator_node
373                               then      if q->operator.op_code ^=bit_pointer
374                                         then do;
375                                                   p = create_operator(offset_ops(r->reference.units),3);
376                                                   p->operand(3)=q;
377                                                   r->reference.offset = p;
378                                         end;
379                                         else;
380                               else do;
381                                         p = create_operator(offset_ops(r->reference.units),3);
382                                         p->operand(3) = q;
383                                         r->reference.offset = p;
384                               end;
385                     end;
386 
387                     if        pl1_stat_$eis_mode
388                     then if   r->reference.units=character_
389                     then if   d->symbol.bit | d->symbol.binary | d->symbol.ptr
390                     then do;
391                               r->reference.units = bit_;
392                               r->reference.c_offset = r->reference.c_offset * bits_per_character;
393 
394                               if r->reference.offset^=null
395                               then do;
396                                         p = create_operator(mult,3);
397                                         p->operand(2) = declare_constant$integer(bits_per_character);
398                                         p->operand(3) = r->reference.offset;
399                                         r -> reference.offset = p;
400                               end;
401                     end;
402 
403 /* set padded bit for this member.      */
404 
405                     if d->symbol.packed
406                     then do;
407 /* walk father chain looking for next structure element */
408                               do q = d repeat q->symbol.father while(q^=null);
409                                         if q->symbol.brother ^= null then go to succ;
410                               end;
411 succ:
412                               if q = null
413                               then      r->reference.padded_ref = ^(d->symbol.based|d->symbol.parameter|d->symbol.defined);
414                               else      r->reference.padded_ref = q->symbol.brother->symbol.aligned;
415                     end;
416 
417 /* If this is an entry variable then process its decriptors.          */
418 
419                     if d->symbol.entry
420                     then do;
421                               if d->symbol.returns
422                               then do;
423                                         rv = d->symbol.dcl_size;
424                                         rv->symbol.return_value = "1"b;
425                                         if rv->symbol.structure | rv->symbol.dimensioned | rv->symbol.star_extents
426                                         then do;
427                                                   d->symbol.dcl_size = copy_expression(d->symbol.dcl_size);
428                                                   call declare(rv);
429                                                   d->symbol.dcl_size->symbol.star_extents = rv->symbol.star_extents;
430                                         end;
431                                         else      call declare(rv);
432                               end;
433                               do q = d->symbol.general repeat q->element(2) while(q^=null);
434                                         q->element(1)->symbol.param_desc ="1"b;
435                                         call declare((q->element(1)));
436                               end;
437                     end;
438 
439 /* Determine the size of the member.  If it is not a sub-structure it was computed by
440    get_size when the boundary was determined, otherwise it is computed now by calling
441    get_structure_size.  In both cases the c_length field of the reference node serves
442    to hold the units in which the size has been computed.  */
443 
444                     if d->symbol.structure then call get_structure_size(d);
445 
446 /* Add this members size to the father's current size.      */
447 
448                     call offset_adder(fsize,fc_size,j,"0"b,(d->symbol.word_size),(d->symbol.c_word_size),
449                               (r->reference.c_length),"0"b,"0"b);
450                     r->reference.c_length = 0;
451 
452                     if (d->symbol.char|d->symbol.bit) & ^d->symbol.varying
453                     then do;
454                               r->reference.c_length = d->symbol.c_dcl_size;
455                               r->reference.length = d->symbol.dcl_size;
456                     end;
457 
458                     if d->symbol.picture
459                     then      r->reference.c_length = d->symbol.c_dcl_size;
460           end;
461 
462 /* record the size of this structure in the symbol node, and the units in which the size
463    is measured in the reference node.   */
464 
465           s->symbol.reference->reference.c_length = j;
466           s->symbol.word_size = fsize;
467           s->symbol.c_word_size = fc_size;
468 
469 /* call get_size to find the size in bits, to find the array size, to improve the units
470    in which the size is measured, to round the size to an integeral number of words,etc.  */
471 
472           call get_size(s);
473 
474           end get_structure_size;
475 ^L
476 initialize:         proc(p);
477 
478 dcl       (p,q,r) ptr;
479 
480           r = p;
481 
482           do q = r repeat q->symbol.son while(q^=null);
483 
484                     if  q->symbol.auto
485                     &  (q->symbol.initialed
486                        |q->symbol.area)
487                     then      call expand_initial(q,null,null);
488 
489                     call initialize((q->symbol.brother));
490 
491           end;
492 
493           end initialize;
494 
495      end /* declare_structure */;