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 /* program to process operand of an operator node
 12 
 13           Modified:  21 May 1973 by RAB for multiple base regs
 14           Modified: 19 June 1973 by RAB for EIS
 15           Modified: 8 August 1974 by RAB to fix 1206
 16           Modified: 18 November 1974 by RAB to fix 1257, 1258
 17           Modified: 22 November 1974 by RAB to remove setting of passed_as_arg
 18           Modified: 26 June 1976 by RAB to fix 1503 (changed handling of
 19                     qualifier for defined_ref)
 20           Modified: 5 Oct 1976 by RAB to improve unspec(char_expr)
 21           Modified: 24 Nov 1976 by RAB to fix 1555
 22           Modified: 14 Sept 1977 by RAB to fix 1662
 23           Modified: 15 Dec 1977 by RAB to fix 1694
 24           Modified: 9 March 1978 by RAB to fix 1714 (setting of aligned_ref for packed decimal)
 25           Modified: 22 Jan 1979 by RAB to fix 1814 (ERROR 313 for multiple occurrences of
 26                     packed based qualifiers in if stmt)
 27                     pointer_chain now sets reference.evaluated after call to
 28                     base_man$load_packed
 29           Modified: 25 Apr 1979 by PCK to implement 4-bit decimal
 30           Modified: 4 Mar 1980 by PCK to fix 1910 and 1911
 31           Modified: 30 Mar 1980 by RAB to add reference.(padded aligned)_for_store_ref
 32                     as a partial fix to bug 1186, the famous PADDED REFERENCE BUG.
 33           Modified 830118 BIM to copy_temp on all pointers.
 34           Modified 830427 BIM to support ptr options (packed);
 35 */
 36 
 37 /* format: style3,^indnoniterdo,indend */
 38 prepare_operand:
 39      proc (pt, evaluate, atomic) returns (ptr);
 40 
 41 dcl       pt                  ptr,                          /* points at reference|operator node */
 42           evaluate            fixed bin,                    /* < 0 means evaluate offset but not size,
 43                                            = 0 means don't evaluate size or offset,
 44                                            > 0 means evaluate size and offset */
 45           atomic              bit (1) aligned;              /* set "1"b if operand is atomic */
 46 
 47 dcl       (p, p1, p2, q, s)   ptr,
 48           (cfo, eval, n, bit_length)
 49                               fixed bin,
 50           (str, useless, here_before, padded_bit)
 51                               bit (1) aligned,
 52           op_code             bit (9) aligned;
 53 
 54 dcl       (
 55           cg_stat$long_string_temp,
 56           cg_stat$cur_block,
 57           cg_stat$cur_statement,
 58           cg_stat$cur_node
 59           )                   ptr ext;
 60 
 61 dcl       (
 62           assign_op,
 63           compile_exp,
 64           stack_temp$assign_aggregate,
 65           state_man$update_ref
 66           )                   entry (ptr),
 67           adjust_ref_count    entry (ptr, fixed bin),
 68           state_man$update_reg
 69                               entry (ptr, bit (19) aligned),
 70           state_man$erase_reg entry (bit (19) aligned),
 71           (
 72           compile_exp$save,
 73           compile_exp$save_exp
 74           )                   entry (ptr) returns (ptr),
 75           eval_exp            entry (ptr, bit (1) aligned) returns (ptr),
 76           get_reference       entry returns (ptr),
 77           prepare_operand     entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
 78           copy_temp           entry (ptr) returns (ptr),
 79           generate_constant$real_fix_bin_1
 80                               entry (fixed bin) returns (ptr),
 81           check_o_and_s       entry (ptr) returns (ptr),
 82           load                entry (ptr, fixed bin),
 83           call_op             entry (ptr) returns (ptr),
 84           base_man$load_packed
 85                               entry (ptr, fixed bin),
 86           pointer_builtins    entry (ptr, bit (1) aligned),
 87           length_op           entry (ptr) returns (ptr),
 88           assign_desc_op      entry (ptr) returns (ptr),
 89           decimal_op$change_target
 90                               entry (ptr) returns (bit (1) aligned),
 91           decimal_op$get_float_temp
 92                               entry (fixed bin (24), bit (1) aligned) returns (ptr),
 93           assign_op$to_dec_scaled
 94                               entry (ptr, ptr);
 95 
 96 dcl       (addrel, divide, fixed, max, mod, null, string, substr)
 97                               builtin;
 98 
 99 dcl       fix_bin             (0:1) fixed bin based;
