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 
 12 
 13 /****^  HISTORY COMMENTS:
 14   1) change(86-07-15,Ginter), approve(86-07-15,MCR7287), audit(86-07-16,Mabey),
 15      install(86-07-28,MR12.0-1105):
 16      Bug fixes for the MR12.0 release of the compiler.
 17                                                    END HISTORY COMMENTS */
 18 
 19 
 20 /*        Modified: 781219 by RAB to fix 1806 (star_extent exprs get ERROR 316) */
 21 /*        Modified: 17 Mar 1980 by PCK to implement by name assignment */
 22 /*                  Also fixes 1878                                    */
 23 /*        Modified: 2 April 1980 by PCK to increase implementation limit
 24                     of the number of substructures that may immediately
 25                     be contained in a structure from a minimum of 256 to
 26                     a minimum of 32767 */
 27 /*        Modified: 7 June 1985 by MM to fix 2109 (by name assignments that
 28                     generate temporaries aren't handled correctly.) */
 29 
 30 /* format: style3 */
 31 expand_primitive:
 32      proc (blk, stmnt, input_tree, context) returns (ptr);
 33 
 34 dcl       (blk, stmnt, tree, input_tree, one, subs, loops, last, qual, p, a, b, s, symbols_block, bna)
 35                               ptr;
 36 dcl       (i, given, ndims, n, stars_given)
 37                               fixed bin (15);
 38 dcl       pds                 bit (1) aligned;
 39 dcl       pl1_stat_$eis_mode  bit (1) aligned ext static;
 40 dcl       pl1_stat_$by_name_parts_tree
 41                               ptr aligned ext static;
 42 
 43 dcl       null                builtin;
 44 ^L
 45           if input_tree -> node.type = operator_node
 46           then return (input_tree);
 47 ^L
 48 /* generates a LOOP/JOIN tree processed by subscripter and by expression_semantics */
 49 
 50           last, loops = null;
 51           this_context = "0"b;
 52           one = declare_constant$integer (1);
 53           stars_given, n = 0;
 54 
 55           if def_context.by_name_assignment
 56           then bna = pl1_stat_$by_name_parts_tree;
 57           else bna = null;
 58 
 59           s = input_tree -> reference.symbol;
 60 
 61           if s -> symbol.block_node = null
 62           then symbols_block = blk;
 63           else symbols_block = s -> symbol.block_node;
 64 
 65           if s -> symbol.reference = input_tree | input_tree -> reference.array_ref
 66           then do;
 67                     tree = create_reference ((input_tree -> reference.symbol));
 68                     tree -> reference = input_tree -> reference;
 69                end;
 70           else tree = input_tree;
 71 
 72 /*  handling the case of unsubscripted array reference */
 73 
 74           if s -> node.type = label_node
 75           then do;
 76                     b = create_bound ();
 77                     b -> bound.c_lower = s -> label.low_bound;
 78                     b -> bound.c_upper = s -> label.high_bound;
 79                     b -> bound.c_multiplier = 1;
 80                     subs = create_list (1);
 81                     subs -> list.element (1) = create_token ("*", asterisk);
 82                     given = 1;
 83                end;
 84           else do;
 85                     qual = tree -> reference.qualifier;
 86 
 87                     subs = tree -> reference.offset;
 88 
 89                     if subs = null
 90                     then given = 0;
 91                     else if subs -> node.type ^= list_node
 92                     then do;
 93                               given = 0;                    /*   simplify-offset may have already split the
 94                                                        offset into offset and c_offset with disastrous
 95                                                        results, therefore, undo the work   */
 96                               pds = tree -> reference.put_data_sw;
 97                               tree -> reference = tree -> reference.symbol -> symbol.reference -> reference;
 98                               tree -> reference.put_data_sw = pds;
 99                               tree -> reference.shared = "0"b;
