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 compile_exp:
51 proc (pt);
52
53
54
55 dcl pt ptr;
56
57
58
59 dcl (
60 cg_stat$cur_node,
61 cg_stat$temp_ref,
62 cg_stat$eis_temp,
63 cg_stat$complex_ac,
64 cg_stat$text_base
65 ) ptr ext,
66 (
67 cg_stat$text_pos,
68 cg_stat$offset_null_value
69 ) fixed bin ext,
70 (
71 cg_stat$save_exp_called,
72 cg_stat$for_test_called,
73 cg_stat$extended_stack
74 ) bit (1) ext;
75
76 dcl (
77 opcode_info$opcode_info
78 (0:118),
79 opcode_info$last_opcode,
80 opcode_info$table (0:18)
81 ) fixed bin ext;
82
83
84
85 dcl (
86 p,
87 q,
88 pa,
89 ref1,
90 save_cur_node,
91 ref (5),
92 sym (5),
93 rand (5)
94 ) ptr,
95 (
96 sec,
97 ftc,
98 in_storage,
99 inline,
100 load_it,
101 atom (5),
102 update_long,
103 constant_rands,
104 save_it,
105 scaled,
106 update_ref,
107 atomic,
108 is_string,
109 check_type,
110 check_aligned
111 ) bit (1) aligned,
112 c_offset fixed bin (24),
113 drop bit (1) aligned init ("0"b),
114 op_code bit (9),
115 b3 bit (3) aligned;
116 dcl double bit (72) aligned;
117 dcl (mvt_table, result_string)
118 char (512) aligned,
119 op_class bit (5) defined (op_code) pos (1),
120 op_relative bit (4) defined (op_code) pos (6),
121 (
122 i,
123 j,
124 k,
125 n,
126 action,
127 op_rel,
128 delta,
129 call_code,
130 code,
131 type (5),
132 bump,
133 orig_count,
134 rlength,
135 scale,
136 array (2)
137 ) fixed bin,
138 (save_l1, save_l2) fixed bin (24),
139 save_mwif bit (1),
140 save_coff fixed bin (24),
141 save_units fixed bin (3),
142 (macro, m) fixed bin (15);
143
144
145
146 dcl (
147 load,
148 load$for_test,
149 load$for_save
150 ) entry (ptr, fixed bin),
151 load$long_string entry (ptr),
152 (assign_op, load_size)
153 entry (ptr),
154 aq_man$fix_scale entry (ptr, fixed bin, fixed bin),
155 aq_man$check_strings
156 entry (fixed bin (8)),
157 aq_man$left_shift entry (fixed bin (8), bit (1) aligned),
158 aq_man$right_shift entry (fixed bin (8), bit (1) aligned),
159 min_max entry (ptr),
160 compile_exp entry (ptr),
161 gen_arithmetic_builtin
162 entry (ptr, (5) ptr, (5) bit (1) aligned, fixed bin),
163 gen_arithmetic_call entry (ptr, (5) ptr, (5) aligned bit (1)),
164 xr_man$load_const entry (fixed bin, fixed bin),
165 (
166 compile_exp$save,
167 compile_exp$save_exp
168 ) entry (ptr) returns (ptr),
169 c_a entry (fixed bin (18), fixed bin) returns (ptr),
170 base_man$load_var entry (fixed bin, ptr, fixed bin),
171 (
172 base_man$load_a_var,
173 base_man$load_q_var,
174 base_man$load_aq_var
175 ) entry (ptr),
176 base_to_core entry (fixed bin, ptr),
177 expmac entry (fixed bin (15), ptr),
178 expmac$many_eis entry (fixed bin (15), ptr, fixed bin),
179 expmac$conditional entry (fixed bin (15), ptr, (5) ptr, (5) bit (1) aligned),
180 (
181 expmac$eis,
182 expmac$one_eis
183 ) entry (fixed bin (15), ptr),
184 expmac$two_eis entry (fixed bin (15), ptr, ptr),
185 expmac$abs entry (ptr, fixed bin),
186 long_op$eis_operator
187 entry (ptr, ptr, fixed bin (15)),
188 cg_error entry (fixed bin, fixed bin),
189 prepare_operand entry (ptr, fixed bin, bit (1) aligned) returns (ptr),
190 eval_exp entry (ptr, bit (1) aligned) returns (ptr),
191 (arith_op, decimal_op, exp_op)
192 entry (ptr, (5) ptr, (5) bit (1) aligned),
193 (string_op, cat_op) entry (ptr, (5) ptr, fixed bin),
194 pointer_builtins entry (ptr, bit (1) aligned),
195 get_reference entry returns (ptr),
196 inline_operation entry (ptr, (5) ptr, (5) bit (1) aligned) returns (bit (1) aligned),
197 set_indicators entry (ptr, ptr, ptr, fixed bin) returns (fixed bin),
198 expmac$zero entry (fixed bin (15)),
199 (
200 store$save_string_temp,
201 store$force,
202 state_man$update_ref
203 ) entry (ptr),
204 state_man$set_aliasables
205 entry (ptr),
206 stack_temp$assign_block
207 entry (ptr, fixed bin),
208 state_man$erase_temps
209 entry,
210 (
211 long_op,
212 long_op$c_or_b
213 ) entry (ptr, fixed bin, fixed bin (15));
214 dcl generate_constant$bit_string
215 entry (bit (*) aligned, fixed bin) returns (ptr);
216 dcl generate_constant$real_fix_bin_1
217 entry (fixed bin) returns (ptr),
218 generate_constant$char_string
219 entry (char (*) aligned, fixed bin (24)) returns (ptr),
220 state_man$erase_reg entry (bit (19) aligned),
221 state_man$flush entry,
222 string_temp entry (ptr, ptr, ptr) returns (ptr),
223 aq_man$lock entry (ptr, fixed bin),
224 adjust_ref_count entry (ptr, fixed bin),
225 copy_temp entry (ptr) returns (ptr),
226 share_expression entry (ptr) returns (ptr);
227
228
229
230 dcl (addr, addrel, collate9, copy, fixed, hbound, index, length, min, mod, null, rank, string, substr)
231 builtin;
232
233
234
235 dcl 1 bit_table_structure
236 based (addr (mvt_table)) aligned,
237 2 bit_table (0:511) bit (9) unaligned;
238
239 dcl fixed_bin_single fixed bin based,
240 fixed_bin_double fixed bin (71) based,
241 word bit (36) aligned based;
242
243 dcl based_cs char (1) aligned based;
244 dcl based_bs bit (1) aligned based;
245
246 dcl 1 mlr_instruction based aligned,
247 2 fill char (1) unal,
248 2 enablefault bit (1) unal,
249 2 pad1 bit (1) unal,
250 2 mf2 bit (7) unal,
251 2 opcode bit (10) unal,
252 2 inhibit bit (1) unal,
253 2 mf1 bit (7) unal;
254
255 dcl 1 csl_instruction based aligned,
256 2 fill bit (1) unal,
257 2 pad1 bit (4) unal,
258 2 bool bit (4) unal,
259 2 enablefault bit (1) unal,
260 2 pad2 bit (1) unal,
261 2 mf2 bit (7) unal,
262 2 opcode bit (10) unal,
263 2 inhibit bit (1) unal,
264 2 mf1 bit (7) unal;
265
266 dcl bit4 bit (4) based aligned;
267
268 dcl 1 op_info aligned based,
269 2 act1 unal bit (6),
270 2 act2 unal bit (6),
271 2 macro unal bit (18),
272 2 delta unal bit (2),
273 2 call_code unal bit (4);
274
275
276
277
278 dcl (
279 zero_bs init (468),
280 one_bs init (469),
281 blank_cs init (472),
282 inline_verify init (207),
283 inline_search init (199),
284 inline_translate init (111),
285 test_translate init (157),
286 test_translate_rev init (158),
287 verify_ltrim_inline init (712),
288 verify_rtrim_inline init (713),
289 absfx1 init (126),
290 testfx1 init (508),
291 ldfx1 init (7),
292 ldfx2 init (8),
293 als init (134),
294 arl init (245),
295 qrs init (514),
296 anq init (688),
297 ana init (40),
298 llr init (372),
299 scaled_mdfx1 init (549),
300 mdfl1 init (269),
301 mdfl2 init (270),
302 stfl2 init (18),
303 stfx1 init (15),
304 offset_mac_easy init (242),
305 offset_mac_hard init (600),
306 chars_move init (420),
307 move_bits init (99),
308 test_bits init (96),
309 fetch_chars_eis init (588),
310 index_chars (4) init (452, 700, 702, 256),
311 index_chars_1 (4) init (460, 704, 706, 256),
312 index_mac (3, 2) init (460, 462, 704, 708, 706, 709),
313 index_rev_mac (2) init (463, 464),
314 round_fl init (531),
315 atan2_mac init (504),
316 atan2d_mac init (557),
317 a_to_x0 init (306),
318 rank_eis_mac init (740),
319 qrl init (418),
320 trunc_mac (0:1) init (124, 384)
321 ) fixed bin (15) int static options (constant);
322
323 dcl rel_table (4:9 , 0:1 , 0:1 ) fixed bin (15) int static
324 init (159, 161, 160, 162,
325 161, 159, 162, 160,
326 163, 163, 163, 163,
327 164, 164, 164, 164,
328 165, 167, 166, 168,
329 167, 165, 168, 166);
330
331 dcl exp_table (4, 4) fixed bin (15) int static init (592, 0, 559, 560,
332
333 0, 0, 0, 0,
334 591, 0, 565, 562,
335 564, 0, 561, 562);
336
337
338
339
340 %include cgsystem;
341 %include reference;
342 %include symbol;
343 %include operator;
344 %include machine_state;
345 %include nodes;
346 %include data_types;
347 %include boundary;
348 %include op_codes;
349 %include mask;
350 %include bases;
351 ^L
352
353
354 ftc = cg_stat$for_test_called;
355 cg_stat$for_test_called = "0"b;
356
357 start:
358 sec = cg_stat$save_exp_called;
359 cg_stat$save_exp_called = "0"b;
360
361 p = pt;
362
363 if p -> node.type ^= operator_node
364 then do;
365 is_atom:
366 i = p -> reference.data_type;
367 call load (p, fixed (i = char_string | i = bit_string, 1));
368 save_cur_node = cg_stat$cur_node;
369 goto return_1;
370 end;
371
372 ref (1) = p -> operand (1);
373 if ^ref (1) -> reference.shared
374 then do;
375
376 if ref (1) -> reference.evaluated
377 then do;
378 p = ref (1);
379 goto is_atom;
380 end;
381
382 if ref (1) -> reference.temp_ref & ^ref (1) -> reference.long_ref & ^ref (1) -> reference.aggregate
383 & ref (1) -> reference.data_type ^= complex_flt_bin_1
384 then drop = "1"b;
385 else drop = "0"b;
386
387 end;
388
389 work:
390 save_cur_node = cg_stat$cur_node;
391 cg_stat$cur_node = p;
392
393 save_it = cg_stat$save_exp_called;
394 update_ref = "1"b;
395
396 update_long, in_storage = "0"b;
397 op_code = p -> operator.op_code;
398
399 do i = 1 to min (p -> operator.number, hbound (rand, 1));
400 rand (i) = p -> operand (i);
401 end;
402
403 op_rel = fixed (op_relative, 4);
404 k = opcode_info$table (fixed (op_class, 5)) + op_rel;
405 if k > opcode_info$last_opcode
406 then goto not_yet;
407
408 q = addr (opcode_info$opcode_info (k));
409 action = fixed (q -> op_info.act1, 6);
410
411 goto switch_a (action);
412
413
414
415 switch_a (1):
416 call assign_op (pt);
417 ref1 = cg_stat$temp_ref;
418 goto return;
419
420
421
422 switch_a (2):
423 call min_max (pt);
424 ref1 = cg_stat$temp_ref;
425
426 if ref1 -> reference.symbol -> symbol.decimal
427 then goto return;
428
429 inline = "1"b;
430 goto done_1;
431
432
433
434 switch_a (4):
435 call cg_error (300, fixed (op_code, 9));
436 goto return;
437
438 switch_a (5):
439 not_yet:
440 call cg_error (301, fixed (op_code, 9));
441 goto return;
442
443
444
445 switch_a (6):
446 call pointer_builtins (p, ^drop);
447
448
449
450
451
452
453 ref1 = p -> operator.operand (1);
454 if ^ref1 -> reference.temp_ref | ^ref1 -> reference.shared
455 then ref1 -> reference.evaluated = "1"b;
456
457 goto return;
458
459
460
461 switch_a (3):
462 action = fixed (q -> op_info.act2, 6);
463 macro = fixed (q -> op_info.macro, 18);
464 delta = fixed (q -> op_info.delta, 2);
465 call_code = fixed (q -> op_info.call_code, 4);
466
467 n = p -> operator.number;
468 do i = n by -1 to 2;
469 q = prepare_operand (rand (i), 1, atom (i));
470 ref (i) = q;
471 sym (i) = q -> reference.symbol;
472 type (i) = q -> reference.data_type;
473 end;
474
475
476
477
478
479
480
481
482 if op_code = repeat_fun
483 then if ref (2) -> reference.c_length = 1 & is_string_constant (2)
484 then ref1 = prepare_operand (rand (1), 1, atom (1));
485 else go to prepare_minus_1;
486 else
487 prepare_minus_1:
488 ref1 = prepare_operand (rand (1), -1, atom (1));
489
490 ref (1) = ref1;
491 sym (1) = ref (1) -> reference.symbol;
492 type (1) = ref (1) -> reference.data_type;
493
494
495
496 cg_stat$for_test_called = cg_stat$for_test_called & ref1 -> reference.ref_count <= 1;
497
498 if sym (1) -> symbol.decimal
499 then inline = "0"b;
500
501 else if sym (1) -> symbol.complex | action = 7 | action = 30
502 then inline = inline_operation (p, ref, atom);
503
504 else
505 inline = "1"b;
506
507
508
509 if n = 2
510 then code = fixed (atom (2), 1);
511 else if n = 3
512 then code = fixed (atom (2) || atom (3), 2);
513
514 if sym (1) -> symbol.complex & inline
515 then do;
516
517 if ^ref (1) -> reference.allocate
518 then do;
519
520 use_cpx:
521 q = get_reference ();
522 q -> reference = ref (1) -> reference;
523 ref (1) = q;
524
525 ref (1) -> reference.offset, ref (1) -> reference.qualifier = null;
526 string (ref (1) -> reference.address) = string (cg_stat$complex_ac -> reference.address);
527 ref (1) -> reference.relocation = cg_stat$complex_ac -> reference.relocation;
528 ref (1) -> reference.perm_address = "1"b;
529 goto branch;
530 end;
531
532 else if ref (1) -> reference.temp_ref
533 then do;
534 ref (1) -> reference.value_in.storage = "1"b;
535 if ^cg_stat$save_exp_called
536 then do;
537 save_it = "1"b;
538 ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;
539 end;
540 end;
541
542 if op_code = mult
543 then if min (type (2), type (3)) = complex_flt_bin_1
544 then goto use_cpx;
545 else ;
546 else if op_code = div
547 then if type (3) = complex_flt_bin_1
548 then goto use_cpx;
549
550 if ref (1) -> reference.offset ^= null
551 then goto use_cpx;
552
553 q = ref (1) -> reference.symbol;
554 if q -> symbol.static & q -> symbol.external
555 then goto use_cpx;
556 if q -> symbol.parameter
557 then goto use_cpx;
558
559 in_storage = "1"b;
560 update_ref = "0"b;
561 end;
562
563 branch:
564 goto switch_b (action);
565
566
567
568 switch_b (1):
569 if ^inline
570 then if sym (1) -> symbol.decimal
571 then call decimal_op (pt, ref, atom);
572
573
574
575 else call gen_arithmetic_call (p, ref, atom);
576
577 else call arith_op (pt, ref, atom);
578
579
580
581 done:
582 cg_stat$temp_ref = ref1;
583
584 done_1:
585 if ^ref1 -> reference.shared
586 then ref1 -> reference.evaluated = "1"b;
587
588 if ^inline
589 then goto return;
590
591 if cg_stat$for_test_called
592 then goto return;
593
594 if update_ref & (^ref1 -> reference.long_ref | update_long)
595 then do;
596 k = ref1 -> reference.c_offset;
597 ref1 -> reference.c_offset = 0;
598
599 call state_man$update_ref (ref1);
600
601 ref1 -> reference.c_offset = k;
602 end;
603
604 if ref1 -> reference.allocate
605 then do;
606
607 if ref1 -> reference.temp_ref
608 then if ^save_it
609 then if ^ref1 -> reference.aggregate
610 then go to return;
611
612 if ref1 -> reference.long_ref
613 then do;
614 if ref1 -> reference.temp_ref & ^ref1 -> reference.aggregate
615 then if ref1 -> reference.address_in.storage
616 then call store$save_string_temp (ref1);
617 else ;
618 else if ref1 ^= cg_stat$eis_temp
619 then call expmac$two_eis (chars_move + type (1) - char_string, ref1, cg_stat$eis_temp);
620 goto return;
621 end;
622
623 if in_storage
624 then goto return;
625
626 if ref1 -> reference.data_type = complex_flt_bin_1
627 then call expmac ((ldfx2), cg_stat$complex_ac);
628
629 call store$force (ref1);
630 end;
631
632 return:
633 if cg_stat$save_exp_called
634 then do;
635 ref_pt = cg_stat$temp_ref;
636 ref_pt -> reference.ref_count = orig_count;
637 end;
638 else if drop
639 then call adjust_ref_count (ref1, -1);
640
641 return_1:
642 cg_stat$save_exp_called = sec;
643 cg_stat$for_test_called = ftc;
644 cg_stat$cur_node = save_cur_node;
645 return;
646
647
648
649 switch_b (2):
650 if type (3) = real_fix_bin_1
651 then if is_constant (3)
652 then if sym (3) -> symbol.initial -> fixed_bin_single > 1
653 then do;
654 call exp_op (pt, ref, atom);
655 go to done;
656 end;
657 else if sym (3) -> symbol.initial -> fixed_bin_single = 1
658 then go to switch_a (1);
659
660 check_type = "0"b;
661 macro = exp_table (type (2), type (3));
662 call math_op;
663 goto done;
664
665
666
667 switch_b (3):
668 cg_stat$for_test_called = cg_stat$for_test_called & ref1 -> reference.ref_count <= 1;
669
670 call string_op (pt, ref, code);
671
672 goto done;
673
674
675
676 switch_b (4):
677 call state_man$erase_temps;
678 k = set_indicators (pt, ref (2), ref (3), code);
679
680 if type (2) <= real_flt_bin_2
681 then j = 0;
682 else do;
683 q = ref (2) -> reference.symbol;
684 j = fixed (q -> symbol.bit | q -> symbol.char, 1);
685 end;
686
687 call expmac$zero ((rel_table (op_rel, j, k)));
688 a_reg.size = 1;
689 goto bnf1;
690
691
692
693
694 declare charno_mac fixed bin (15) init (691) int static options (constant);
695 declare bitno_mac fixed bin (15) init (692) int static options (constant);
696 declare baseno_mac fixed bin (15) init (241) int static options (constant);
697 declare segno_mac fixed bin (15) init (240) int static options (constant);
698 declare packed_pointer bit (1) aligned;
699
700 switch_b (5):
701 if ref (2) -> reference.data_type = packed_ptr
702 then do;
703 packed_pointer = "1"b;
704 if ^ref (2) -> reference.value_in.storage
705
706 then if ^ref (2) -> reference.value_in.q
707 then if string (ref (2) -> reference.value_in.b) ^= ""b
708 then packed_pointer = "0"b;
709 end;
710 else do;
711 packed_pointer = "0"b;
712
713 if ^atom (2)
714 then if rand (2) -> node.type = operator_node
715
716 then do;
717 call pointer_builtins (rand (2), "0"b);
718 ref (2) = rand (2) -> operand (1);
719 if ^ref (2) -> reference.shared
720 then ref (2) -> reference.evaluated = "1"b;
721 end;
722 end;
723
724 if packed_pointer
725 then go to PACKED_POINTER_BIFS (macro);
726 else go to POINTER_BIFS (macro);
727
728
729 PACKED_POINTER_BIFS (1):
730 PACKED_POINTER_BIFS (10):
731 ref (2) -> reference.data_type = bit_string;
732 go to LOAD_PP_COMMON;
733 PACKED_POINTER_BIFS (2):
734 PACKED_POINTER_BIFS (3):
735 PACKED_POINTER_BIFS (4):
736 PACKED_POINTER_BIFS (9):
737 ref (2) -> reference.data_type = real_fix_bin_1;
738
739 LOAD_PP_COMMON:
740 call load (ref (2), 0);
741 ref (2) -> reference.data_type = packed_ptr;
742
743 go to PACKED_POINTER_BIFS_2 (macro);
744
745 PACKED_POINTER_BIFS_2 (1):
746 q = c_a ((bits_per_half), 1);
747 call expmac (als, q);
748 go to RETURN_18_BITS;
749
750 PACKED_POINTER_BIFS_2 (2):
751 q = c_a (-1, 2);
752 call expmac (anq, q);
753 go to done;
754
755 declare charno_packed_mac init (377) fixed bin (15) int static options (constant);
756 PACKED_POINTER_BIFS_2 (3):
757 call expmac$zero (charno_packed_mac);
758 go to done;
759
760 PACKED_POINTER_BIFS_2 (4):
761 q = c_a (12 + 18, 1);
762 call expmac (qrl, q);
763 go to done;
764
765 declare baseno_mask init (4095) fixed bin (18) static options (constant);
766
767 PACKED_POINTER_BIFS_2 (9):
768 q = c_a ((bits_per_half), 1);
769 call expmac (qrl, q);
770 q = c_a (baseno_mask, 2);
771 call expmac (anq, q);
772 go to done;
773
774 PACKED_POINTER_BIFS_2 (10):
775 q = c_a (baseno_mask, 3);
776 call expmac (ana, q);
777 go to RETURN_18_BITS;
778
779
780 POINTER_BIFS (1):
781 call base_man$load_a_var (ref (2));
782 go to RETURN_18_BITS;
783
784
785 POINTER_BIFS (2):
786 call base_man$load_q_var (ref (2));
787 macro = qrl;
788 q = c_a ((bits_per_half), 1);
789 call expmac (macro, q);
790 go to done;
791
792
793 POINTER_BIFS (3):
794 call base_man$load_aq_var (ref (2));
795 call expmac$zero (charno_mac);
796 go to done;
797
798 POINTER_BIFS (4):
799 call base_man$load_aq_var (ref (2));
800 call expmac$zero (bitno_mac);
801 go to done;
802
803
804 POINTER_BIFS (9):
805 POINTER_BIFS (10):
806 call base_man$load_aq_var (ref (2));
807 if op_code = segno_fun
808 then do;
809 call expmac$zero (segno_mac);
810 go to done;
811 end;
812 call expmac$zero (baseno_mac);
813
814 RETURN_18_BITS:
815 l9a:
816 a_reg.size = bits_per_half;
817
818 bnf1:
819 a_reg.length = bits_per_word;
820 a_reg.offset = 0;
821 goto done;
822
823
824
825
826 switch_b (6):
827 if ^inline
828 then goto ext_call;
829
830 l2:
831 if atom (2)
832 then call load (ref (2), 0);
833 else call compile_exp (rand (2));
834
835 if delta = 1
836 then macro = macro + fixed (type (1) ^= real_fix_bin_1, 1);
837
838 switch_b (23):
839 l2a:
840 if macro ^= 0
841 then call expmac$zero (macro);
842 goto done;
843
844
845
846 switch_b (7):
847 if ^inline
848 then do;
849
850 ext_call:
851 load_it = "0"b;
852 if ref (1) -> reference.temp_ref & ^cg_stat$save_exp_called
853 then do;
854 if sym (1) -> symbol.binary & sym (1) -> symbol.real
855 then if sym (2) -> symbol.decimal
856 then do;
857 load_it = "0"b;
858 bump = 0;
859 inline = "1"b;
860 end;
861 else do;
862 load_it = "1"b;
863 bump = 2;
864 end;
865 else bump = 1;
866
867 if ^ref (1) -> reference.shared
868 then ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + bump;
869 end;
870
871 if sym (2) -> symbol.decimal
872 then call decimal_op (p, ref, atom);
873 else call gen_arithmetic_builtin (p, ref, atom, call_code);
874
875 if load_it
876 then call load (ref (1), 0);
877
878 goto done;
879 end;
880
881 if atom (2)
882 then call load$for_test (ref (2), 0);
883 else call compile_exp_and_set_indicators (rand (2), type (2));
884
885 macro = absfx1 - real_fix_bin_1 + type (2);
886 goto l2a;
887
888
889
890 switch_b (8):
891 if ^inline
892 then goto ext_call;
893
894 if sym (2) -> symbol.float
895 then do;
896 macro = trunc_mac (fixed (type (1) ^= real_fix_bin_1, 1));
897 goto l2;
898 end;
899
900
901
902 l7:
903 if sym (2) -> symbol.scale <= 0
904 then do;
905 macro = 0;
906 goto l2;
907 end;
908
909 scale = sym (2) -> symbol.scale;
910 if atom (2)
911 then call load (ref (2), 0);
912 else call compile_exp (rand (2));
913
914 k = type (2) - real_fix_bin_1;
915 macro = macro + k;
916
917 call xr_man$load_const (scale, 2);
918
919 if k > 0
920 then if action ^= 8
921 then call xr_man$load_const (-2 * scale, 3);
922 goto l2a;
923
924
925
926 switch_b (9):
927 if ^atom (3)
928 then ref (3) = compile_exp$save (rand (3));
929 if atom (2)
930 then call load (ref (2), 0);
931 else call compile_exp (rand (2));
932
933 if delta = 1
934 then macro = macro + fixed (type (1) ^= real_fix_bin_1, 1);
935
936 call expmac (macro, ref (3));
937
938 if action = 21
939 then if scaled
940 then do;
941 array (1) = sym (2) -> symbol.scale;
942 array (2) = sym (3) -> symbol.scale;
943 call expmac$abs (addr (array), 2);
944 end;
945 goto done;
946
947
948
949 switch_b (10):
950 call expmac$conditional (macro, pt, ref, atom);
951 goto done;
952
953
954
955 switch_b (14):
956 cg_stat$for_test_called = "0"b;
957 call cat_op (pt, ref, code);
958 goto done;
959
960
961
962 switch_b (15):
963 if op_code = index_fun
964 then m = 1;
965 else if op_code = index_before_fun
966 then m = 2;
967 else m = 3;
968
969 if type (2) = char_string
970 then do;
971 rlength = ref (3) -> reference.c_length;
972 if rlength = 1 | rlength = 2
973 then do;
974 if op_code = index_rev_fun
975 then macro = index_rev_mac (rlength);
976 else macro = index_mac (m, rlength);
977 if ^atom (2)
978 then ref (2) = compile_exp$save_exp (rand (2));
979 if ^atom (3)
980 then ref (3) = compile_exp$save_exp (rand (3));
981 call expmac$two_eis (macro, ref (2), ref (3));
982 go to done;
983 end;
984 else if op_code = index_rev_fun
985 then m = 4;
986 end;
987
988 else if ref (3) -> reference.c_length = 1
989 then do;
990 if ^atom (2)
991 then if rand (2) -> node.type = operator_node
992 then if rand (2) -> operator.op_code = reverse_fun
993 then goto ind0;
994 else ref (2) = compile_exp$save (rand (2));
995
996 call compile_exp (rand (3));
997
998
999
1000 if ref (2) -> reference.big_offset
1001 then do;
1002 call aq_man$lock (null, 1);
1003 if ^ref (2) -> reference.shared
1004 then ref (2) -> reference.ref_count = ref (2) -> reference.ref_count + 1;
1005 call base_man$load_var (2, ref (2), 1);
1006 end;
1007
1008 call long_op$c_or_b (ref (2), 0, (index_chars_1 (m)));
1009 goto done;
1010 end;
1011
1012
1013
1014 ind0:
1015 if ^atom (3)
1016 then ref (3) = compile_exp$save_exp (rand (3));
1017
1018 if ^atom (2)
1019 then call compile_string;
1020
1021 call load$long_string (ref (2));
1022 call long_op$c_or_b (ref (3), 0, (index_chars (m)));
1023 goto done;
1024
1025
1026
1027 switch_b (16):
1028 call load_size (ref (2));
1029 if ^ref (2) -> reference.shared
1030 then call adjust_ref_count (ref (2), -1);
1031 goto done;
1032
1033
1034
1035 switch_b (17):
1036 if ^atom (2)
1037 then ref (2) = compile_exp$save (rand (2));
1038
1039 pa = ref (2) -> reference.symbol;
1040 if pa -> symbol.constant
1041 then do;
1042
1043
1044
1045 call load (generate_constant$real_fix_bin_1 (cg_stat$offset_null_value), 0);
1046 goto done;
1047 end;
1048
1049 call check_ptr;
1050
1051 call load (ref (2), 0);
1052 k = ref (2) -> reference.data_type - unpacked_ptr;
1053
1054 pa = ref (3) -> reference.symbol;
1055 if pa -> symbol.internal & (pa -> symbol.auto | pa -> symbol.static)
1056 then macro = offset_mac_easy;
1057 else macro = offset_mac_hard;
1058
1059 call expmac (macro + k, ref (3));
1060 goto done;
1061
1062
1063
1064 switch_b (18):
1065 call expmac (macro, ref (1));
1066 cg_stat$temp_ref = ref (1);
1067 goto return;
1068
1069
1070
1071 switch_b (19):
1072 call expmac (macro, ref (2));
1073 goto done;
1074
1075
1076
1077 switch_b (20):
1078 if ^inline
1079 then goto ext_call;
1080
1081 if sym (2) -> symbol.float
1082 then do;
1083 macro = macro + 2;
1084 goto l2;
1085 end;
1086
1087 goto l7;
1088
1089
1090
1091 switch_b (21):
1092 if ^inline
1093 then goto ext_call;
1094
1095 scaled = "0"b;
1096
1097 if sym (1) -> symbol.float
1098 then do;
1099 if type (1) = real_flt_bin_1
1100 then macro = mdfl1;
1101 else do;
1102 macro = mdfl2;
1103
1104 if type (3) = real_flt_bin_1
1105 then do;
1106
1107 if atom (3) & is_constant (3)
1108 then do;
1109 double = sym (3) -> symbol.initial -> word;
1110 ref (3) = generate_constant$bit_string (double, (bits_per_two_words));
1111 ref (3) -> reference.symbol -> symbol.boundary = mod2_;
1112 end;
1113 else do;
1114 call compile_exp (rand (3));
1115 call save_ref_3;
1116 end;
1117
1118 atom (3) = "1"b;
1119 end;
1120 end;
1121
1122 goto switch_b (9);
1123 end;
1124
1125 k = 2 * type (2) + type (3) - 3;
1126
1127 if sym (2) -> symbol.scale = 0 & sym (3) -> symbol.scale = 0
1128 then macro = macro + k;
1129 else do;
1130 macro = scaled_mdfx1 + k;
1131 scaled = "1"b;
1132 end;
1133
1134 go to switch_b (9);
1135
1136
1137
1138 switch_b (22):
1139 if ^inline
1140 then goto ext_call;
1141 if sym (1) -> symbol.complex
1142 then goto ext_call;
1143
1144 if atom (2)
1145 then call load (ref (2), 0);
1146 else call compile_exp (rand (2));
1147
1148 if type (3) = real_fix_bin_1
1149 then k = sym (3) -> symbol.initial -> fixed_bin_single;
1150 else k = sym (3) -> symbol.initial -> fixed_bin_double;
1151
1152 if sym (2) -> symbol.float
1153 then do;
1154 call expmac ((round_fl), c_a ((k), 1));
1155 goto done;
1156 end;
1157
1158 macro = macro + type (2) - real_fix_bin_1;
1159
1160 j = sym (2) -> symbol.scale - k;
1161
1162 if j > 0
1163 then do;
1164 call xr_man$load_const (j, 7);
1165 goto l2a;
1166 end;
1167 else do;
1168 call aq_man$fix_scale (ref (2), k, type (1));
1169 go to done;
1170 end;
1171
1172
1173
1174 switch_b (24):
1175 if (op_code = repeat_fun) & (ref (2) -> reference.c_length = 1) & is_string_constant (2)
1176 then do;
1177
1178
1179
1180 NOTE
1181
1182
1183
1184
1185 cg_stat$for_test_called = "0"b;
1186
1187 call adjust_ref_count (rand (3), -1);
1188
1189 ref (1) = string_temp (p, ref (2), null);
1190
1191 if type (1) = char_string
1192 then macro = blank_cs;
1193 else do;
1194 if ref (2) -> reference.units = word_
1195 then c_offset = ref (2) -> reference.c_offset * bits_per_word;
1196 else c_offset = ref (2) -> reference.c_offset;
1197
1198
1199 if substr (sym (2) -> symbol.initial -> based_bs, c_offset + 1, 1)
1200 then macro = one_bs;
1201 else macro = zero_bs;
1202 end;
1203
1204 call expmac$one_eis (macro, ref (1));
1205
1206 if type (1) = char_string
1207 then do;
1208 if ref (2) -> reference.units = word_
1209 then c_offset = ref (2) -> reference.c_offset * chars_per_word;
1210 else c_offset = ref (2) -> reference.c_offset;
1211
1212
1213 addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> mlr_instruction.fill =
1214 substr (sym (2) -> symbol.initial -> based_cs, c_offset + 1, 1);
1215 end;
1216
1217 go to eis_done;
1218 end;
1219
1220 if op_code = reverse_fun
1221 then if ref (2) -> reference.c_length = 2
1222 then if ref1 -> reference.temp_ref & ^ref1 -> reference.aggregate
1223 then do;
1224
1225
1226
1227 if type (1) = char_string
1228 then macro = chars_move;
1229 else macro = move_bits;
1230 call adjust_ref_count (ref (2), 1);
1231
1232 if ^atom (2)
1233 then ref (2) = compile_exp$save_exp (rand (2));
1234 ref (1) = string_temp (p, ref (2), null);
1235 if ^(^ref (1) -> reference.aggregate & ref (1) -> reference.temp_ref)
1236 then call adjust_ref_count (ref (1), 1);
1237 save_l1 = ref (1) -> reference.c_length;
1238 save_l2 = ref (2) -> reference.c_length;
1239 ref (1) -> reference.c_length, ref (2) -> reference.c_length = 1;
1240 call adjust_c_offset (ref (1), +1);
1241 call expmac$two_eis (macro, ref (1), ref (2));
1242 call restore_c_offset (ref (1));
1243 call adjust_c_offset (ref (2), +1);
1244 call expmac$two_eis (macro, ref (1), ref (2));
1245 call restore_c_offset (ref (2));
1246 ref (1) -> reference.c_length = save_l1;
1247 ref (2) -> reference.c_length = save_l2;
1248
1249 goto eis_done;
1250 end;
1251
1252 if atom (2)
1253 then do;
1254 l10:
1255 call load$long_string (ref (2));
1256
1257 if op_code = repeat_fun
1258 then if atom (3)
1259 then call load (ref (3), 0);
1260 else call compile_exp (rand (3));
1261 else macro = macro + type (1) - char_string;
1262
1263 call expmac$zero (macro);
1264
1265 if type (1) = bit_string
1266 then do;
1267 machine_state.indicators = ind_invalid;
1268 cg_stat$for_test_called = "0"b;
1269 end;
1270
1271 l10a:
1272 if ref (1) -> reference.length ^= null
1273 then do;
1274
1275
1276
1277
1278
1279
1280 if action = 24
1281 then do;
1282 pa = prepare_operand ((ref (1) -> reference.length), 0, atomic);
1283
1284 if atomic
1285 then if ^pa -> reference.temp_ref
1286 then ref (1) -> reference.length = pa;
1287 else ;
1288 else do;
1289 if pa -> reference.shared
1290 then pa, ref (1) -> reference.length -> operand (1) = copy_temp (pa);
1291 pa -> reference.evaluated = "1"b;
1292 end;
1293
1294 call state_man$update_ref (pa);
1295 end;
1296 else ref (1) -> reference.length = eval_exp ((ref (1) -> reference.length), "1"b);
1297 end;
1298 else if ref (1) -> reference.c_length <= max_short_size (type (1))
1299 then call expmac$zero (fetch_chars_eis - char_string + type (1));
1300
1301 if ref (1) -> reference.long_ref
1302 then do;
1303 update_long = ref (1) -> reference.temp_ref & ^ref (1) -> reference.aggregate;
1304 if update_long
1305 then if ref (1) -> reference.length = null
1306 then if ref (1) -> reference.ref_count - fixed (cg_stat$save_exp_called, 1) > 1
1307 then do;
1308 update_long = "0"b;
1309 q = copy_temp (ref (1));
1310 call state_man$update_ref (q);
1311 call expmac$two_eis (chars_move + type (1) - char_string, ref (1), q);
1312 end;
1313 else ;
1314 else ;
1315 else do;
1316 q, cg_stat$eis_temp = COPY (ref (1));
1317 if ref (1) -> reference.length ^= null
1318 then q -> reference.length = share_expression ((ref (1) -> reference.length));
1319 q -> reference.ref_count = 1;
1320 call state_man$update_ref (q);
1321 end;
1322 end;
1323
1324 cg_stat$extended_stack = "1"b;
1325
1326 goto done;
1327 end;
1328
1329 call compile_string;
1330 goto l10;
1331
1332
1333
1334 switch_b (25):
1335 if ^atom (3)
1336 then ref (3) = compile_exp$save_exp (rand (3));
1337
1338 if ref (2) -> reference.c_length = 1
1339 then do;
1340 if ^atom (2)
1341 then call compile_string;
1342 if op_code = verify_fun | op_code = verify_rev_fun
1343 then macro = inline_verify;
1344 else macro = inline_search;
1345 call expmac$two_eis (macro, ref (2), ref (3));
1346 end;
1347
1348 else if is_constant (3)
1349 then do;
1350 if op_code = verify_ltrim_fun
1351 then macro = verify_ltrim_inline;
1352 else if op_code = verify_rtrim_fun
1353 then macro = verify_rtrim_inline;
1354 else if op_code = verify_rev_fun | op_code = search_rev_fun
1355 then macro = test_translate_rev;
1356 else macro = test_translate;
1357 if ^atom (2)
1358 then ref (2) = compile_exp$save_exp (rand (2));
1359 if op_code = search_rev_fun
1360 then op_code = search_fun;
1361 q = sym (3) -> symbol.initial;
1362
1363 if (ref (3) -> reference.c_length = 1) & (op_code ^= search_fun)
1364 then q = c_a (rank (substr (q -> based_cs, 1, 1)), 16);
1365
1366 else do;
1367 string (bit_table) = "0"b;
1368 do i = 1 to ref (3) -> reference.c_length;
1369 j = rank (substr (q -> based_cs, i, 1));
1370 bit_table (j) = "777"b3;
1371 end;
1372
1373 if op_code ^= search_fun
1374 then string (bit_table) = ^string (bit_table);
1375
1376 q = generate_constant$char_string (mvt_table, length (mvt_table));
1377 end;
1378
1379 call expmac$two_eis (macro, ref (2), q);
1380 end;
1381
1382 else do;
1383 if ^atom (2)
1384 then call compile_string;
1385 call long_op$eis_operator (ref (2), ref (3), macro);
1386 end;
1387
1388 go to done;
1389
1390
1391
1392 switch_b (26):
1393 if n = 4
1394 then macro = macro + 1;
1395
1396 constant_rands = "1"b;
1397
1398 do i = 3 to n;
1399 if ^atom (i)
1400 then do;
1401 ref (i) = compile_exp$save_exp (rand (i));
1402 constant_rands = "0"b;
1403 end;
1404 else constant_rands = constant_rands & is_constant (i);
1405 end;
1406
1407 if constant_rands
1408 then do;
1409
1410
1411
1412
1413 if ^atom (2)
1414 then ref (2) = compile_exp$save_exp (rand (2));
1415 if ref (2) -> reference.value_in.string_aq
1416
1417 then call state_man$erase_reg ("001"b);
1418
1419 ref (1) = string_temp (p, ref (2), null);
1420
1421
1422
1423 mvt_table = collate9 ();
1424
1425 q = sym (3) -> symbol.initial;
1426
1427 if n = 3
1428 then mvt_table = substr (q -> based_cs, 1, ref (3) -> reference.c_length);
1429 else do;
1430 result_string = substr (q -> based_cs, 1, ref (3) -> reference.c_length);
1431 q = sym (4) -> symbol.initial;
1432 do i = ref (4) -> reference.c_length to 1 by -1;
1433 j = rank (substr (q -> based_cs, i, 1));
1434 substr (mvt_table, j + 1, 1) = substr (result_string, i, 1);
1435 end;
1436 end;
1437
1438 ref (3) = generate_constant$char_string (mvt_table, length (mvt_table));
1439
1440 call expmac$many_eis ((inline_translate), addr (ref), 3);
1441 eis_done:
1442 if ^ref (1) -> reference.long_ref
1443 then if ^cg_stat$for_test_called
1444 then do;
1445 update_ref = "0"b;
1446 in_storage = ref1 = ref (1);
1447 if ^(cg_stat$save_exp_called & in_storage) & ref (1) -> reference.temp_ref
1448 & ^ref (1) -> reference.aggregate
1449 then do;
1450 if in_storage
1451 then if ^ref (1) -> reference.shared
1452 then ref (1) -> reference.ref_count =
1453 ref (1) -> reference.ref_count + 1;
1454 call load (ref (1), 1);
1455 end;
1456 end;
1457 go to done;
1458 end;
1459
1460 else do;
1461
1462
1463
1464 if ^atom (2)
1465 then call compile_string;
1466
1467 call load$long_string (ref (2));
1468
1469 if n = 3
1470 then call long_op (ref (3), 0, macro);
1471 else call long_op$eis_operator (ref (3), ref (4), macro);
1472
1473
1474
1475 go to l10a;
1476 end;
1477
1478
1479
1480 switch_b (27):
1481 if ^atom (2)
1482 then ref (2) = compile_exp$save (rand (2));
1483
1484 call compile_exp (rand (3));
1485
1486 call base_man$load_var (1, ref (2), 1);
1487 call state_man$set_aliasables (null);
1488 call expmac$zero (macro);
1489
1490 a_reg.size = 1;
1491 goto bnf1;
1492
1493 switch_b (29):
1494 switch_b (30):
1495 if inline
1496 then goto switch_b (10);
1497 else goto ext_call;
1498
1499
1500
1501 switch_b (31):
1502 if sym (2) -> symbol.decimal
1503 then go to ext_call;
1504
1505 if atom (2)
1506 then call load$for_test (ref (2), 0);
1507 else call compile_exp_and_set_indicators (rand (2), type (2));
1508
1509 goto l2a;
1510
1511
1512
1513 switch_b (32):
1514 if sym (2) -> symbol.internal
1515 then n = 13;
1516 else n = 9;
1517
1518 ref (2) = c_a ((sym (2) -> symbol.location), n);
1519 goto switch_b (19);
1520
1521
1522
1523 switch_b (33):
1524 if ^atom (2)
1525 then ref (2) = compile_exp$save_exp (rand (2));
1526
1527 if ^atom (3)
1528 then if rand (3) -> node.type = operator_node
1529 then if ref (3) -> reference.long_ref & atom (4)
1530 then call compile_exp (rand (3));
1531 else ref (3) = compile_exp$save (rand (3));
1532
1533 cg_stat$for_test_called =
1534 cg_stat$for_test_called & is_constant (4) & ref (2) -> reference.length = ref (3) -> reference.length
1535 & ref (2) -> reference.c_length <= ref (3) -> reference.c_length;
1536
1537 ref (1) = string_temp (p, ref (3), ref (2));
1538
1539 if is_constant (4)
1540 then do;
1541 if cg_stat$for_test_called
1542 then m = test_bits;
1543 else m = move_bits;
1544 call expmac$eis (m, ref (2));
1545 addrel (cg_stat$text_base, cg_stat$text_pos - 3) -> csl_instruction.bool =
1546 sym (4) -> symbol.initial -> bit4;
1547 end;
1548
1549 else do;
1550 call compile_exp (rand (4));
1551 call state_man$erase_reg ("1"b);
1552 call expmac ((arl), c_a (32, 1));
1553
1554 if need_areg ()
1555 then do;
1556 call expmac$zero ((a_to_x0));
1557 macro = macro + 1;
1558 end;
1559 else call aq_man$lock (null, 1);
1560
1561 call expmac$eis (macro, ref (2));
1562 end;
1563
1564 go to eis_done;
1565
1566
1567
1568 switch_b (34):
1569 if n = 3
1570 then do;
1571 check_type = "1"b;
1572 if op_code = atan_fun
1573 then macro = atan2_mac;
1574 else macro = atan2d_mac;
1575 end;
1576
1577 if type (1) = real_flt_bin_2
1578 then macro = macro + 1;
1579
1580 call math_op;
1581 go to done;
1582
1583
1584
1585
1586
1587
1588
1589 switch_b (35):
1590 if ^atom (2)
1591 then ref (2) = compile_exp$save (rand (2));
1592
1593 if ^atom (4)
1594 then ref (4) = compile_exp$save (rand (4));
1595
1596 call compile_exp (rand (3));
1597 call base_man$load_var (2, ref (2), 1 );
1598 if ref (2) -> reference.aliasable
1599 then call state_man$set_aliasables (ref (2));
1600 call expmac (macro, ref (4));
1601 a_reg.size = 1;
1602 go to bnf1;
1603
1604
1605
1606
1607
1608 switch_b (36):
1609 call state_man$erase_reg ((18)"0"b || "1"b);
1610 call expmac$zero (macro);
1611 go to done;
1612
1613
1614
1615
1616
1617 switch_b (37):
1618 if ^atom (2)
1619 then call compile_exp (rand (2));
1620 else call load (ref (2), 0);
1621
1622 call aq_man$check_strings (0);
1623 a_reg.offset = 63;
1624 a_reg.length = 9;
1625 a_reg.size = 72;
1626 call aq_man$left_shift (63, "1"b);
1627 go to done;
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640 switch_b (38):
1641 if ref (2) -> reference.hard_to_load
1642 then do;
1643
1644
1645
1646 if ^ref (1) -> reference.temp_ref | ref (1) -> reference.ref_count > 1
1647 then q = ref (1);
1648 else q = c_a (46, 4);
1649
1650 if q -> reference.temp_ref
1651 then q -> reference.value_in.storage = "1"b;
1652
1653 call expmac$two_eis (rank_eis_mac, q, ref (2));
1654 in_storage = "1"b;
1655
1656 if ^save_it & ref (1) -> reference.temp_ref
1657 then do;
1658 if ^ref (1) -> reference.shared
1659 then ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;
1660
1661 call expmac (ldfx1, q);
1662 end;
1663 else update_ref = "0"b;
1664 end;
1665 else do;
1666 if atom (2)
1667 then call load (ref (2), 1);
1668 else call compile_exp (rand (2));
1669
1670 call aq_man$right_shift (63, "1"b);
1671 a_reg.offset, a_reg.size, a_reg.length = 0;
1672 end;
1673 go to done;
1674 ^L
1675 compile_exp$for_test:
1676 entry (pt);
1677
1678 ftc = cg_stat$for_test_called;
1679 cg_stat$for_test_called = "1"b;
1680 goto start;
1681
1682 compile_exp$save:
1683 entry (pt, ref_pt);
1684
1685 dcl ref_pt ptr;
1686
1687 p = pt;
1688 if p -> node.type ^= operator_node
1689 then do;
1690
1691 if ^p -> reference.aligned_ref
1692 then do;
1693
1694 l4:
1695 i = p -> reference.data_type;
1696 is_string = i = char_string | i = bit_string;
1697
1698 if p -> reference.hard_to_load
1699 then if substr (string (p -> reference.value_in), 1, 2) = "00"b
1700
1701 then if p -> reference.ref_count > 0
1702 then do;
1703 if is_string | mod (p -> reference.c_length, bits_per_word) = 0
1704 then do;
1705 call load$for_save (p, 0);
1706 go to l5;
1707 end;
1708 end;
1709
1710 call load (p, fixed (is_string, 1));
1711
1712
1713
1714
1715 if p -> reference.aligned_ref
1716 then p -> reference.ref_count = p -> reference.ref_count + 2;
1717 else p = COPY (p);
1718
1719 call store$force (p);
1720 end;
1721
1722 l5:
1723 ref_pt = p;
1724 return;
1725 end;
1726
1727 check_aligned = "1"b;
1728
1729 l6:
1730 ref (1) = p -> operand (1);
1731 if ref (1) -> reference.evaluated
1732 then do;
1733 if check_aligned
1734 then if ^ref (1) -> reference.aligned_ref
1735 then if ^ref (1) -> reference.long_ref
1736 then if ^ref (1) -> reference.varying_ref
1737 then if ^ref (1) -> reference.symbol -> symbol.decimal
1738 then do;
1739 p = ref (1);
1740 go to l4;
1741 end;
1742 ref_pt = ref (1);
1743 return;
1744 end;
1745
1746 if ^ref (1) -> reference.allocate
1747 then do;
1748
1749 p -> operand (1) = copy_temp (ref (1));
1750 orig_count = 1;
1751 p -> operand (1) -> reference.ref_count = 2;
1752 end;
1753 else if ^ref (1) -> reference.shared
1754 then do;
1755 orig_count = ref (1) -> reference.ref_count;
1756 ref (1) -> reference.ref_count = orig_count + 1;
1757 end;
1758
1759 ftc = cg_stat$for_test_called;
1760 cg_stat$for_test_called = "0"b;
1761
1762 sec = cg_stat$save_exp_called;
1763 cg_stat$save_exp_called = "1"b;
1764
1765 goto work;
1766
1767 compile_exp$save_exp:
1768 entry (pt, ref_pt);
1769
1770 p = pt;
1771 if p -> node.type ^= operator_node
1772 then goto l5;
1773
1774 check_aligned = "0"b;
1775 goto l6;
1776
1777 compile_exp$save_fix_scaled:
1778 entry (pt, target_scale, targ_type) returns (ptr);
1779
1780 dcl target_scale fixed bin,
1781 target_type fixed bin,
1782 targ_type fixed bin;
1783
1784 target_type = targ_type;
1785 save_join:
1786 p = pt;
1787 if p -> node.type ^= operator_node
1788 then call load (p, 0);
1789 else do;
1790 call compile_exp (p);
1791 p = p -> operand (1);
1792 end;
1793
1794 if target_type <= real_fix_bin_2
1795 then call aq_man$fix_scale (p, target_scale, target_type);
1796
1797 q = COPY (p);
1798 q -> reference.data_type = target_type;
1799
1800 call stack_temp$assign_block (q, min (target_type, 2));
1801 NOTE
1802
1803 call expmac (stfx1 - real_fix_bin_1 + target_type, q);
1804
1805 q -> reference.value_in.storage = "1"b;
1806
1807 return (q);
1808
1809 compile_exp$save_float_2:
1810 entry (pt) returns (ptr);
1811
1812 target_type = real_flt_bin_2;
1813 goto save_join;
1814 ^L
1815
1816
1817 COPY:
1818 proc (pt) returns (ptr);
1819
1820 dcl (pt, p) ptr;
1821
1822 p = copy_temp (pt);
1823 p -> reference.units = word_;
1824 p -> reference.aligned_ref, p -> reference.padded_ref, p -> reference.aligned_for_store_ref,
1825 p -> reference.padded_for_store_ref = "1"b;
1826 p -> reference.aggregate = "0"b;
1827 p -> reference.c_offset = 0;
1828 p -> reference.ref_count = 2;
1829 p -> reference.length, p -> reference.offset, p -> reference.qualifier = null;
1830 return (p);
1831
1832 end;
1833
1834 check_ptr:
1835 proc;
1836
1837 if ref (2) -> reference.temp_ref
1838 then if ^ref (2) -> reference.value_in.storage
1839 then if ^ref (2) -> reference.value_in.q
1840 then do;
1841 i = index (string (ref (2) -> reference.value_in.b), "1"b) - 1;
1842 if i >= 0
1843 then do;
1844 ref (2) -> reference.ref_count = ref (2) -> reference.ref_count + 1;
1845 call base_to_core (i, ref (2));
1846 end;
1847 end;
1848
1849 end;
1850
1851 compile_exp_and_set_indicators:
1852 procedure (bv_ref, bv_type);
1853
1854
1855
1856
1857
1858 dcl (
1859 bv_ref ptr,
1860 bv_type fixed bin
1861 ) parameter;
1862
1863
1864
1865 call compile_exp (bv_ref);
1866 if (machine_state.indicators ^= ind_arithmetic)
1867 then do;
1868 call expmac$zero (testfx1 - real_fix_bin_1 + bv_type);
1869 machine_state.indicators = ind_arithmetic;
1870 end;
1871
1872 end ;
1873 ^L
1874 compile_string:
1875 proc;
1876
1877 if rand (2) -> node.type = operator_node
1878 then if ref (2) -> reference.long_ref
1879 then call compile_exp (rand (2));
1880 else ref (2) = compile_exp$save (rand (2));
1881
1882 end;
1883
1884 need_areg:
1885 proc returns (bit (1) aligned);
1886
1887 if ref (1) -> reference.big_length
1888 then if ref (3) -> reference.big_length
1889 then if ref (1) -> reference.length ^= ref (3) -> reference.length
1890 | ref (1) -> reference.c_length ^= ref (3) -> reference.c_length
1891 then return ("1"b);
1892
1893 return ("0"b);
1894 end;
1895
1896 is_constant:
1897 proc (i) reducible returns (bit (1) aligned);
1898
1899 dcl i fixed bin;
1900
1901 if sym (i) -> symbol.constant
1902 then if ^ref (i) -> reference.varying_ref
1903 then if ref (i) -> reference.offset = null
1904 then if ref (i) -> reference.c_offset = 0
1905 then if ref (i) -> reference.length = null
1906 then return ("1"b);
1907
1908 return ("0"b);
1909 end;
1910 ^L
1911 is_string_constant:
1912 proc (i) reducible returns (bit (1) aligned);
1913
1914 dcl i fixed bin;
1915
1916 if sym (i) -> symbol.constant
1917 then if ^ref (i) -> reference.varying_ref
1918 then if ref (i) -> reference.offset = null
1919 then if ref (i) -> reference.length = null
1920 then return ("1"b);
1921
1922 return ("0"b);
1923 end ;
1924
1925 save_ref_3:
1926 proc;
1927
1928 ref (3) = c_a (2, 12);
1929 ref (3) -> reference.ref_count = 2;
1930 call expmac ((stfl2), ref (3));
1931
1932 end;
1933
1934
1935 math_op:
1936 proc;
1937
1938
1939
1940 dcl adjust bit (1) aligned;
1941
1942 adjust = "0"b;
1943
1944 if n = 3
1945 then if type (1) > type (3) & check_type
1946 then ref (3) = compile_exp$save_float_2 (rand (3));
1947 else if ^atom (3)
1948 then ref (3) = compile_exp$save (rand (3));
1949
1950
1951
1952 if atom (2)
1953 then call load (ref (2), 0);
1954 else call compile_exp (rand (2));
1955
1956 if n = 3
1957 then do;
1958 if ref (3) -> reference.temp_ref
1959 then do;
1960
1961
1962
1963 adjust = "1"b;
1964 ref (3) -> reference.ref_count = ref (3) -> reference.ref_count + 1;
1965 end;
1966
1967
1968
1969 call base_man$load_var (2, ref (3), 3);
1970 end;
1971
1972
1973
1974 q = c_a (32, 12);
1975 q -> reference.ref_count = 2;
1976 call base_man$load_var (2, q, 1);
1977
1978
1979
1980 call state_man$flush;
1981
1982 call expmac$zero (macro);
1983 machine_state.indicators = ind_arithmetic;
1984
1985 if adjust
1986 then call adjust_ref_count (ref (3), -1);
1987 call adjust_ref_count (q, -1);
1988
1989 end;
1990
1991 adjust_c_offset:
1992 proc (p, delta);
1993
1994 dcl p ptr,
1995 delta fixed bin;
1996
1997 save_mwif = p -> reference.modword_in_offset;
1998 save_coff = p -> reference.c_offset;
1999 save_units = p -> reference.units;
2000 if save_mwif
2001 then p -> reference.c_offset = save_coff + delta;
2002 else if save_units < word_
2003 then p -> reference.c_offset = save_coff + delta;
2004 else do;
2005 p -> reference.modword_in_offset = "1"b;
2006 if p -> reference.data_type = bit_string
2007 then do;
2008 p -> reference.units = bit_;
2009 p -> reference.c_offset = save_coff * bits_per_word + delta;
2010 end;
2011 else do;
2012 p -> reference.units = character_;
2013 p -> reference.c_offset = save_coff * chars_per_word + delta;
2014 end;
2015 end;
2016 end;
2017
2018 restore_c_offset:
2019 proc (p);
2020
2021 dcl p ptr;
2022
2023 p -> reference.c_offset = save_coff;
2024 p -> reference.modword_in_offset = save_mwif;
2025 p -> reference.units = save_units;
2026 end;
2027
2028
2029 end compile_exp;