100 
101 dcl       io_class            init ("10000"b) bit (5) int static;
102 
103 %include cgsystem;
104 %include reference;
105 %include symbol;
106 %include array;
107 %include label;
108 %include operator;
109 %include nodes;
110 %include op_codes;
111 %include data_types;
112 %include boundary;
113 %include machine_state;
114 
115           p, q = pt;
116           atomic = "1"b;
117 
118           eval = evaluate;
119 
120           if p -> node.type = label_node
121           then do;
122 
123                q = get_reference ();
124                q -> reference.symbol = p;
125 
126 l1:
127                q -> reference.data_type = label_constant;
128                q -> reference.allocated = p -> label.allocated;
129                q -> reference.aliasable, q -> reference.temp_ref, q -> reference.defined_ref, q -> reference.allocate = "0"b;
130                goto l3;
131                end;
132 
133           if p -> node.type = operator_node
134           then do;
135 
136                if p -> operator.op_code = desc_size
137                then do;
138                     q = check_o_and_s (p);
139                     if q ^= null
140                     then goto go;
141                     end;
142 
143                q = p -> operand (1);
144 
145 /* check for expression already done */
146 
147                if q -> reference.evaluated
148                then if q -> reference.data_type = 0
149                     then goto l8a;
150                     else do;
151                          if eval > 0
152                          then if q -> reference.symbol -> node.type = symbol_node
153                               then if q -> reference.symbol -> symbol.return_value
154                                    then q -> reference.length = eval_exp ((q -> reference.length), "1"b);
155                          if ^q -> reference.aligned_ref
156                          then atomic = "0"b;
157                          goto done;
158                          end;
159 
160                if p -> operator.op_code = assign
161                then do;
162                     s = p -> operand (2);
163                     if s -> node.type ^= reference_node
164                     then goto l8;
165                     if s -> reference.symbol -> node.type ^= symbol_node
166                     then goto l8;
167                     if ^s -> reference.symbol -> symbol.arg_descriptor
168                     then goto l8;
169                     if ^q -> reference.symbol -> symbol.temporary
170                     then goto l8;
171 
172 /* have assignment of element of arg_descriptor to a temporary,
173                        eliminate the unnecessary assignment */
174 
175                     if q -> reference.shared
176                     then do;
177                          q = s;
178                          goto go;
179                          end;
180                     else do;
181                          q = assign_desc_op (p);
182                          go to exit;
183                          end;
184                     end;
185 
186                if p -> operator.op_code = length_fun
187                then do;
188                     q = length_op (p);
189                     go to exit;
190                     end;
191 
192                if p -> operator.op_code = std_call
193                then do;
194                     q = call_op (p);
195                     if ^q -> reference.aligned_ref
196                     then atomic = "0"b;
197                     goto done;
198                     end;
199 
200 l8:
201                eval = 0;
202 l8a:
203                atomic = "0"b;
204                end;
205 
206 /* set fields not yet set by declaration processor */
207 
208 go:
209           p1 = q -> reference.qualifier;
210           s = q -> reference.symbol;
211 
212           here_before = q -> reference.data_type ^= 0 & ^q -> reference.shared;
213 
214           if s -> node.type = label_node
215           then do;
216                p = s;
217                goto l1;
218                end;
219 
220           q -> reference.aggregate =
221                q -> reference.array_ref | s -> symbol.structure | s -> symbol.arg_descriptor | s -> symbol.storage_block
222                | ((s -> symbol.dimensioned | s -> symbol.member) & s -> symbol.temporary);
223 
224           q -> reference.aliasable =
225                s -> symbol.aliasable
226                | (s -> symbol.auto & (cg_stat$cur_block ^= s -> symbol.block_node) & s -> symbol.passed_as_arg);
227           q -> reference.temp_ref = q -> reference.temp_ref | s -> symbol.temporary;
228           q -> reference.allocated =
229                q -> reference.allocated | (s -> symbol.allocated & q -> reference.temp_ref = s -> symbol.temporary);
230           q -> reference.defined_ref = s -> symbol.defined & ^q -> reference.temp_ref;
231           q -> reference.allocate =
232                q -> reference.allocate | s -> symbol.allocate | q -> reference.ref_count > 0 | q -> reference.aggregate
233                | ^q -> reference.temp_ref;
234 
235 /*                            THE PADDED REFERENCE PROBLEM
236 
237           The code generator uses reference.aligned_ref to specify that an
238           operand may be directly used in a computation with a register
239           (such as addition or intersection) without first extracting it by
240           shifting and/or masking.  Prepare_operand develops this bit from
241           various sources, such as the offset units, symbol.packed, and
242           reference.padded_ref.  reference.padded_ref specifies that the
243           reference is that last in a machine word and that zeroes may be
244           considered to exist between the rightmost bit of the reference and
245           the right end of the machine word, if there is any gap.  The semantic
246           translator develops the bit for packed items only under the assumption
247           that unpacked items are always padded.  A level-one packed item is
248           considered padded if the declaration is for an original generation of
249           storage rather than for an alias of an original generation; thus a
250           level-one item is padded if it is neither based, defined, nor parameter.
251           Packed structure members are considered padded only if they abut the
252           right end of a word, if the next item to the right is unpacked, or if
253           they abut the right end of a padded structure.  This setting is
254           generally correct ignoring considerations of the substr pseudovariable.
255           The semantic translator furthermore considers all substr references
256           to be unpadded since there may be more non-zero bits to the right in
257           the full generation of the string.  Since the substr pseudovariable may
258           only set part of a string, it makes sense to assume that the target
259           of a substr is unpadded unless the compiler can prove that the whole
260           string is set before it is fetched and other conditions for
261           padded references hold.  Here comes the reason for the bug.  The
262           code generator marks vars that are passed_as_arg or parameters as
263           always unpadded (even if unpacked) because their aliases might be
264           set by substr, but ignores more complete aliasing rules. Furthermore,
265           until 30 March 1980, the code generator used the same bits to determine
266           whether an item should be padded when stored as were used to
267           determine padded fetches.  The combination of these 2 flaws allowed
268           for vars to be stored unpadded, but fetched padded.  Since 30 March
269           1980, this has been partially corrected by determining whether to
270           zero out remaining bits in a word independently from whether it
271           might be a target of substr elsewhere.  Thus reference.aligned_for_storre_ref
272           and reference.padded_for_store_ref are introduced.  A complete fix
273           would involve using more complete aliasing rules and attempting to
274           ensure that all potential substr targets were somehow initialized
275           with proper padding, if necessary.  (Note that the Multics implementation
276           allocates static and controlled vars from storage that is preinitialized
277           to zeroes, so the problem only exists for vars whose original generation
278           is automatic or based.)  A complete fix would be incompatable with
279           pre March 30, 1980 behavior because of aliasing problems.  It is
280           hoped the fix of March 30, 1980 will greatly reduce that
281           incompatability so that the complete fix might be tried after several
282           years.
283 */
284 
285           q -> reference.padded_for_store_ref = q -> reference.padded_ref;
286 
287           if ^s -> symbol.packed
288           then do;
289                padded_bit,
290                     q -> reference.padded_for_store_ref =
291                     ^q -> reference.substr | q -> reference.c_length = s -> symbol.c_dcl_size;
292 
293                if ^(s -> symbol.parameter | (s -> symbol.defined & s -> symbol.overlayed))
294                then q -> reference.padded_ref = padded_bit;
295                end;
296 
297 /* The following is a bad remnant of the old padded reference scheme
298              that we hope to drop, eventually.  Note that reference.padded_for_store_ref
299              is not affected. */
300 
301           if s -> symbol.passed_as_arg
302           then if ^s -> symbol.constant
303                then q -> reference.padded_ref = "0"b;
304 
305           /* end of code that we eventually hope to drop */
306 
307           if p1 ^= null
308           then if p1 -> node.type ^= temporary_node
309                then if eval ^= 0
310                     then if ^q -> reference.defined_ref
311                          then call pointer_chain (q);
312                          else call defined_chain (q);
313 
314 /* encode data type of reference */
315 
316           if s -> symbol.binary
317           then do;
318                if s -> symbol.fixed
319                then if s -> symbol.c_dcl_size > max_p_fix_bin_1
320                     then n = real_fix_bin_2;
321                     else n = real_fix_bin_1;
322                else if s -> symbol.c_dcl_size > max_p_flt_bin_1
323                then n = real_flt_bin_2;
324                else n = real_flt_bin_1;
325 
326                if s -> symbol.complex
327                then n = n + 4;
328                goto set;
329                end;
330 
331           if s -> symbol.decimal
332           then do;
333                n = real_fix_dec + fixed (s -> symbol.float, 1);
334                if s -> symbol.complex
335                then n = n + 2;
336 
337 set:
338                q -> reference.data_type = n;
339                goto l2;
340                end;
341 
342           if s -> symbol.char | s -> symbol.picture
343           then do;
344                q -> reference.data_type = char_string;
345                goto l2;
346                end;
347 
348           if s -> symbol.bit
349           then do;
350                q -> reference.data_type = bit_string;
351                goto l2;
352                end;
353 
354           if s -> symbol.offset
355           then do;
356                q -> reference.data_type = real_fix_bin_1;
357                goto l2;
358                end;
359 
360           if s -> symbol.ptr
361           then do;
362                if q -> reference.temp_ref      /* temp ptr operands are copied */
363                then if q -> reference.shared   /* so they can be in the machine state correctly */
364                then do;
365                          q = copy_temp (q);
366                          q -> reference.ref_count = 2; /* create, then use */
367                          if p -> node.type = operator_node
368                          then p -> operator.operand (1) = q;
369                     end;
370                q -> reference.data_type = unpacked_ptr + fixed (s -> symbol.packed | s -> symbol.unaligned | s -> symbol.explicit_packed, 1);
371                goto l2;
372                end;
373 
374           if s -> symbol.label
375           then do;
376                q -> reference.data_type = label_variable - fixed (s -> symbol.local, 1);
377                goto l2;
378                end;
379 
380           if s -> symbol.arg_descriptor
381           then do;
382                q -> reference.data_type = real_fix_bin_1;
383                goto l2;
384                end;
385 
386           if s -> symbol.file
387           then do;
388                q -> reference.data_type = local_label_variable;
389                goto l2;
390                end;
391 
392           if s -> symbol.format
393           then do;
394                q -> reference.data_type = local_label_variable - fixed (s -> symbol.constant, 1);
395                goto l2;
396                end;
397 
398           if s -> symbol.area
399           then do;
400                q -> reference.data_type = real_fix_bin_2;
401                go to l2;
402                end;
403 
404           if s -> symbol.entry
405           then if s -> symbol.variable | s -> symbol.temporary
406                then q -> reference.data_type = entry_variable;
407                else if s -> symbol.external
408                then q -> reference.data_type = ext_entry_in + fixed (s -> symbol.initial = null);
409                else q -> reference.data_type = int_entry;
410 
411 l2:
412           str = s -> symbol.char | s -> symbol.bit | s -> symbol.picture;
413 
414           if here_before
415           then do;
416                if (s -> symbol.packed & ^(str | s -> symbol.decimal))
417                     | (str & ^(q -> reference.long_ref | q -> reference.varying_ref))
418                then if ^q -> reference.aligned_ref
419                     then atomic = "0"b;
420 
421                goto done;
422                end;
423 
424           n = q -> reference.units;
425           if n = 0
426           then n, q -> reference.units = word_;
427 
428           else if n ^= word_ & q -> reference.offset = null
429           then if mod (q -> reference.c_offset, units_per_word (n)) = 0
430                then do;
431                     q -> reference.c_offset = divide (q -> reference.c_offset, units_per_word (n), 17, 0);
432                     n, q -> reference.units = word_;
433                     end;
434 
435           q -> reference.aligned_for_store_ref, q -> reference.aligned_ref = n = word_ & ^q -> reference.fo_in_qual;
436 
437           if n < word_
438           then if q -> reference.data_type > 0
439                then if q -> reference.data_type = char_string | (s -> symbol.decimal & ^s -> symbol.unaligned)
440                     then if n ^= character_
441                          then call bad;
442                          else ;
443                     else if s -> symbol.decimal & s -> symbol.unaligned
444                     then if n ^= digit_
445                          then call bad;
446                          else ;
447                     else if n ^= bit_
448                     then call bad;
449 
450           if str
451           then do;
452 
453                bit_length = q -> reference.c_length * convert_size (q -> reference.data_type);
454                if q -> reference.c_length = 0 & q -> reference.length = null
455                then q -> reference.aligned_for_store_ref, q -> reference.aligned_ref = "1"b;
456 
457                if q -> reference.length ^= null
458                then do;
459                     q -> reference.long_ref = "1"b;
460                     if q -> reference.shared
461                     then go to l3;                          /* This catches call from mst for symbol.reference */
462                     q -> reference.big_length = is_big ((q -> reference.length));
463                     go to l3;
464                     end;
465 
466                if q -> reference.c_length > max_short_size (q -> reference.data_type)
467                then do;
468                     q -> reference.big_length = q -> reference.c_length > max_index_register_value;
469                     q -> reference.long_ref = "1"b;
470                     if q -> reference.temp_ref
471                     then call check_assign;
472                     go to l3;
473                     end;
474 
475                if q -> reference.varying_ref
476                then do;
477                     q -> reference.big_length = "1"b;
478                     if q -> reference.symbol -> symbol.dcl_size = null
479                     then if q -> reference.symbol -> symbol.c_dcl_size <= max_index_register_value
480                          then q -> reference.big_length = "0"b;
481                     go to l3;
482                     end;
483 
484                q -> reference.aligned_ref =
485                     q -> reference.aligned_ref & (q -> reference.padded_ref | mod (bit_length, bits_per_word) = 0);
486 
487                q -> reference.aligned_for_store_ref =
488                     q -> reference.aligned_for_store_ref
489                     & (q -> reference.padded_for_store_ref | mod (bit_length, bits_per_word) = 0);
490                goto l5b;
491                end;
492 
493           bit_length = q -> reference.c_length;
494 
495           if bit_length = 0
496           then do;
497                if s -> symbol.array = null
498                then bit_length = s -> symbol.c_bit_size;
499                else bit_length = s -> symbol.array -> array.c_element_size_bits;
500 
501                if s -> symbol.decimal
502                then if s -> symbol.unaligned
503                     then do;
504                          if s -> symbol.float
505                          then q -> reference.c_length = s -> symbol.c_dcl_size + 3;
506                          else q -> reference.c_length = s -> symbol.c_dcl_size + 1;
507 
508                          if s -> symbol.complex
509                          then q -> reference.c_length = 2 * q -> reference.c_length;
510                          end;
511                     else q -> reference.c_length = divide (bit_length, bits_per_char, 24, 0);
512                else q -> reference.c_length = bit_length;
513                end;
514 
515           if s -> symbol.decimal
516           then do;
517                call prepare_decimal;
518                if s -> symbol.packed
519                then do;
520                     q -> reference.aligned_ref =
521                          q -> reference.aligned_ref & (q -> reference.padded_ref | mod (bit_length, bits_per_word) = 0);
522                     q -> reference.aligned_for_store_ref =
523                          q -> reference.aligned_for_store_ref
524                          & (q -> reference.padded_for_store_ref | mod (bit_length, bits_per_word) = 0);
525                     end;
526                go to l5b;
527                end;
528 
529           if s -> symbol.packed
530           then do;
531                if s -> symbol.binary
532                     & ^(q -> reference.data_type = real_fix_bin_1 | q -> reference.data_type = real_flt_bin_1)
533                then do;
534                     q -> reference.aligned_ref =
535                          q -> reference.aligned_ref
536                          & (s -> symbol.boundary > word_ & mod (bit_length, bits_per_two_words) = 0);
537                     q -> reference.aligned_for_store_ref =
538                          q -> reference.aligned_for_store_ref
539                          & (s -> symbol.boundary > word_ & mod (bit_length, bits_per_two_words) = 0);
540                     end;
541 
542                else if ^s -> symbol.ptr
543                then do;
544                     if s -> symbol.structure
545                     then do;
546                          q -> reference.aligned_ref = q -> reference.aligned_ref & q -> reference.padded_ref;
547                          q -> reference.aligned_for_store_ref =
548                               q -> reference.aligned_for_store_ref & q -> reference.padded_for_store_ref;
549                          end;
550                     q -> reference.aligned_ref = q -> reference.aligned_ref & (mod (bit_length, bits_per_word) = 0);
551                     q -> reference.aligned_for_store_ref =
552                          q -> reference.aligned_for_store_ref & (mod (bit_length, bits_per_word) = 0);
553                     end;
554 l5b:
555                if ^q -> reference.aligned_ref
556                then atomic = "0"b;
557                end;
558 
559 l3:
560           if q -> reference.aggregate & q -> reference.temp_ref
561           then do;
562 
563 /* this is an aggregate temp, walk back to level 1 ancestor and
564                     assign storage if non-already assigned */
565 
566                do p2 = s repeat (p2 -> symbol.father) while (p2 -> symbol.father ^= null);
567                end;
568 
569                if p2 -> symbol.initial = null
570                then call stack_temp$assign_aggregate (p2);
571                end;
572 
573 /* develop hard_to_load bit */
574 
575           if ^q -> reference.aligned_ref
576           then if q -> reference.fo_in_qual
577                then q -> reference.hard_to_load = "1"b;
578                else do;
579                     n = q -> reference.units;
580                     if n < word_
581                     then if q -> reference.offset ^= null & ^q -> reference.modword_in_offset
582                          then q -> reference.hard_to_load = "1"b;
583                          else if ^q -> reference.long_ref
584                          then do;
585                               cfo = mod (q -> reference.c_offset * convert_offset (n), bits_per_word);
586                               if cfo < 0
587                               then cfo = cfo + bits_per_word;
588                               q -> reference.hard_to_load = cfo + bit_length > bits_per_two_words;
589                               end;
590                     end;
591 
592           if eval = 0
593           then goto done;
594 
595           if eval > 0
596           then if q -> reference.length ^= null
597                then q -> reference.length = eval_exp ((q -> reference.length), (q -> reference.big_length));
598 
599           if q -> reference.offset ^= null
600           then do;
601                if n < word_ & ^q -> reference.modword_in_offset
602                then do;
603                     q -> reference.big_offset = q -> reference.big_offset | is_big ((q -> reference.offset));
604                     end;
605 
606                q -> reference.offset = eval_exp ((q -> reference.offset), (q -> reference.big_offset));
607                end;
608 
609 done:
610           q -> reference.no_address = "1"b;
611           q -> reference.perm_address = "0"b;
612 
613           if q -> reference.defined_ref
614           then do;
615                if p1 = null
616                then goto exit;
617 
618                if p1 -> node.type = operator_node
619                then p1 = p1 -> operand (1);
620 
621                if p1 -> reference.temp_ref
622                then do;
623 
624                     if substr (string (p1 -> reference.value_in), 1, 2) = "00"b
625                     then goto def_done;
626 
627                     if q -> reference.hard_to_load
628                     then go to erase_no_update;
629 
630 /* the defined base is in A or Q register */
631 
632                     if q -> reference.data_type ^= bit_string
633                     then do;
634                          if q -> reference.data_type ^= p1 -> reference.data_type
635                          then go to erase_no_update;
636 
637 same:
638                          string (q -> reference.value_in) =
639                               string (q -> reference.value_in) | string (p1 -> reference.value_in);
640                          call state_man$erase_reg (substr (string (p1 -> reference.value_in), 1, 2));
641                          call state_man$update_reg (q, string (q -> reference.value_in));
642                          if q -> reference.value_in.a
643                          then if p1 -> reference.data_type = char_string
644                               then if a_reg.size < p1 -> reference.c_length * bits_per_char
645                                    then a_reg.length = a_reg.size + a_reg.offset;
646                          goto exit;
647                          end;
648 
649 /* the defined temporary is a bit string (possibly from unspec or substr) */
650 
651                     if p1 -> reference.data_type ^= bit_string
652                     then do;
653                          if p1 -> reference.data_type = real_fix_bin_1
654                          then goto same;
655                          if p1 -> reference.data_type = packed_ptr
656                          then goto same;
657                          if p1 -> reference.data_type = char_string
658                          then goto same;
659 
660                          if p1 -> reference.data_type = real_fix_bin_2 | p1 -> reference.data_type = unpacked_ptr
661                          then do;
662                               q -> reference.value_in.a = "1"b;
663                               call state_man$update_reg (q, "1"b);
664                               goto exit;
665                               end;
666 
667 erase_no_update:
668                          call state_man$erase_reg (substr (string (p1 -> reference.value_in), 1, 2));
669                          end;
670                     else do;
671                          call state_man$erase_reg (substr (string (p1 -> reference.value_in), 1, 2));
672                          call state_man$update_ref (q);
673                          if a_reg.size < p1 -> reference.c_length
674                          then a_reg.length = a_reg.size + a_reg.offset;
675                          end;
676 
677 def_done:
678                     end;
679                else do;
680                     q -> reference.allocate, q -> reference.allocated = "1"b;
681                     q -> reference.temp_ref = "0"b;
682                     end;
683 
684                end;
685 
686 exit:
687           return (q);
688 
689 pointer_chain:
690      proc (pt);
691 
692 dcl       (pt, qp, tp, sp, rp)
693                               ptr,
694           dummy               fixed bin,
695           useless             bit (1) aligned,
696           op_code             bit (9) aligned;
697 
698           qp = pt -> reference.qualifier;
699           if qp -> node.type = reference_node
700           then do;
701                qp = prepare_operand (qp, 1, useless);
702                return;
703                end;
704 
705           tp = qp -> operand (1);
706           if tp -> reference.evaluated
707           then return;
708 
709           op_code = qp -> operator.op_code;
710           if op_code = std_call
711           then do;
712                pt -> reference.qualifier = call_op (qp);
713                return;
714                end;
715 
716           if op_code = addr_fun
717           then do;
718                qp -> operand (2) = prepare_operand ((qp -> operand (2)), 1, useless);
719                return;
720                end;
721 
722           sp = tp -> reference.symbol;
723 
724           if op_code = assign /* must be (unpacked temp) <- (packed) */
725           then do;
726                if qp -> operator.operand (1) -> reference.temp_ref
727                then if qp -> operator.operand (1) -> reference.shared
728                then qp -> operator.operand (1) = copy_temp ((qp -> operator.operand (1)));
729                call base_man$load_packed (qp, dummy);
730                qp -> operand (1) -> reference.evaluated = "1"b;
731                return;
732                end;
733 
734           if op_code = param_ptr
735           then return;
736           if op_code = param_desc_ptr
737           then return;
738 
739 /* must be a pointer valued builtin function */
740 
741           if sp -> symbol.temporary
742           then if tp -> reference.shared
743                then qp -> operand (1) = copy_temp (tp);
744 
745           call pointer_builtins (qp, "0"b);
746           qp -> operand (1) -> reference.evaluated = "1"b;
747 
748      end;
749 
750 
751 defined_chain:
752      proc (pt);
753 
754 dcl       (pt, qp, rp)        ptr;
755 dcl       atomic              bit (1) aligned;
756 
757           qp = pt -> reference.qualifier;
758 
759           if qp -> node.type = reference_node
760           then qp = prepare_operand (qp, 1, atomic);
761           else if ^qp -> operand (1) -> reference.evaluated
762           then do;
763                rp = prepare_operand (qp, 1, atomic);
764                if ^atomic
765                then rp = compile_exp$save_exp (qp);
766                end;
767 
768      end;
769 
770 
771 is_big:
772      proc (pt) reducible returns (bit (1) aligned);
773 
774 /* is_big determines if the precision of an offset or length expression is
775    too big to fit in an index register */
776 
777 dcl       (p, pt)             ptr;
778 dcl       result              bit (1) aligned;
779 
780           p = pt;
781 
782           if p -> node.type = operator_node
783           then if p -> operator.op_code = length_fun
784                then do;
785                     p = p -> operand (2);
786                     if p -> node.type = operator_node
787                     then p = p -> operand (1);
788                     p = p -> reference.symbol;
789                     result = "1"b;
790                     if p -> symbol.dcl_size = null
791                     then if p -> symbol.c_dcl_size <= max_index_register_value
792                          then result = "0"b;
793                     return (result);
794                     end;
795                else p = p -> operand (1);
796 
797           return (p -> reference.symbol -> symbol.c_dcl_size > max_p_xreg);
798 
799      end;
800 
801 
802 check_assign:
803      proc;
804 
805 /* This code is necessary because assign_op cannot have a shared temporary
806    as the target of a conversion to long string */
807 
808 dcl       p2                  ptr;
809 
810           if q -> reference.shared
811           then if p -> node.type = operator_node
812                then if substr (p -> operator.op_code, 1, 5) = "00011"b
813                                                             /* assign class */
814                     then do;
815                          p2 = p -> operand (2);
816                          if p2 -> node.type = operator_node
817                          then p2 = p2 -> operand (1);
818                          if (string (p2 -> reference.symbol -> symbol.data_type) & "0111111111111111111"b)
819                               ^= (string (s -> symbol.data_type) & "0111111111111111111"b)
820                          then q, p -> operand (1) = copy_temp (q);
821                          end;
822 
823      end;
824 
825 
826 prepare_decimal:
827      proc;
828 
829 /* prepare_decimal is needed to make up for a disagreement between the hardware and
830    the language.  PL/I allows scales from -128 to 127 while the hardware will only take
831    decimal scales from -31 to +32.  In order to get around this restriction, we must,
832    in most cases, replace any fixed decimal temporaries whose scale is outside the
833    hardware limits to floating temporaries of the same precision.  */
834 
835 dcl       r                   ptr;
836 dcl       (
837           i,
838           scale               (3)
839           )                   fixed bin;
840 
841           if s -> symbol.temporary
842           then if s -> symbol.fixed
843                then if s -> symbol.scale < min_dec_scale | s -> symbol.scale > max_dec_scale
844                     then if p -> node.type = operator_node
845                          then if p -> operator.number >= 3
846                               then if p -> operator.op_code ^= complex_fun
847                                    then if p -> operator.op_code ^= round_fun
848                                         then do;
849                                              if decimal_op$change_target (p)
850                                              then do;
851                                                   r = decimal_op$get_float_temp (s -> symbol.c_dcl_size,
852                                                        (s -> symbol.complex));
853 
854                                                   if cg_stat$cur_node ^= null
855                                                   then if cg_stat$cur_node -> operator.op_code = std_call
856                                                        then go to keep_fixed;
857                                                        else if substr (cg_stat$cur_node -> operator.op_code, 1, 5) = io_class
858                                                        then go to keep_fixed;
859 
860                                                   if s -> symbol.c_dcl_size < max_p_fix_dec
861                                                   then do;
862                                                        if ^q -> reference.shared
863                                                        then r -> reference.ref_count = q -> reference.ref_count;
864                                                        q, p -> operand (1) = r;
865                                                        s = r -> reference.symbol;
866                                                        end;
867                                                   else do;
868 keep_fixed:
869                                                        p -> operand (1) = r;
870                                                        r = compile_exp$save (p);
871                                                        if q -> reference.shared
872                                                        then q = copy_temp (q);
873                                                        call assign_op$to_dec_scaled (q, r);
874                                                        p -> operand (1) = q;
875                                                        atomic = "1"b;
876                                                        end;
877                                                   end;
878                                              end;
879 
880      end;
881 
882 
883 
884 
885 bad:
886      proc;
887 
888 dcl       error               entry (fixed bin, ptr, ptr);
889 
890           if q -> reference.offset = null
891           then if q -> reference.temp_ref
892                then if q -> reference.data_type = real_fix_bin_1
893                     then return;
894 
895           call error (332, cg_stat$cur_statement, q);
896 
897      end;
898 
899      end;