100                               tree -> reference.ref_count = 1;
101                               subs = null;
102                          end;
103                     else do;
104                               subs = copy_expression ((subs));
105                                                             /* preserve original subs */
106                               given = subs -> list.number;
107                          end;
108 
109                     a = s -> symbol.array;
110 
111                     if a ^= null
112                     then ndims = a -> array.number_of_dimensions;
113                     else ndims = 0;
114 
115 /*   the case of an unsubscripted structure or a scalar   */
116                     if given = 0 & ndims = 0
117                     then return (expander (tree, bna));
118 
119                     if ndims ^= given & given ^= 0
120                     then call semantic_translator$abort (81, s);
121 
122                     b = a -> array.bounds;
123                     tree -> reference.offset = copy_expression (s -> symbol.reference -> reference.offset);
124                     if tree -> reference.length ^= null
125                     then tree -> reference.length = copy_expression (tree -> reference.length);
126                end;
127 
128 /*   This reference is (or will be) a fully subscripted array reference.
129 Implied asterisks will be added.  */
130 
131           if given = 0
132           then do;
133                     n, given = ndims;
134                     subs = create_list (ndims);
135 
136                     subs -> list.element (*) = create_token ("*", asterisk);
137                end;
138           else do i = 1 to given;                           /* count the asterisks */
139                     p = subs -> list.element (i);
140 
141                     if p -> node.type = token_node
142                     then if p -> token.type = asterisk
143                          then n = n + 1;
144                end;
145 
146           stars_given = n;
147 
148           do i = 1 to given;
149                p = subs -> list.element (i);
150 
151                if p -> node.type = token_node
152                then if p -> token.type = asterisk
153                     then do;
154                               p = make_loop (n, b, s);
155                               n = n - 1;
156                               p -> operand (1) = loops;
157                               loops = p;
158                               if last = null
159                               then last = p;
160 
161                               if b -> bound.c_lower ^= 1
162                               then do;
163                                         if b -> bound.lower = null
164                                         then b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
165                                         subs -> list.element (i) =
166                                              addf ((p -> operand (2)), subf (copy_expression (b -> bound.lower), one));
167                                    end;
168                               else subs -> list.element (i) = p -> operand (2);
169                          end;
170 
171                b = b -> bound.next;
172           end;
173 
174           tree -> reference.array_ref = "0"b;
175 
176           if s -> node.type = label_node
177           then do;
178                     p = subscripter (blk, stmnt, tree, subs, s);
179                     p -> reference.offset = expression_semantics (blk, stmnt, (p -> reference.offset), "0"b);
180                     call simplify_offset (p, context);
181                end;
182           else if s -> symbol.structure
183           then p = expander (tree, bna);
184           else p = process_subscripted_reference (tree, subs);
185 
186           if last = null
187           then return (p);
188 
189           last -> operand (1) = p;
190 
191           return (loops);
192 ^L
193 /* builds ALL loops for THIS level except as noted for the major structure */
194 
195 expander:
196      proc (tree, bna) returns (ptr);
197 
198 /* parameters */
199 
200 dcl       tree                ptr;                          /* reference to be expanded into loop/join operators */
201 dcl       bna                 ptr;                          /* by name parts tree--for expanding structure refs
202                               in by name assignments        */
203 
204 /* automatic */
205 
206 dcl       (s, a, q, qt, b, p, bnm, join_operator)
207                               ptr;
208 dcl       (k, i, n, m, our_last_index)
209                               fixed bin (15);
210 dcl       first_time          bit (1) aligned;
211 dcl       number_of_members   fixed bin (35);
212 
213           first_time = "1"b;
214           s = tree -> reference.symbol;
215           a = s -> symbol.array;
216 
217           if a ^= null
218           then do;
219                     n = a -> array.number_of_dimensions;
220                     m = n + 1 - a -> array.own_number_of_dimensions;
221                     our_last_index = n - given + stars_given;
222                end;
223 
224 /* If this is a structure call yourself for each son and collect the results.  */
225 
226           if s -> symbol.structure
227           then do;
228 
229                     k = 0;
230                     bnm = null;
231 
232 /* Expand all members of the structure if this is ordinary
233                        (not by name assignment) aggregate expansion, otherwise
234                        use the by name parts tree to select members that
235                        have names that match other structures in the by name
236                        assignment. */
237 
238                     if ^def_context.by_name_assignment
239                     then do;
240                               number_of_members = 0;
241                               do q = s -> symbol.son repeat q -> symbol.brother while (q ^= null);
242                                    number_of_members = number_of_members + 1;
243                               end;
244 
245                               if number_of_members > max_number_of_operands
246                               then call semantic_translator$abort (383, s);
247 
248                               join_operator = create_operator (join, (number_of_members));
249                               do q = s -> symbol.son repeat q -> symbol.brother while (q ^= null);
250                                    call expand_son (q, bnm);
251                               end;
252                          end;
253                     else do;
254                               number_of_members = 0;
255                               do bnm = bna -> by_name_agg.son repeat bnm -> by_name_agg.right_brother while (bnm ^= null);
256                                    number_of_members = number_of_members + 1;
257                               end;
258 
259                               if number_of_members > max_number_of_operands
260                               then call semantic_translator$abort (383, s);
261 
262                               join_operator = create_operator (join, (number_of_members));
263                               do bnm = bna -> by_name_agg.son repeat bnm -> by_name_agg.right_brother while (bnm ^= null);
264                                    do q = s -> symbol.son repeat q -> symbol.brother
265                                         while (q -> symbol.token ^= bnm -> by_name_agg.token);
266                                    end;
267                                    call expand_son (q, bnm);
268                               end;
269                          end;
270 
271 /* If this is not an array reference, return the join operator.  */
272 
273                     if ^tree -> reference.array_ref
274                     then return (join_operator);
275 
276                     q = join_operator;
277                     goto make_my_loops;
278                end;
279 
280 
281           if ^tree -> reference.array_ref
282           then do;
283                     if ^tree -> reference.processed
284                     then do;
285                               tree -> reference.qualifier = qual;
286 
287                               tree = expression_semantics (blk, stmnt, tree, this_context);
288                          end;
289 
290                     return (tree);
291                end;
292 
293 
294 /* create a set of subscripts adjusted to compensate for the fact that the loop will run from
295    1 to n rather than from lb to hb.    */
296 
297           b = a -> array.bounds;
298           q = create_list ((a -> array.number_of_dimensions));
299 
300           do i = 1 to n - given;
301                p = declare_index (our_last_index + 1 - i);
302                if b -> bound.c_lower ^= 1
303                then do;
304                          if b -> bound.lower = null
305                          then b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
306                          q -> list.element (i) = addf (p, subf (copy_expression (b -> bound.lower), one));
307                     end;
308                else q -> list.element (i) = p;
309 
310                b = b -> bound.next;
311           end;
312 
313           k = 0;
314 
315           do i = n - given + 1 to n;
316                k = k + 1;
317                q -> list.element (i) = copy_expression (subs -> list.element (k));
318           end;
319 
320           q = process_subscripted_reference (tree, q);
321 
322 
323 
324 /* make a loop operator for each dimension at THIS level; i.e., excluding inherited dimensions.  */
325 
326 make_my_loops:
327           b = a -> array.bounds;
328 
329           k = 0;
330 
331           if n ^= given
332           then do i = m to n;
333                     p = make_loop (our_last_index - k, b, s);
334                     p -> operand (1) = q;
335                     q = p;
336                     b = b -> bound.next;
337                     k = k + 1;
338                end;
339 
340 /* return the top loop operator.  */
341 
342           return (q);
343 
344 /* Expands a son of a structure into loop and join operators */
345 
346 expand_son:
347      procedure (q, bnm);
348 
349 /* parameters */
350 
351 dcl       q                   ptr;                          /* A son of the structure being expanded by expander */
352 dcl       bnm                 ptr;                          /* The corresponding point in the by_name_parts_tree or null */
353 
354           k = k + 1;
355 
356           qt = create_reference (q);
357           qt -> reference = q -> symbol.reference -> reference;
358           qt -> reference.shared = "0"b;
359           qt -> reference.ref_count = 1;
360           qt -> reference.length = copy_expression (qt -> reference.length);
361           qt -> reference.offset = copy_expression (qt -> reference.offset);
362 
363           if ^first_time
364           then qt -> reference.qualifier = share_expression (qual);
365           else do;
366                     first_time = "0"b;
367                     qt -> reference.qualifier = qual;
368 
369 /* force temp, if any, to be unshared so
370                        simplify_offset will not try to alter qualifier */
371 
372                     if qual ^= null
373                     then if qual -> node.type = operator_node
374                          then if qual -> operand (1) -> reference.shared
375                               then do;
376                                         qual -> operand (1) = copy_expression (qual -> operand (1));
377                                         qual -> operand (1) -> reference.shared = "0"b;
378                                         qual -> operand (1) -> reference.ref_count = 1;
379                                    end;
380                end;
381 
382           qt -> reference.put_data_sw = tree -> reference.put_data_sw;
383 
384           if tree -> reference.array_ref
385           then qt -> reference.array_ref = "1"b;
386           else if qt -> reference.symbol -> symbol.array ^= null
387           then if qt -> reference.symbol -> symbol.array -> array.own_number_of_dimensions ^= 0
388                then qt -> reference.array_ref = "1"b;
389                else qt -> reference.array_ref = "0"b;
390           else qt -> reference.array_ref = "0"b;
391 
392           if ^qt -> reference.array_ref & subs ^= null
393           then qt = process_subscripted_reference (qt, copy_expression ((subs)));
394 
395           join_operator -> operator.operand (k) = expander (qt, bnm);
396 
397           return;
398 
399      end /* expand_son */;
400 
401      end /* expander */;
402 ^L
403 process_subscripted_reference:
404      proc (tree, subs) returns (ptr);
405 
406 dcl       (tree, subs, p, s)  ptr;
407 
408 dcl       constant            fixed bin,
409           modified            bit (1) aligned;
410 
411 dcl       pl1_stat_$locator   (128) ptr ext static,
412           pl1_stat_$index     fixed bin (15) ext static;
413 
414           s = tree -> reference.symbol;
415 
416           if qual ^= null
417           then do;
418                     pl1_stat_$index = pl1_stat_$index + 1;
419                     if pl1_stat_$index > hbound (pl1_stat_$locator, 1)
420                     then do;
421                               call semantic_translator$abort (70, s);
422                               return (null);
423                          end;
424                     pl1_stat_$locator (pl1_stat_$index) = tree;
425                end;
426 
427           if s -> symbol.defined
428           then p = defined_reference (blk, stmnt, tree, subs, s, this_context);
429           else p = subscripter (blk, stmnt, tree, (subs), s);
430 
431           p -> reference.array_ref = "0"b;
432 
433           if s -> symbol.defined
434           then ;
435           else p -> reference.qualifier = qual;
436 
437           if p -> reference.offset ^= null
438           then do;
439                     if ^pl1_stat_$eis_mode
440                     then call bit_ptr ((p -> reference.offset), qual);
441                     p -> reference.offset =
442                          expression_semantics (symbols_block, stmnt, (p -> reference.offset), this_context);
443 
444                     p -> reference.offset = convert$to_integer ((p -> reference.offset), integer_type);
445 
446                     call simplify_expression ((p -> reference.offset), constant, modified);
447 
448                     if modified
449                     then do;
450                               p -> reference.offset = null;
451                               p -> reference.c_offset = constant;
452                          end;
453                end;
454 
455           if p -> reference.length ^= null
456           then do;
457                     p -> reference.length =
458                          expression_semantics (symbols_block, stmnt, (p -> reference.length), this_context);
459                     p -> reference.length = convert$to_integer ((p -> reference.length), integer_type);
460                end;
461 
462           call simplify_offset (p, context);
463 
464           if qual ^= null
465           then pl1_stat_$index = pl1_stat_$index - 1;
466 
467           p -> reference.processed = "1"b;                  /* otherwise expression_semantics might destroy offset, modword... */
468 
469           return (p);
470 
471      end process_subscripted_reference;
472 ^L
473 /* subroutine to create a loop operator */
474 
475 make_loop:
476      proc (i, b, s) returns (ptr);
477 
478 dcl       i                   fixed bin (15);
479 dcl       constant_field      fixed bin;
480 dcl       (p, q, b, s, lower, upper)
481                               ptr;
482 dcl       (constant, modified)
483                               bit (1) aligned;
484 
485           if b -> bound.lower = null
486           then lower, b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
487           else lower = copy_expression (b -> bound.lower);
488 
489           if b -> bound.upper = null
490           then upper, b -> bound.upper = declare_constant$integer ((b -> bound.c_upper));
491           else upper = copy_expression (b -> bound.upper);
492 
493           p = create_operator (loop, 5);
494           p -> operand (2) = declare_index ((i));
495           p -> operand (3) = one;
496 
497           if lower -> node.type = reference_node & upper -> node.type = reference_node
498           then if lower -> reference.symbol -> node.type = symbol_node
499                     & upper -> reference.symbol -> node.type = symbol_node
500                then if lower -> reference.symbol -> symbol.constant & upper -> reference.symbol -> symbol.constant
501                     then constant = "1"b;
502                     else constant = "0"b;
503                else constant = "0"b;
504           else constant = "0"b;
505 
506           if b -> bound.c_lower = 1
507           then p -> operand (4) = upper;
508           else if constant
509           then p -> operand (4) = declare_constant$integer (b -> bound.c_upper - b -> bound.c_lower + 1);
510           else p -> operand (4) = subf (upper, subf (lower, one));
511 
512           q = p -> operand (4);
513           call refer_extent (q, qual);
514 
515           p -> operand (4) = expression_semantics (symbols_block, stmnt, q, this_context);
516           p -> operand (4) = convert$to_integer ((p -> operand (4)), integer_type);
517 
518           call simplify_expression ((p -> operand (4)), constant_field, modified);
519 
520           if modified
521           then p -> operand (4) = declare_constant$integer ((constant_field));
522 
523           return (p);
524 
525      end make_loop;
526 ^L
527 /* subroutine to declare an index variable.  */
528 
529 declare_index:
530      proc (i) returns (ptr);
531 
532 dcl       i                   fixed bin (7);
533 dcl       (t, d)              ptr;
534 
535           t = create_token ("s." || bindec$vs ((i)), identifier);
536 
537           do d = t -> token.declaration repeat d -> symbol.multi_use while (d ^= null);
538                if d -> symbol.block_node = blk
539                then return (d -> symbol.reference);
540           end;
541 
542           d = create_symbol (blk, t, by_compiler);
543           d -> symbol.fixed, d -> symbol.binary, d -> symbol.real, d -> symbol.auto, d -> symbol.allocate = "1"b;
544 
545           call declare (d);
546 
547           return (d -> symbol.reference);
548 
549      end declare_index;
550 ^L
551 /* subroutine to create expressions. */
552 
553 addf:
554      proc (a, b) returns (ptr);
555 
556 dcl       (a, b, c)           ptr;
557 dcl       opcode              bit (9) aligned;
558 
559           opcode = add;
560 
561           go to common;
562 
563 subf:
564      entry (a, b) returns (ptr);
565 
566           opcode = sub;
567 common:
568           c = create_operator (opcode, 3);
569           c -> operand (2) = a;
570           c -> operand (3) = b;
571 
572           return (c);
573 
574      end addf;
575 ^L
576 bit_ptr:
577      proc (exp, q);
578 
579 dcl       (exp, q)            ptr;
580 dcl       i                   fixed bin (15);
581 
582           if exp = null
583           then return;
584           if exp -> node.type ^= operator_node
585           then return;
586 
587           if exp -> op_code = bit_pointer
588           then do;
589                     exp -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
590                     exp -> operand (2) = share_expression (q);
591                     exp -> operator.processed = "1"b;
592                end;
593           else do i = 2 to exp -> operator.number;
594                     call bit_ptr ((exp -> operand (i)), q);
595                end;
596 
597      end bit_ptr;
598 ^L
599 %include semant;
600 %include array;
601 %include by_name_agg;
602 %include declare_type;
603 %include label;
604 %include list;
605 %include nodes;
606 %include op_codes;
607 %include operator;
608 %include reference;
609 %include semantic_bits;
610 %include symbol;
611 %include system;
612 %include token;
613 %include token_types;
614 
615      end expand_primitive;