1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62 %page;
63 assign_op:
64 proc (pt);
65
66
67 dcl pt ptr parameter;
68
69
70 dcl (p, p1, p2, s1, s2, b2, q, q1, q2) ptr;
71 dcl exp_pt ptr;
72 dcl arg (3) ptr;
73 dcl top ptr;
74 dcl (a, b, i, type1, type2, k, size1, size2) fixed bin;
75 dcl (length1, length2, aq_used, scale1, scale2) fixed bin;
76 dcl (prec1, prec2, ds, d, dt, cfo, orig_count, units_per_wrd) fixed bin;
77 dcl (atomic, all_blanks, all_ones, all_zeros, all_same) bit (1) aligned;
78 dcl (loaded, last_macro, hard1, hard2, here_before) bit (1) aligned;
79 dcl (load_it, right_constant, check_size, no_store) bit (1) aligned;
80 dcl (pack_char_pic, always_round, refs_are_same) bit (1) aligned;
81 dcl base bit (3) aligned;
82 dcl tag bit (4) aligned;
83 dcl op_code bit (9) aligned;
84 dcl full_word bit (36) aligned;
85 dcl c_length fixed bin (24);
86 dcl word bit (36) aligned based;
87 dcl double_string bit (72) aligned;
88 dcl (m1, m2, macro, bump_mac, size_ck_macro) fixed bin (15);
89
90
91 dcl cg_stat$cur_level fixed bin external;
92 dcl cg_stat$cur_statement ptr external;
93 dcl cg_stat$cur_tree ptr ext;
94 dcl cg_stat$null_value bit (72) aligned external;
95 dcl cg_stat$packed_null_value fixed bin external;
96 dcl cg_stat$save_exp_called bit (1) external;
97 dcl cg_stat$temp_ref ptr external;
98 dcl cg_stat$text_base ptr external;
99 dcl cg_stat$text_pos fixed bin external;
100
101
102 dcl adjust_ref_count entry (ptr, fixed bin);
103
104 dcl aq_man$check_strings entry (fixed bin);
105 dcl aq_man$left_shift entry (fixed bin (8), bit (1) aligned);
106 dcl aq_man$lock entry (ptr, fixed bin);
107 dcl aq_man$right_shift entry (fixed bin (8), bit (1) aligned);
108 dcl aq_man$trim_aq entry (fixed bin);
109
110 dcl base_to_core entry (fixed bin, ptr);
111 dcl base_man$load_any_var entry (fixed bin, ptr) returns (bit (3) aligned);
112 dcl base_man$load_packed entry (ptr, fixed bin);
113 dcl base_man$load_var entry (fixed bin, ptr, fixed bin);
114 dcl base_man$store_ptr_to entry (ptr, ptr);
115 dcl base_man$update_base entry (fixed bin, ptr, fixed bin);
116
117 dcl compile_exp entry (ptr);
118 dcl compile_exp$save entry (ptr) returns (ptr);
119 dcl compile_exp$save_exp entry (ptr) returns (ptr);
120 dcl copy_temp entry (ptr) returns (ptr);
121 dcl compare_expression entry (ptr, ptr) reducible returns (bit (1) aligned);
122 dcl convert_chars entry (ptr, ptr, bit (1) aligned, bit (1) aligned);
123 dcl convert_arithmetic entry (ptr, ptr, bit (1) aligned, bit (1) aligned);
124 dcl c_a entry (fixed bin, fixed bin) returns (ptr);
125 dcl decimal_op$get_float_temp entry (fixed bin (24), bit (1) aligned) returns (ptr);
126 dcl error entry (fixed bin, ptr, ptr);
127 dcl expmac entry (fixed bin (15), ptr);
128 dcl expmac$one entry (fixed bin (15), ptr, fixed bin);
129 dcl expmac$zero entry (fixed bin (15));
130 dcl expmac$many entry (fixed bin (15), ptr, fixed bin);
131 dcl expmac$many_eis entry (fixed bin (15), ptr, fixed bin);
132 dcl expmac$one_eis entry (fixed bin (15), ptr);
133 dcl expmac$two_eis entry (fixed bin (15), ptr, ptr);
134
135 dcl fixed_to_float entry (ptr);
136 dcl float_to_fixed entry (ptr);
137 dcl generate_constant entry (bit (*) aligned, fixed bin) returns (ptr);
138 dcl generate_constant$real_fix_bin_1 entry (fixed bin) returns (ptr);
139 dcl generate_constant$bit_string entry (bit (*) aligned, fixed bin) returns (ptr);
140 dcl generate_constant$char_string entry (char (*) aligned, fixed bin) returns (ptr);
141 dcl get_imaginary entry (ptr) returns (ptr);
142 dcl get_single_ref entry (ptr) returns (ptr);
143 dcl load entry (ptr, fixed bin);
144 dcl load$for_store entry (ptr, fixed bin);
145 dcl load$long_string entry (ptr);
146 dcl load$short_string entry (ptr, fixed bin);
147 dcl load_prog entry (ptr, fixed bin) variable;
148 dcl load_size entry (ptr);
149 dcl load_size$xr_or_aq entry (ptr, bit (4) aligned);
150 dcl long_op$one_eis entry (ptr, fixed bin, fixed bin (15));
151 dcl long_op$extend_stack entry (ptr, fixed bin (15));
152 dcl make_n_addressable entry (ptr, fixed bin);
153 dcl m_a entry (ptr, bit (2) aligned);
154 dcl make_both_addressable entry (ptr, ptr, bit (1) aligned);
155 dcl need_temp entry (ptr, bit (2) aligned);
156 dcl move_data$move_block entry (ptr, ptr, fixed bin);
157 dcl picture_op entry (ptr);
158 dcl prepare_operand entry (ptr, fixed bin, bit (1) aligned) returns (ptr);
159 dcl stack_temp$assign_temp entry (ptr);
160 dcl state_man$erase_reg entry (bit (19) aligned);
161 dcl state_man$flush_ref entry (ptr);
162 dcl state_man$flush_sym entry (ptr);
163 dcl store entry (ptr);
164 dcl store$all_ones entry (ptr);
165 dcl store$force entry (ptr);
166 dcl store$save_string_temp entry (ptr);
167 dcl xr_man$load_const entry (fixed bin, fixed bin);
168
169
170 dcl (abs, addr, addrel, bit, divide, fixed, max, min, mod, null, string, substr, verify) builtin;
171
172
173 dcl assign_info$assign_info (14, 14) fixed bin ext,
174 1 assign_info aligned based,
175 2 act_a unal bit (6),
176 2 act_b unal bit (6),
177 2 macro_1 unal bit (12),
178 2 macro_2 unal bit (12);
179
180 dcl (
181 assign_label_to_int init (379),
182 rflb1_to_cflb1 init (390),
183 set_label_const (2) init (315, 285),
184 ldfl1 init (9),
185 alloc_char_temp init (89),
186 chars_move init (420),
187 chars_move_vt init (444),
188 cat_move_chars init (218),
189 sbfx1 init (22),
190 aos_mac init (309),
191 incr_mac init (310),
192 lda init (1),
193 ansa init (43),
194 longbs_to_fx2 init (132),
195 cpfx1 init (136),
196 lrl init (62),
197 lrs init (492),
198 lls init (63),
199 move_chars init (98),
200 oraq init (48),
201 stfx1 init (15),
202 sta init (4),
203 fx1_to_bs init (293),
204 blank_cs init (472),
205 zero_bs init (468),
206 one_bs init (469),
207 zero_cs init (419),
208 one_cs init (484),
209 zero_cs_q init (479),
210 b2c_mac init (108),
211 size_check_fx1 init (553),
212 chars_move_ck init (555),
213 signal_stringsize init (563),
214 size_ck_varying init (566),
215 size_ck_suffix init (567),
216 size_ck_decimal init (582),
217 cmp_suffix_1 init (220),
218 size_ck_suffix_1 init (698),
219 left_shift (2) init (515, 63),
220 truncate (2) init (520, 521),
221 min_fx1 init (247),
222 zero_mac init (308),
223 zero_mac_p_1 init (307),
224 move_decimal init (438),
225 multiply_decimal init (450),
226 make_lv init (173),
227 store_lv init (174),
228 size_check_uns_fx1 init (731),
229 uns_fx1_to_bs init (733)
230 ) fixed bin (15) int static options (constant);
231
232 dcl ptr_convert (23:24, 23:24) fixed bin (15) int static init (0, 407, 408, 0);
233
234 dcl based_bs bit (size2) aligned based,
235 based_cs char (length2) aligned based;
236
237 dcl 1 instruction based aligned,
238 2 fill char (1) unal,
239 2 enablefault bit (1) unal,
240 2 pad1 bit (1) unal,
241 2 mf2 bit (7) unal,
242 2 opcode bit (10) unal,
243 2 inhibit bit (1) unal,
244 2 mf1 bit (7) unal;
245
246 dcl 1 exponent aligned,
247 2 pad bit (1) unal,
248 2 value fixed bin (7) unal;
249
250 dcl exponent_char char (1) based (addr (exponent)) aligned;
251
252
253
254 dcl TRUE bit (1) aligned int static options (constant) init ("1"b);
255 dcl FALSE bit (1) aligned int static options (constant) init ("0"b);
256
257 %page;
258 %include cgsystem;
259 %page;
260 %include statement;
261 %page;
262 %include operator;
263 %page;
264 %include reference;
265 %page;
266 %include symbol;
267 %page;
268 %include block;
269 %page;
270 %include nodes;
271 %page;
272 %include bases;
273 %page;
274 %include data_types;
275 %page;
276 %include machine_state;
277 %page;
278 %include op_codes;
279 %page;
280 %include boundary;
281 %page;
282
283
284 load_prog = load$for_store;
285
286 all_blanks, all_ones, all_zeros, all_same, loaded, here_before, full_word, no_store, pack_char_pic, last_macro =
287 FALSE;
288
289 p = pt;
290 op_code = p -> operator.op_code;
291 check_size = (op_code = assign_size_ck);
292 always_round = (op_code = assign_round);
293
294 p1 = prepare_operand ((p -> operand (1)), 1, atomic);
295 orig_count = p1 -> reference.ref_count;
296
297 exp_pt, p2 = p -> operand (2);
298 if p2 -> node.type = operator_node | p2 -> node.type = label_node | ^p2 -> reference.temp_ref then
299 p2 = prepare_operand (p2, 1, atomic);
300 else
301 atomic = TRUE;
302
303 gt:
304 s1 = p1 -> reference.symbol;
305 s2 = p2 -> reference.symbol;
306
307 scale1 = s1 -> symbol.scale;
308 prec1 = s1 -> symbol.c_dcl_size;
309
310 right_constant = FALSE;
311
312 type2 = p2 -> reference.data_type;
313
314 if s2 -> node.type = label_node then do;
315 type1 = p1 -> reference.data_type;
316 goto lab_or_ent;
317 end;
318
319 scale2 = s2 -> symbol.scale;
320 prec2 = s2 -> symbol.c_dcl_size;
321
322 if s1 -> symbol.storage_block & ^here_before then do;
323 type1, p1 -> reference.data_type = type2;
324 p1 -> reference.c_length = p2 -> reference.c_length;
325 if type1 = char_string | type2 = bit_string then
326 p1 -> reference.long_ref = p1 -> reference.c_length * convert_size (type1) > bits_per_two_words;
327 end;
328 else
329 type1 = p1 -> reference.data_type;
330
331 here_before = TRUE;
332
333 dt = type1 - char_string;
334
335 if type2 ^= bit_string then
336 if type2 ^= char_string then
337 goto chk_temp;
338
339 length2 = p2 -> reference.c_length;
340 size2 = length2 * convert_size (type2);
341
342 if op_code = pack then
343 if type2 = char_string then
344 if substr (cg_stat$cur_statement -> statement.prefix, 5, 1) then
345 pack_char_pic = TRUE;
346
347 if atomic then do;
348 if ^s2 -> symbol.constant then
349 goto chk_temp;
350 if s2 -> symbol.varying then
351 goto chk_temp;
352 if s2 -> symbol.dimensioned then
353 goto chk_temp;
354 if p2 -> reference.offset ^= null then
355 goto chk_temp;
356 if p2 -> reference.length ^= null then
357 goto chk_temp;
358 if p2 -> reference.c_offset ^= 0 then
359 goto chk_temp;
360 if p2 -> reference.temp_ref then
361 goto chk_temp;
362
363 right_constant = TRUE;
364
365 q = s2 -> symbol.initial;
366
367 if type2 = char_string then do;
368 if length2 > 0 then do;
369 all_same = verify (q -> based_cs, substr (q -> based_cs, 1, 1)) = 0;
370 if all_same then
371 all_blanks = substr (q -> based_cs, 1, 1) = " ";
372 end;
373 else
374 all_same, all_blanks = TRUE;
375 end;
376 else do;
377 all_ones = (^q -> based_bs = FALSE);
378 all_zeros = (q -> based_bs = FALSE);
379 end;
380 end;
381
382 chk_temp:
383 if ^p1 -> reference.temp_ref then
384 goto get_info;
385 if p1 -> reference.defined_ref then
386 goto get_info;
387 if p1 -> reference.aggregate then
388 goto get_info;
389
390
391
392 if p1 -> reference.length = null then do;
393
394 load_prog = load;
395
396 if p1 -> reference.allocate then do;
397 if ^p1 -> reference.allocated then
398 call stack_temp$assign_temp (p1);
399 if p1 -> reference.ref_count = 1 then
400 p1 -> reference.ref_count = 2;
401 goto get_info;
402 end;
403
404 if ^p1 -> reference.long_ref then do;
405 no_store = TRUE;
406 goto get_info;
407 end;
408
409 end;
410
411
412
413 if type1 ^= type2 then do;
414 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
415 call long_op$extend_stack (p1, alloc_char_temp + dt);
416 call store$save_string_temp (p1);
417 goto get_info;
418 end;
419
420 if ^atomic then
421 p2 = compile_exp$save (exp_pt);
422
423 call long_op$extend_stack (p1, alloc_char_temp + dt);
424 if cg_stat$save_exp_called then
425 call store$save_string_temp (p1);
426 call expmac$two_eis (move_chars + dt, p1, p2);
427
428 goto done;
429
430 get_info:
431 if atomic then
432 goto gi;
433
434 if type2 <= real_flt_bin_2 then
435 k = 1;
436 else do;
437 if type2 ^= type1 then
438 goto gi;
439 if type2 < char_string then
440 goto gi;
441 if type2 > bit_string then
442 goto gi;
443
444 if pack_char_pic then
445 goto gi;
446 if p1 -> reference.varying_ref then
447 goto gi;
448 if p1 -> reference.length ^= null then
449 goto gi;
450
451 k = 0;
452 end;
453
454
455
456
457
458
459 if exp_pt -> node.type ^= operator_node then
460 goto gi;
461 if exp_pt -> operator.op_code ^= assign then
462 goto gi;
463 if exp_pt -> operator.operand (1) -> reference.ref_count > 1 then
464 goto gi;
465
466 if k = 0 then do;
467 if p2 -> reference.varying_ref then
468 goto gi;
469 if p2 -> reference.length ^= null then
470 goto gi;
471
472
473
474
475 if p1 -> reference.c_length = p2 -> reference.c_length then
476 goto elim;
477 end;
478
479
480
481
482
483
484 q2 = exp_pt -> operand (2);
485 if q2 -> node.type = operator_node then
486 q2 = q2 -> operand (1);
487
488 m1 = q2 -> reference.data_type;
489
490 q2 = prepare_operand (q2, 0, atomic);
491
492 m2 = q2 -> reference.data_type;
493 q2 -> reference.data_type = m1;
494
495 if k = 0 then do;
496 if p1 -> reference.c_length < p2 -> reference.c_length then
497 if type2 ^= m2 then
498 goto repair;
499 else
500 goto elim;
501
502
503
504
505
506
507
508 if type2 ^= m2 then
509 if m2 >= real_fix_dec & m2 <= complex_flt_dec then
510 goto repair;
511
512 if q2 -> reference.varying_ref then
513 goto repair;
514 if q2 -> reference.length ^= null then
515 goto repair;
516
517 if p2 -> reference.c_length < q2 -> reference.c_length then
518 goto repair;
519
520
521
522 elim:
523 p2, exp_pt = exp_pt -> operand (2);
524 if k = 0 then do;
525 p2 = prepare_operand (p2, 1, atomic);
526 goto gt;
527 end;
528 p2 = prepare_operand (p2, 1, atomic);
529 goto gi;
530 end;
531
532
533
534 if type2 = m2 then
535 goto elim;
536
537 repair:
538 atomic = FALSE;
539
540 gi:
541 if type2 > bit_string then
542 goto LABEL_ENTRY_OR_PTR;
543
544 q = addr (assign_info$assign_info (type1, type2));
545 a = fixed (q -> assign_info.act_a, 6);
546 b = fixed (q -> assign_info.act_b, 6);
547 m1 = fixed (q -> assign_info.macro_1, 12);
548 m2 = fixed (q -> assign_info.macro_2, 12);
549
550 if pack_char_pic then do;
551 a = 2;
552 b = 2;
553 end;
554
555
556
557
558 if p1 -> reference.symbol -> symbol.alloc_in_text then
559 call error (134, cg_stat$cur_statement, null);
560
561 goto A (a);
562 %page;
563
564
565 A (0):
566 call error (331, cg_stat$cur_statement, null);
567 goto done;
568 %page;
569
570
571 A (1):
572 if p1 -> reference.aligned_for_store_ref then do;
573 A1a:
574 if atomic then
575 call load_prog (p2, 0);
576 else
577 call compile_exp (exp_pt);
578 goto B (b);
579 end;
580
581
582
583 if type1 ^= type2 then
584 goto A1a;
585
586 if ^atomic then
587 if exp_pt -> node.type = operator_node then
588 goto A1a;
589
590 if p2 -> reference.ref_count > 1 then
591 goto A1a;
592
593 if check_size then
594 if type1 = real_fix_bin_1 then
595 if prec1 < prec2 then
596 goto A1a;
597
598
599
600 size1 = p1 -> reference.c_length;
601
602 if type1 = real_fix_bin_1 then do;
603
604 if s2 -> symbol.constant then do;
605
606 if s2 -> symbol.packed & ^p2 -> reference.aligned_ref then
607 goto fake_bit;
608
609 if p2 -> reference.offset ^= null then
610 goto A1b;
611 if p2 -> reference.c_offset ^= 0 then
612 goto A1b;
613
614 p2 = generate_constant$bit_string (
615 substr (s2 -> symbol.initial -> word, bits_per_word - size1 + 1, size1), size1);
616
617
618
619 fake_bit:
620 check_size = FALSE;
621
622 if prec1 = prec2 then
623 if s1 -> symbol.unsigned = s2 -> symbol.unsigned then
624 if p1 -> reference.hard_to_load | p2 -> reference.hard_to_load then do;
625 dt = 1;
626 goto short_eis;
627 end;
628
629 call load$for_store (p2, 0);
630
631 aq_used = a_reg.offset + a_reg.size;
632
633 k = size1 - a_reg.size;
634 if k < 0 then do;
635 call aq_man$check_strings (aq_used + k);
636 a_reg.offset = a_reg.offset - k;
637 end;
638 else if k > 0 then do;
639 if a_reg.offset > 0 then
640 call aq_man$left_shift (a_reg.offset, "0"b);
641
642 if s2 -> symbol.unsigned then
643 macro = lrl;
644 else
645 macro = lrs;
646
647 call expmac (macro, c_a (k, 1));
648
649 end;
650
651 a_reg.size = size1;
652 p1 -> reference.data_type = bit_string;
653 goto l1;
654 end;
655
656 A1b:
657 if p2 -> reference.aligned_ref then
658 goto A1a;
659 if p2 -> reference.value_in.q then
660 goto A1a;
661
662 if scale1 ^= scale2 then
663 goto A1a;
664
665
666
667 p2 -> reference.data_type = bit_string;
668 goto fake_bit;
669 end;
670
671 if p2 -> reference.value_in.q then
672 goto A1a;
673
674 if type1 = real_flt_bin_1 | type1 = real_flt_bin_2 then do;
675 type1, p1 -> reference.data_type, p2 -> reference.data_type = bit_string;
676
677 call load_prog (p2, type2 - real_flt_bin_1);
678
679 size2 = p2 -> reference.c_length;
680 goto string_store_check;
681 end;
682
683 goto A1a;
684 %page;
685
686
687 A (2):
688 if ^atomic then
689 p2 = compile_exp$save_exp (exp_pt);
690 goto B (b);
691 %page;
692
693
694 A (3):
695 if atomic then do;
696 call expmac (m2, p2);
697 goto l1;
698 end;
699
700 call compile_exp (exp_pt);
701 m2 = 0;
702 goto B (b);
703 %page;
704
705
706 A (4):
707 if ^atomic then do;
708 p2 = compile_exp$save_exp (exp_pt);
709 if exp_pt -> node.type ^= operator_node then
710 goto B (4);
711 end;
712
713 if type1 = complex_flt_bin_1 then do;
714 call load_prog (p2, 0);
715 goto l1;
716 end;
717
718 call expmac ((ldfl1), p2);
719 loaded = TRUE;
720 if scale1 ^= 0 then
721 b = 7;
722 goto B (b);
723 %page;
724
725
726 A (5):
727 length1 = p1 -> reference.c_length;
728 size1 = length1 * convert_size (type1);
729 d = fixed (size1 > bits_per_word, 1);
730
731 all_same = all_same & ((length1 = length2 & p1 -> reference.length = null) | all_blanks);
732 all_ones = all_ones & (length1 = length2 & p1 -> reference.length = null);
733
734 hard1 = p1 -> reference.hard_to_load;
735 hard2 = p2 -> reference.hard_to_load;
736 if ^hard2 then
737 if p2 -> reference.long_ref then
738 if p2 -> reference.units < word_ then
739 hard2 = size1 > bits_per_word;
740
741 if ^check_size then
742 goto A5a;
743 if p1 -> reference.length ^= null then
744 goto A5a;
745 if p2 -> reference.length ^= null then
746 goto A5a;
747
748 call check_stringsize;
749
750
751
752
753
754 A5a:
755 if p1 -> reference.varying_ref then
756 goto A5c;
757 if p1 -> reference.length ^= null then
758 goto A5c;
759 if ^p1 -> reference.aligned_for_store_ref then
760 goto A5c;
761
762 if no_store then
763 goto A5c;
764
765 if ^p2 -> reference.aligned_ref then
766 goto A5c;
767 if p2 -> reference.varying_ref then
768 goto A5c;
769 if p2 -> reference.length ^= null then
770 goto A5c;
771 if ^p2 -> reference.long_ref then
772 goto A5c;
773
774 if all_same | all_ones | all_zeros then
775 if size1 > break_even_bits then
776 goto A5c;
777
778 if length1 > length2 then
779 goto A5c;
780
781 if ^(mod (size1, bits_per_word) = 0 | p1 -> reference.long_ref) then
782 goto A5c;
783
784 if mod (size1, bits_per_word) = 0 | p1 -> reference.padded_for_store_ref then do;
785
786 if ^atomic then
787 call compile_exp (exp_pt);
788
789 call move_data$move_block (p1, p2, divide (size1 + bits_per_word - 1, bits_per_word, 17, 0));
790 goto done;
791 end;
792
793 A5c:
794 if atomic then do;
795
796 A5ca:
797 if ^p1 -> reference.varying_ref then
798 goto chk;
799
800
801
802 if p2 -> reference.length ^= null then
803 goto l9;
804 if p2 -> reference.varying_ref then
805 goto l9;
806
807 if length2 = 0 then do;
808 p1 -> reference.c_offset = p1 -> reference.c_offset - 1;
809 call expmac ((zero_mac), p1);
810 p1 -> reference.c_offset = p1 -> reference.c_offset + 1;
811 call state_man$flush_ref (p1);
812 goto done;
813 end;
814
815 if p1 -> reference.length ^= null then
816 goto l9;
817
818 load_prog = load;
819
820 if ^hard2 then do;
821 if ^p2 -> reference.long_ref then do;
822 call load_prog (p2, d);
823 goto string_store_work;
824 end;
825
826 if ^p1 -> reference.long_ref then do;
827 call load$short_string (p2, d);
828 goto string_store_work;
829 end;
830 end;
831
832 goto l9;
833
834 chk:
835 if p1 -> reference.long_ref then do;
836
837 l9:
838 lg:
839 if ^p1 -> reference.varying_ref then do;
840 call state_man$flush_sym ((p1 -> reference.symbol));
841 call eis_move;
842 goto done;
843 end;
844
845
846
847 if p1 -> reference.length ^= p2 -> reference.length then
848 arg (1) = get_length_in_storage (p1);
849 else
850 arg (1) = get_length (p1);
851
852 if p2 -> reference.varying_ref then do;
853
854 call load_size (p2);
855
856 if arg (1) = null then
857 if s2 -> symbol.c_dcl_size <= length1 & s2 -> symbol.dcl_size = null then
858 goto l11;
859 else
860 arg (1) = generate_constant$real_fix_bin_1 (length1);
861
862 goto l10;
863 end;
864
865 arg (2) = get_length (p2);
866
867 if arg (1) = null then
868 if arg (2) = null then do;
869 call load (generate_constant$real_fix_bin_1 (min (length1, length2)), 0);
870 goto l11;
871 end;
872 else
873 arg (1) = generate_constant$real_fix_bin_1 (length1);
874 else if arg (2) = null then
875 arg (2) = generate_constant$real_fix_bin_1 (length2);
876
877 call load (arg (2), 0);
878
879 if arg (1) = arg (2) then do;
880 if ^arg (1) -> reference.shared then
881 arg (1) -> reference.ref_count = arg (1) -> reference.ref_count - 1;
882 goto l11;
883 end;
884
885 l10:
886 if p2 -> reference.ref_count = 1 then
887 call need_temp (p2, "01"b);
888 if check_size then
889 macro = size_ck_varying;
890 else
891 macro = min_fx1;
892 if arg (1) -> reference.data_type = real_fix_bin_2 then
893 arg (1) = get_single_ref (arg (1));
894 call expmac (macro, arg (1));
895
896 l11:
897 refs_are_same = compare_refs (p1, p2);
898
899 if ^refs_are_same & p2 -> reference.offset ^= null then do;
900
901
902
903
904
905
906
907
908
909 call aq_man$lock (null, 2);
910 arg (1) = p2;
911 call make_n_addressable (addr (arg), 1);
912 end;
913
914 call expmac_length_of_varying (stfx1, p1);
915
916 if ^refs_are_same then
917 call expmac$two_eis (chars_move_vt + dt, p1, p2);
918 else do;
919 if ^p2 -> reference.shared then
920 call adjust_ref_count (p2, -1);
921 if ^p1 -> reference.shared then
922 call adjust_ref_count (p1, -1);
923 end;
924
925 goto done;
926 end;
927
928
929
930 if p2 -> reference.varying_ref then
931 goto short_eis;
932
933 if hard1 | hard2 then
934 goto short_eis;
935
936 if p2 -> reference.long_ref then
937 if p2 -> reference.length = null then
938 call load$short_string (p2, d);
939 else do;
940 short_eis:
941 if no_store then
942 p1 = copy_temp (p1);
943
944 if p1 -> reference.aligned_for_store_ref then
945 if mod (size1, bits_per_word) ^= 0 then do;
946 if size1 < bits_per_word then
947 macro = zero_mac;
948 else
949 macro = zero_mac_p_1;
950 if ^p1 -> reference.shared then
951 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
952 call expmac (macro, p1);
953 end;
954
955 call state_man$flush_sym ((p1 -> reference.symbol));
956
957 call eis_move;
958
959 if p1 -> reference.temp_ref then
960 if cg_stat$save_exp_called then
961 call adjust_ref_count (p1, -1);
962 else if cg_stat$cur_tree ^= p then do;
963 if ^no_store then
964 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
965 call load (p1, d);
966 end;
967
968 goto done;
969 end;
970 else if all_zeros then do;
971
972 if p1 -> reference.temp_ref then do;
973 call load_prog (p2, d);
974 goto string_store_work;
975 end;
976
977 if p1 -> reference.aligned_for_store_ref then
978 if size1 <= bits_per_word then
979 goto zm;
980 else do;
981 call load_prog (p2, d);
982 goto string_store_work;
983 end;
984
985
986
987
988
989
990 call state_man$flush_ref (p1);
991 double_string = (72)"1"b;
992 cfo = mod (p1 -> reference.c_offset * convert_offset (p1 -> reference.units), bits_per_word);
993 substr (double_string, cfo + 1, size1) = "0"b;
994
995 d = fixed (cfo + size1 > bits_per_word, 1);
996 p2 = generate_constant (double_string, d + 1);
997 call load (p2, d);
998 call expmac$one ((ansa), p1, d);
999 goto done;
1000 end;
1001 else if right_constant then do;
1002 if p1 -> reference.aligned_for_store_ref then do;
1003 call load_prog (p2, d);
1004 goto string_store_work;
1005 end;
1006
1007
1008
1009
1010
1011
1012 cfo = mod (p1 -> reference.c_offset * convert_offset (p1 -> reference.units), bits_per_word);
1013 if cfo + size1 > bits_per_two_words then do;
1014 call load_prog (p2, d);
1015 goto string_store_work;
1016 end;
1017
1018 double_string = (72)"0"b;
1019 substr (double_string, cfo + 1, size1) = s2 -> symbol.initial -> based_bs;
1020 d = fixed (cfo + size1 > bits_per_word, 1);
1021 p2 = generate_constant (double_string, d + 1);
1022
1023 call expmac$one ((lda), p2, d);
1024 a_reg.offset = cfo;
1025 a_reg.size = size2;
1026 a_reg.length = bits_per_word * (d + 1);
1027 goto string_store_work;
1028 end;
1029 else do;
1030 call load_prog (p2, d);
1031 goto string_store_work;
1032 end;
1033
1034 goto string_store_work;
1035 end;
1036
1037 if exp_pt -> node.type ^= operator_node then
1038 goto A5ca;
1039
1040
1041
1042 if ^p1 -> reference.varying_ref then
1043 goto l4;
1044
1045
1046
1047 note
1048
1049
1050
1051
1052
1053 if exp_pt -> operator.op_code ^= cat_string then
1054 goto l4;
1055
1056 q = exp_pt -> operand (2);
1057 if q -> reference.c_length ^= 0 then
1058 goto l4;
1059 if q -> reference.length ^= null then
1060 goto l4;
1061
1062 if ^compare_refs (p1, q) then
1063 goto l4;
1064
1065
1066
1067
1068
1069
1070 q = prepare_operand (q, -1, atomic);
1071
1072 q1 = prepare_operand ((exp_pt -> operand (3)), 1, atomic);
1073 if ^atomic then
1074 if q1 -> reference.long_ref then
1075 call compile_exp ((exp_pt -> operand (3)));
1076 else
1077 q1 = compile_exp$save_exp ((exp_pt -> operand (3)));
1078
1079
1080
1081
1082
1083 call adjust_suff_temp ((exp_pt -> operand (1)));
1084
1085
1086
1087
1088
1089
1090 if q1 -> reference.c_length ^= 1 then
1091 q2 = get_suffix_length (q1);
1092 else
1093 q2 = get_suffix_length (p1);
1094
1095
1096
1097 call m_a (p1, "10"b);
1098
1099 if p1 -> address.tag then do;
1100 if ^p1 -> reference.shared then
1101 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1102 base = base_man$load_any_var (2, p1);
1103 if p1 -> reference.ref_count = 1 then
1104 call need_temp (p1, "10"b);
1105 end;
1106
1107
1108
1109
1110
1111 call state_man$erase_reg ("01"b);
1112 call aq_man$lock (null, 2);
1113 arg (1) = p1;
1114 arg (2) = q1;
1115 p1 -> reference.perm_address = TRUE;
1116 call make_n_addressable (addr (arg), 2);
1117 p1 -> reference.perm_address = FALSE;
1118
1119 if q1 -> reference.c_length ^= 1 then do;
1120 call load_size (p1);
1121 call expmac_length_of_varying ((sbfx1), p1);
1122
1123
1124
1125 if check_size then
1126 macro = size_ck_suffix;
1127 else
1128 macro = min_fx1;
1129 if q1 -> reference.varying_ref then
1130 call expmac_length_of_varying (macro, q1);
1131 else
1132 call expmac (macro, q2);
1133
1134
1135
1136 call load_size$xr_or_aq (q, tag);
1137
1138 bump_mac = incr_mac;
1139 macro = chars_move_vt + dt;
1140 end;
1141 else do;
1142
1143 call load_size (q);
1144
1145 if check_size then
1146 macro = size_ck_suffix_1;
1147 else
1148 macro = cmp_suffix_1;
1149
1150 call expmac (macro, q2);
1151
1152 tag = "0110"b;
1153
1154 bump_mac = aos_mac;
1155 macro = cat_move_chars + dt;
1156 end;
1157
1158 if ^q -> reference.shared then
1159 call adjust_ref_count (q, -1);
1160
1161
1162
1163 call expmac_length_of_varying (bump_mac, p1);
1164
1165
1166
1167 p1 -> address.tag = "00"b || tag;
1168 p1 -> reference.perm_address = TRUE;
1169 q1 -> reference.perm_address = TRUE;
1170 call expmac$two_eis (macro, p1, q1);
1171
1172 if dt > 0 then
1173 machine_state.indicators = ind_invalid;
1174 goto done;
1175 %page;
1176
1177
1178 l4:
1179 if ^p2 -> reference.long_ref & ^(p1 -> reference.varying_ref & p1 -> reference.length = null)
1180 & (p1 -> reference.long_ref | hard1) then
1181 p2 = compile_exp$save (exp_pt);
1182 else
1183 call compile_exp (exp_pt);
1184
1185 if p1 -> reference.varying_ref then do;
1186 if p1 -> reference.length ^= null then
1187 goto lg;
1188
1189 if p2 -> reference.length = null then do;
1190 if ^p2 -> reference.long_ref then
1191 goto string_store_work;
1192 end;
1193 else
1194 goto lg;
1195 end;
1196
1197 if p1 -> reference.long_ref then
1198 goto lg;
1199
1200
1201
1202 if hard1 then
1203 goto short_eis;
1204
1205 if p2 -> reference.long_ref then do;
1206
1207 if check_size then
1208 goto short_eis;
1209
1210 if p2 -> reference.length ^= null | size2 < bits_per_two_words then
1211 goto short_eis;
1212
1213 p2 -> reference.value_in.storage = TRUE;
1214
1215 call load$short_string (p2, d);
1216 size2 = bits_per_word * (d + 1);
1217 end;
1218
1219
1220
1221 string_store_work:
1222 if p1 -> reference.varying_ref then do;
1223
1224 if ^p1 -> reference.shared then
1225 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1226
1227 call expmac$one ((sta), p1, fixed (min (size1, size2) > bits_per_word, 1));
1228 p2 = generate_constant$real_fix_bin_1 (min (length1, length2));
1229
1230 if p1 -> address.tag = "000110"b then do;
1231 call expmac ((lda), p2);
1232 m2 = sta;
1233 end;
1234 else do;
1235 call load (p2, 0);
1236 m2 = stfx1;
1237 end;
1238
1239 last_macro = TRUE;
1240 call expmac_length_of_varying (m2, p1);
1241
1242 goto done;
1243 end;
1244
1245 string_store_check:
1246 if size1 = a_reg.size then
1247 goto st;
1248
1249 if size1 < a_reg.size then do;
1250 if no_store then
1251 call aq_man$trim_aq (size1);
1252 goto st;
1253 end;
1254
1255
1256
1257 aq_used = a_reg.size + a_reg.offset;
1258
1259 if type1 = bit_string then
1260 if a_reg.length = bits_per_two_words | a_reg.length - a_reg.offset >= size1 then
1261 goto st;
1262 else
1263 goto pad;
1264
1265
1266
1267
1268
1269 if size1 > bits_per_two_words - a_reg.offset then do;
1270
1271
1272
1273
1274 call aq_man$left_shift (a_reg.offset, "1"b);
1275 aq_used = a_reg.size;
1276 end;
1277
1278 if size1 <= bits_per_word then
1279 k = size1 + a_reg.offset;
1280 else
1281 k = bits_per_two_words;
1282
1283 if a_reg.length < k then do;
1284 pad:
1285 call aq_man$trim_aq (aq_used);
1286 a_reg.length = 72;
1287 end;
1288
1289 if type1 = bit_string then
1290 goto st;
1291
1292 call expmac ((oraq), c_a (aq_used, 6));
1293
1294 if mod (k, bits_per_word) ^= 0 then do;
1295 call aq_man$trim_aq (k);
1296 a_reg.length = bits_per_two_words;
1297 end;
1298
1299 a_reg.size = k - a_reg.offset;
1300
1301 st:
1302 if (size1 = size2) & all_ones then
1303 call store$all_ones (p1);
1304 else
1305 call store (p1);
1306
1307 if a_reg.size + a_reg.offset > bits_per_two_words then
1308 a_reg.size = bits_per_two_words - a_reg.offset;
1309
1310 goto done;
1311 %page;
1312
1313
1314 A (6):
1315 if p2 -> reference.long_ref | p2 -> reference.varying_ref then do;
1316
1317 if ^atomic then
1318 call compile_exp (exp_pt);
1319 call load$long_string (p2);
1320
1321 call expmac$zero ((longbs_to_fx2));
1322
1323
1324
1325 now_fx2:
1326 type2 = real_fix_bin_2;
1327
1328 q = addr (assign_info$assign_info (type1, type2));
1329 m1 = fixed (q -> assign_info.macro_1, 12);
1330 m2 = fixed (q -> assign_info.macro_2, 12);
1331 goto B (fixed (q -> assign_info.act_b, 6));
1332 end;
1333
1334 if all_zeros then
1335 if type1 = real_fix_bin_1 & ^p1 -> reference.temp_ref & p1 -> reference.aligned_for_store_ref then do;
1336 zm:
1337 call state_man$flush_ref (p1);
1338 call expmac ((zero_mac), p1);
1339 goto done;
1340 end;
1341
1342 if atomic then
1343 call load (p2, 1);
1344 else
1345 call compile_exp (exp_pt);
1346
1347 dt = a_reg.offset;
1348 if a_reg.number ^= 0 then do;
1349 q = a_reg.variable (1);
1350 if q -> reference.temp_ref & q -> reference.ref_count > 0 then
1351 call state_man$erase_reg ("1"b);
1352 end;
1353
1354 if size2 < bits_per_two_words then do;
1355 k = bits_per_two_words - size2;
1356 if k > dt then
1357 call aq_man$right_shift (k - dt, "1"b);
1358 end;
1359
1360 if scale1 ^= 0 then
1361 call state_man$erase_reg ("1"b);
1362
1363 goto now_fx2;
1364 %page;
1365
1366
1367 A (7):
1368 if ^atomic then do;
1369 call compile_exp (exp_pt);
1370
1371 loaded = TRUE;
1372 end;
1373
1374 goto B (b);
1375 %page;
1376
1377
1378 B (1):
1379 if m1 ^= 0 then
1380 call expmac$zero (m1);
1381
1382 l0:
1383 if m2 ^= 0 then
1384 call expmac$zero (m2);
1385
1386 l1:
1387 if check_size & s1 -> symbol.fixed then do;
1388 if type1 > real_fix_bin_1 then
1389 dt = 1;
1390 else if type2 > real_fix_bin_1 then
1391 dt = 1;
1392 else
1393 dt = 0;
1394 call xr_man$load_const (-s1 -> symbol.c_dcl_size * (dt + 1), 7);
1395
1396 if s1 -> symbol.unsigned then
1397 size_ck_macro = size_check_uns_fx1 + dt;
1398 else
1399 size_ck_macro = size_check_fx1 + dt;
1400
1401 call expmac$zero (size_ck_macro);
1402
1403
1404
1405
1406 machine_state.indicators = ind_invalid;
1407
1408 end;
1409
1410 call store (p1);
1411
1412 done:
1413 cg_stat$temp_ref = p1;
1414
1415 if p1 -> reference.temp_ref then
1416 p1 -> reference.ref_count = min (p1 -> reference.ref_count, orig_count);
1417
1418 if ^p1 -> reference.shared then
1419 p1 -> reference.evaluated = TRUE;
1420
1421 return;
1422 %page;
1423
1424
1425 B (2):
1426 if p1 -> reference.temp_ref & p1 -> reference.shared & p1 -> reference.length = null then do;
1427 p1, p -> operand (1) = copy_temp (p1);
1428 orig_count = 1;
1429 end;
1430
1431 load_it =
1432 p1 -> reference.temp_ref & ^cg_stat$save_exp_called & cg_stat$cur_tree ^= p & ^p1 -> reference.long_ref
1433 & ^s1 -> symbol.decimal;
1434
1435 if op_code = pack | op_code = unpack then
1436 call picture_op (p);
1437 else do;
1438 call convert_chars (p1, p2, check_size, always_round);
1439
1440 if p2 ^= null then do;
1441 atomic = TRUE;
1442 length2 = p2 -> reference.c_length;
1443 size2 = bits_per_char * length2;
1444 type2 = char_string;
1445 goto A (5);
1446 end;
1447 end;
1448
1449 B2b:
1450 if type1 = bit_string then
1451 machine_state.indicators = ind_invalid;
1452
1453 if load_it then do;
1454 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1455 call load (p1, fixed (type1 >= char_string, 1));
1456 end;
1457 goto done;
1458 %page;
1459
1460
1461 B (3):
1462 size1, length1 = p1 -> reference.c_length;
1463
1464 if type2 <= real_fix_bin_2 & scale2 ^= 0 then do;
1465 if ^loaded then
1466 call load (p2, 0);
1467
1468 call scaler (-scale2, type2);
1469
1470 prec2 = max (prec2 - scale2, 0);
1471 goto B3b;
1472 end;
1473
1474 if ^loaded then
1475 if type2 > real_fix_bin_2 | ^p2 -> reference.aligned_ref then
1476 call load (p2, 0);
1477 else do;
1478 d = type2 - real_fix_bin_1;
1479 k = bits_per_word * (d + 1);
1480
1481 arg (1) = p2;
1482 arg (2) = c_a (k - prec2, 1);
1483
1484 if s2 -> symbol.unsigned then
1485 macro = uns_fx1_to_bs;
1486 else
1487 macro = fx1_to_bs;
1488
1489 call expmac$many (macro + d, addr (arg), 2);
1490
1491 a_reg.length = k;
1492 goto B3a;
1493 end;
1494
1495 B3b:
1496 if ^s2 -> symbol.unsigned then do;
1497 if machine_state.indicators ^= ind_arithmetic then do;
1498 call expmac (cpfx1 - real_fix_bin_1 + type2, c_a (0, 5));
1499 machine_state.indicators = ind_arithmetic;
1500 end;
1501
1502 if m1 ^= 0 then
1503 call expmac$zero (m1);
1504 if m2 ^= 0 then
1505 call expmac$zero (m2);
1506 end;
1507
1508 call expmac ((lls), c_a (bits_per_two_words - prec2, 1));
1509
1510 a_reg.length = bits_per_two_words;
1511
1512 B3a:
1513 a_reg.size, size2, length2 = prec2;
1514 a_reg.offset = 0;
1515
1516 if p1 -> reference.long_ref & ^(p1 -> reference.varying_ref & p1 -> reference.length = null) then do;
1517 p2 = c_a (46, 4);
1518 p2 -> reference.c_length = length2;
1519 p2 -> reference.temp_ref = TRUE;
1520 p2 -> reference.data_type = bit_string;
1521 p2 -> reference.ref_count = 2;
1522 p2 -> reference.value_in.storage = TRUE;
1523 call expmac$one ((sta), p2, fixed (length2 > bits_per_word, 1));
1524 goto lg;
1525 end;
1526 else do;
1527 if check_size then
1528 call check_stringsize;
1529 goto string_store_work;
1530 end;
1531
1532 LABEL_ENTRY_OR_PTR:
1533 orig_count = p1 -> reference.ref_count;
1534 if type2 < unpacked_ptr then
1535 goto lab_or_ent;
1536
1537
1538
1539 if type1 = local_label_variable then
1540 type1, p1 -> reference.data_type = unpacked_ptr;
1541
1542 if type2 = unpacked_ptr then do;
1543
1544 NOTE
1545
1546
1547
1548 if ^atomic then do;
1549 if type1 = unpacked_ptr then
1550 if ^p2 -> reference.allocate then do;
1551
1552 exp_pt -> operand (1) = p1;
1553 call compile_exp (exp_pt);
1554 goto done;
1555 end;
1556
1557
1558 call compile_exp (exp_pt);
1559 p2 = exp_pt -> operator.operand (1);
1560 goto CONVERT_UNPACKED_PTR_TO_SOMETHING;
1561 end;
1562
1563 if s2 -> symbol.constant then do;
1564
1565
1566
1567
1568 if type1 = packed_ptr then do;
1569 p2, p -> operand (2) = generate_constant$real_fix_bin_1 (cg_stat$packed_null_value);
1570 type2, p2 -> reference.data_type = packed_ptr;
1571 end;
1572 end;
1573 end;
1574
1575 if p2 -> reference.temp_ref then
1576 if ^p1 -> reference.temp_ref then
1577 do i = 1 to 6;
1578 if p2 -> reference.value_in.b (i) then do;
1579 if p1 -> reference.aligned_for_store_ref then
1580 if ^p2 -> reference.shared then
1581 call adjust_ref_count (p2, -1);
1582
1583 call base_to_core (i, p1);
1584
1585
1586
1587
1588
1589
1590 if ^p1 -> reference.aligned_for_store_ref then
1591 if ^p2 -> reference.shared then
1592 call adjust_ref_count (p2, -1);
1593 goto done;
1594 end;
1595 end;
1596
1597 CONVERT_UNPACKED_PTR_TO_SOMETHING:
1598 if type1 < type2 | (type2 = packed_ptr & p1 -> reference.temp_ref) then do;
1599 call base_man$load_packed (p, i);
1600 if ^p1 -> reference.temp_ref | p1 -> reference.aggregate | cg_stat$save_exp_called then
1601 call base_to_core (i, p1);
1602 goto done;
1603 end;
1604 else if type2 = unpacked_ptr then
1605 if p1 -> reference.temp_ref | ^s2 -> symbol.constant then
1606 if p1 -> reference.aligned_for_store_ref | p1 -> reference.hard_to_load then do;
1607 if ^p2 -> reference.shared & p2 -> reference.temp_ref then
1608 call adjust_ref_count (p2, +1);
1609
1610 base = base_man$load_any_var (1, p2);
1611 i = which_base (fixed (base, 3));
1612 if ^p1 -> reference.temp_ref | p1 -> reference.aggregate | cg_stat$save_exp_called then
1613 call base_to_core (i, p1);
1614 else
1615 call base_man$update_base (1, p1, i);
1616 goto done;
1617 end;
1618
1619 call load (p2, 0);
1620
1621 m2 = ptr_convert (type2, type1);
1622 goto l0;
1623 %page;
1624
1625
1626 B (4):
1627 if s1 -> symbol.complex ^= s2 -> symbol.complex then
1628 goto B4b;
1629 if type1 ^= type2 then
1630 goto B4a;
1631 if scale1 ^= scale2 then
1632 goto B4a;
1633 if p1 -> reference.c_length ^= p2 -> reference.c_length then
1634 goto B4a;
1635
1636 if p1 -> reference.aligned_for_store_ref & p2 -> reference.aligned_ref
1637 & s1 -> symbol.unaligned = s2 -> symbol.unaligned then do;
1638 if s2 -> symbol.decimal then
1639 if s2 -> symbol.unaligned then do;
1640 units_per_wrd = packed_digits_per_word;
1641 if s2 -> symbol.complex then
1642 c_length =
1643 p2 -> reference.c_length + 2 * mod (divide (p2 -> reference.c_length, 2, 24, 0), 2);
1644 else
1645 c_length = p2 -> reference.c_length;
1646 end;
1647 else do;
1648 units_per_wrd = chars_per_word;
1649 c_length = p2 -> reference.c_length;
1650 end;
1651 else do;
1652 units_per_wrd = bits_per_word;
1653 c_length = p2 -> reference.c_length;
1654 end;
1655
1656 call move_data$move_block (p1, p2, divide (c_length + units_per_wrd - 1, units_per_wrd, 17, 0));
1657 goto done;
1658 end;
1659
1660 B4a:
1661 if s1 -> symbol.decimal then
1662 if s2 -> symbol.decimal then do;
1663 macro = move_decimal;
1664
1665 if max (scale1, scale2) <= max_dec_scale & min (scale1, scale2) >= min_dec_scale then
1666 call assign_decimal;
1667
1668 else if type1 = type2 then do;
1669 if abs (scale1 - scale2) <= max_dec_scale - min_dec_scale then do;
1670 if scale1 > scale2 then
1671 i = min_dec_scale;
1672 else
1673 i = max_dec_scale;
1674 s1 -> symbol.scale = i + (scale1 - scale2);
1675 s2 -> symbol.scale = i;
1676 end;
1677 else do;
1678 macro = multiply_decimal;
1679 exponent.pad = "0"b;
1680 exponent.value = scale1 - scale2;
1681 s1 -> symbol.scale = 0;
1682 s2 -> symbol.scale = 0;
1683 end;
1684
1685 call assign_decimal;
1686
1687 s1 -> symbol.scale = scale1;
1688 s2 -> symbol.scale = scale2;
1689 end;
1690 else do;
1691 macro = multiply_decimal;
1692 exponent.pad = "0"b;
1693
1694 if scale1 > max_dec_scale | scale1 < min_dec_scale then
1695 exponent.value = scale1;
1696 else
1697 exponent.value = -scale2;
1698
1699 call assign_decimal;
1700 end;
1701
1702 goto done;
1703 end;
1704
1705 B4b:
1706 if p1 -> reference.temp_ref & p1 -> reference.shared then do;
1707 p1, p -> operand (1) = copy_temp (p1);
1708 orig_count = 1;
1709 end;
1710
1711 load_it =
1712 p1 -> reference.temp_ref & ^cg_stat$save_exp_called & cg_stat$cur_tree ^= p
1713 & ^(s1 -> symbol.decimal | s1 -> symbol.complex);
1714
1715 call convert_arithmetic (p1, p2, check_size, always_round);
1716
1717 goto B2b;
1718 %page;
1719
1720
1721 B (5):
1722 if m1 ^= 0 then
1723 call expmac$zero (m1);
1724
1725 ds = scale1 - scale2;
1726
1727 if ds ^= 0 then do;
1728 k = max (type1, type2);
1729 call scaler (ds, k);
1730 end;
1731
1732 goto l1;
1733 %page;
1734
1735
1736 B (6):
1737 if scale2 = 0 then
1738 goto B (1);
1739
1740 call fixed_to_float (p2);
1741 if type1 = complex_flt_bin_1 then
1742 call expmac$zero (rflb1_to_cflb1);
1743 goto l1;
1744 %page;
1745
1746
1747 B (7):
1748 if scale1 = 0 then
1749 goto B (1);
1750
1751 call float_to_fixed (p1);
1752 goto l1;
1753 %page;
1754 lab_or_ent:
1755 if p1 -> reference.temp_ref & ^cg_stat$save_exp_called then
1756 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1757
1758 if type1 = real_fix_bin_1 then do;
1759 arg (1) = p1;
1760 arg (2) = p2;
1761 call expmac$many ((assign_label_to_int), addr (arg), 2);
1762 goto done;
1763 end;
1764
1765 if type1 = unpacked_ptr then do;
1766 call base_man$store_ptr_to (p2, p1);
1767 goto done;
1768 end;
1769
1770 if type2 = ext_entry_in | type2 = ext_entry_out then do;
1771 call base_man$load_var (2, p2, 1);
1772
1773 if ^p1 -> reference.shared then
1774 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1775
1776 p1 -> reference.data_type = unpacked_ptr;
1777 call base_to_core (1, p1);
1778
1779 p2 = generate_constant$bit_string (cg_stat$null_value, (bits_per_two_words));
1780 p2 -> reference.data_type = unpacked_ptr;
1781 call load (p2, 0);
1782 call m_a (p1, "1"b);
1783 p1 -> reference.perm_address = TRUE;
1784
1785 p1 -> address.offset = bit (fixed (fixed (p1 -> address.offset, 15) + 2, 15), 15);
1786 call store$force (p1);
1787 p1 -> reference.perm_address = FALSE;
1788 p1 -> reference.data_type = type1;
1789 goto done;
1790 end;
1791
1792 b2 = s2 -> symbol.block_node;
1793
1794 if type2 ^= label_constant then
1795 if type2 ^= int_entry then
1796 goto le_1;
1797
1798 if b2 -> block.level ^= cg_stat$cur_level then
1799 goto le_2;
1800
1801 call m_a (p1, "1"b);
1802 p1 -> reference.perm_address = TRUE;
1803 k = 1 + fixed (p1 -> address.base = bp, 1);
1804 call base_man$load_var (2, p2, k);
1805 call expmac ((set_label_const (k)), p1);
1806 goto done;
1807
1808 le_1:
1809 if type2 > entry_variable then do;
1810 le_2:
1811 arg (1) = p2;
1812 arg (2) = c_a (cg_stat$cur_level - b2 -> block.level, 2);
1813 call expmac$many ((make_lv), addr (arg), 2);
1814
1815 call m_a (p1, "0"b);
1816 p1 -> reference.perm_address = TRUE;
1817 call expmac ((store_lv), p1);
1818 end;
1819
1820 else do;
1821 if ^p1 -> reference.shared then
1822 p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1823 if ^p2 -> reference.shared then
1824 p2 -> reference.ref_count = p2 -> reference.ref_count + 1;
1825 call base_man$update_base (0, null, 1);
1826 call make_both_addressable (p1, p2, "1"b);
1827
1828 do i = 1 to 2;
1829 p1 -> reference.perm_address = TRUE;
1830 p2 -> reference.perm_address = TRUE;
1831 call base_man$load_var (1, p2, 1);
1832 call base_to_core (1, p1);
1833 call state_man$flush_ref (p2);
1834 if i = 1 then do;
1835 p1 -> address.offset = bit (fixed (fixed (p1 -> address.offset, 15) + 2, 15), 15);
1836 substr (p2 -> address.tag, 1, 2) = "00"b;
1837 p2 -> address.offset = bit (fixed (fixed (p2 -> address.offset, 15) + 2, 15), 15);
1838 end;
1839 end;
1840
1841 p1 -> reference.perm_address = FALSE;
1842 p2 -> reference.perm_address = FALSE;
1843 end;
1844
1845 goto done;
1846 %page;
1847
1848
1849
1850 assign_op$length_of_varying:
1851 entry (pt, source);
1852
1853 dcl source ptr parameter;
1854
1855 last_macro = FALSE;
1856 call load (source, 0);
1857 call expmac_length_of_varying ((stfx1), pt);
1858 return;
1859 %page;
1860
1861
1862
1863
1864 assign_op$fix_dec_scaled:
1865 entry (pt);
1866
1867 always_round, check_size = FALSE;
1868 p2 = pt;
1869 s2 = p2 -> reference.symbol;
1870 p1 = decimal_op$get_float_temp (s2 -> symbol.c_dcl_size, (s2 -> symbol.complex));
1871 s1 = p1 -> reference.symbol;
1872 macro = multiply_decimal;
1873 exponent.pad = "0"b;
1874 exponent.value = -s2 -> symbol.scale;
1875 call assign_decimal;
1876 pt = p1;
1877 return;
1878 %page;
1879
1880
1881
1882
1883 assign_op$to_dec_scaled:
1884 entry (pt, source);
1885
1886 always_round, check_size = FALSE;
1887 p2 = source;
1888 p1 = pt;
1889 s1 = p1 -> reference.symbol;
1890 s2 = p2 -> reference.symbol;
1891 macro = multiply_decimal;
1892 exponent.pad = "0"b;
1893 exponent.value = s1 -> symbol.scale;
1894 call assign_decimal;
1895 if ^p1 -> reference.shared then
1896 p1 -> reference.evaluated = TRUE;
1897 return;
1898 %page;
1899
1900
1901
1902 eis_move:
1903 proc;
1904
1905 if p1 -> reference.temp_ref then
1906 p1 -> reference.value_in.storage = TRUE;
1907
1908 if ^(check_size & p1 -> reference.length ^= null) then do;
1909 if all_same then do;
1910 call expmac$one_eis ((blank_cs), p1);
1911 if length2 > 0 then
1912 addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> instruction.fill =
1913 substr (s2 -> symbol.initial -> based_cs, 1, 1);
1914 return;
1915 end;
1916
1917 if all_ones then do;
1918 if p1 -> reference.aligned_for_store_ref then
1919 if mod (size1, bits_per_char) = 0 then do;
1920 m1 = one_cs;
1921 call long_op$one_eis (p1, divide (size1 + bits_per_char - 1, bits_per_char, 17, 0), m1);
1922 return;
1923 end;
1924
1925 m1 = one_bs;
1926 call expmac$one_eis (m1, p1);
1927 return;
1928 end;
1929
1930 if all_zeros then do;
1931 if p1 -> reference.aligned_for_store_ref then
1932 if p1 -> reference.length = null then do;
1933 if p1 -> reference.padded_for_store_ref | mod (size1, bits_per_char) = 0 then do;
1934 m1 = zero_cs;
1935 call long_op$one_eis (p1, divide (size1 + bits_per_char - 1, bits_per_char, 17, 0), m1)
1936 ;
1937 return;
1938 end;
1939 end;
1940 else if p1 -> reference.padded_for_store_ref then do;
1941 call load_size (p1);
1942 if p1 -> reference.ref_count = 1 then
1943 call need_temp (p1, "01"b);
1944 call expmac$zero ((b2c_mac));
1945 call expmac$one_eis ((zero_cs_q), p1);
1946 return;
1947 end;
1948
1949 m1 = zero_bs;
1950 call expmac$one_eis (m1, p1);
1951 return;
1952 end;
1953 end;
1954
1955 if check_size then
1956 macro = chars_move_ck;
1957 else
1958 macro = chars_move;
1959
1960 call expmac$two_eis (macro + dt, p1, p2);
1961 end eis_move;
1962 %page;
1963
1964
1965
1966
1967 get_length:
1968 proc (pt) returns (ptr);
1969
1970 dcl pt ptr parameter;
1971 dcl (q, q1) ptr;
1972
1973 q = pt -> reference.length;
1974
1975 if q ^= null then do;
1976 if q -> node.type = operator_node then do;
1977 q1 = q -> operand (1);
1978 if q1 -> reference.shared then
1979 q -> operand (1) = copy_temp (q1);
1980 q = q -> operand (1);
1981 end;
1982
1983 if ^q -> reference.shared then
1984 q -> reference.ref_count = q -> reference.ref_count + 1;
1985 end;
1986
1987 return (q);
1988 end get_length;
1989 %page;
1990
1991
1992
1993
1994
1995 get_length_in_storage:
1996 proc (pt) returns (ptr);
1997
1998 dcl pt ptr parameter;
1999 dcl p ptr;
2000
2001 p = get_length ((pt));
2002
2003 if p ^= null then
2004 if ^p -> reference.aligned_ref then
2005 p = compile_exp$save (p);
2006
2007 return (p);
2008
2009 end get_length_in_storage;
2010 %page;
2011
2012
2013
2014
2015
2016 get_suffix_length:
2017 proc (pt) returns (ptr);
2018
2019 dcl pt ptr parameter;
2020 dcl (p, q) ptr;
2021
2022 p = pt;
2023
2024 q = get_length_in_storage (p);
2025
2026 if q = null then do;
2027 if p -> reference.c_length ^= 0 | ^p -> reference.varying_ref then
2028 q = generate_constant$real_fix_bin_1 ((p -> reference.c_length));
2029 end;
2030 else if q -> reference.data_type = real_fix_bin_2 then
2031 q = get_single_ref (q);
2032
2033 return (q);
2034
2035 end get_suffix_length;
2036 %page;
2037
2038
2039
2040 expmac_length_of_varying:
2041 proc (macro, pt);
2042
2043 dcl macro fixed bin (15) parameter;
2044 dcl pt ptr parameter;
2045
2046 dcl p ptr;
2047 dcl addr_hold bit (36) aligned;
2048 dcl reloc_hold bit (12) aligned;
2049
2050 p = pt;
2051
2052 if string (p -> reference.address_in.b) ^= "0"b & ^p -> reference.temp_ref then do;
2053
2054 if p -> address.offset ^= (15)"0"b | p -> reference.no_address then
2055 call m_a (p, "00"b);
2056 p -> address.offset = (15)"1"b;
2057 end;
2058 else do;
2059 addr_hold = string (p -> reference.address);
2060 reloc_hold = p -> reference.relocation;
2061 p -> reference.c_offset = p -> reference.c_offset - 1;
2062 call m_a (p, "00"b);
2063 p -> reference.c_offset = p -> reference.c_offset + 1;
2064 end;
2065
2066 p -> reference.perm_address = TRUE;
2067
2068 if ^last_macro then
2069 if ^p -> reference.shared then
2070 p -> reference.ref_count = p -> reference.ref_count + 1;
2071
2072 call expmac (macro, p);
2073
2074 p -> reference.perm_address = FALSE;
2075
2076 if string (p -> reference.address_in.b) ^= "0"b & ^p -> reference.temp_ref then
2077 p -> address.offset = (15)"0"b;
2078 else do;
2079 string (p -> reference.address) = addr_hold;
2080 p -> reference.relocation = reloc_hold;
2081 end;
2082
2083 end expmac_length_of_varying;
2084 %page;
2085
2086
2087
2088 scaler:
2089 proc (amt, type);
2090
2091 dcl (amt, type) fixed bin parameter;
2092
2093 if amt < 0 then do;
2094 call xr_man$load_const (abs (amt), 2);
2095 call expmac$zero ((truncate (type)));
2096 end;
2097 else
2098 call expmac ((left_shift (type)), c_a (amt, 1));
2099
2100 end scaler;
2101 %page;
2102
2103
2104
2105 compare_refs:
2106 proc (p1, p2) reducible returns (bit (1) aligned);
2107
2108 dcl (p1, p2) ptr parameter;
2109
2110 if p1 -> reference.symbol ^= p2 -> reference.symbol then
2111 return (FALSE);
2112 else if p1 -> reference.c_offset ^= p2 -> reference.c_offset then
2113 return (FALSE);
2114 else if ^compare_expression ((p1 -> reference.offset), (p2 -> reference.offset)) then
2115 return (FALSE);
2116 else if ^compare_expression ((p1 -> reference.qualifier), (p2 -> reference.qualifier)) then
2117 return (FALSE);
2118 else
2119 return (TRUE);
2120
2121 end compare_refs;
2122 %page;
2123
2124
2125
2126 adjust_suff_temp:
2127 proc (pt);
2128
2129 dcl pt ptr parameter;
2130 dcl p ptr;
2131
2132 p = pt;
2133 top = p -> reference.length;
2134 call adjust_suff_op (top);
2135 call adjust_ref_count (p, -1);
2136
2137 end adjust_suff_temp;
2138 %page;
2139
2140
2141
2142 adjust_suff_op:
2143 proc (pt);
2144
2145 dcl pt ptr parameter;
2146 dcl (p, q) ptr;
2147 dcl i fixed bin;
2148
2149 p = pt;
2150
2151 if p -> node.type = operator_node then do;
2152 q = p -> operand (1);
2153 if ^q -> reference.evaluated then
2154 if q -> reference.ref_count <= 1 then
2155 do i = 2 to p -> operator.number;
2156 if p -> operand (i) ^= null then
2157 call adjust_suff_op ((p -> operand (i)));
2158 end;
2159 end;
2160 else
2161 q = p;
2162
2163 if p ^= top then
2164 if q -> node.type = reference_node then
2165 if ^q -> reference.shared then
2166 call adjust_ref_count (q, -1);
2167
2168 return;
2169
2170 end adjust_suff_op;
2171 %page;
2172
2173
2174
2175 assign_decimal:
2176 proc;
2177
2178 dcl (mac, ninst) fixed bin (15);
2179 dcl arg (2, 3) ptr;
2180
2181 mac = macro + fixed (s1 -> symbol.float | always_round, 1);
2182
2183 if macro = multiply_decimal then do;
2184 arg (1, 3), arg (2, 3) = generate_constant$char_string ("+1" || exponent_char, 3);
2185 k = 3;
2186 end;
2187 else
2188 k = 2;
2189
2190 ninst = fixed (s1 -> symbol.complex, 1) + 1;
2191
2192 arg (1, 1) = p1;
2193 arg (1, 2) = p2;
2194
2195 if ninst > 1 then do;
2196 arg (2, 1) = get_imaginary (p1);
2197 arg (2, 2) = get_imaginary (p2);
2198 end;
2199
2200 do i = 1 to ninst;
2201 call expmac$many_eis (mac, addr (arg (i, 1)), k);
2202
2203 if check_size then
2204 if s1 -> symbol.fixed then
2205 call expmac$zero ((size_ck_decimal));
2206 end;
2207
2208 end assign_decimal;
2209 %page;
2210
2211
2212
2213
2214 check_stringsize:
2215 proc;
2216
2217 if length1 < length2 then do;
2218 if ^cg_stat$cur_statement -> statement.suppress_warnings then
2219 call error (319, cg_stat$cur_statement, null);
2220 call expmac$zero ((signal_stringsize));
2221 end;
2222
2223 end check_stringsize;
2224 end assign_op;