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 convert_chars: proc(left,right,check_size,always_round);
36
37 dcl left ptr,
38 right ptr,
39 check_size bit(1) aligned,
40 always_round bit(1) aligned;
41
42 dcl cg_stat$save_exp_called bit(1) ext,
43 (cg_stat$double_temp,cg_stat$ext_proc_list,cg_stat$cur_block) ptr ext,
44 cg_stat$text_pos fixed bin ext;
45
46 dcl (lp,arg(65),arg_pt,p,p1,p2,ap,q,buff(3),s,sym(2)) ptr;
47 dcl atomic bit (1) aligned;
48 dcl (comparison,c,check,scaled,varying_target) bit(1),
49 adjust bit(36),
50 increment bit(1) aligned init("0"b),
51 macro fixed bin(15),
52 last_freed fixed bin(18),
53 (iop,i,j,k,k1,k2,arg_pos,n_args,n,type(2),dtype(2),prec(2),scale(2),length_hold,iscan,tprec,word,nchars) fixed bin;
54
55 dcl c_a entry(fixed bin,fixed bin) returns(ptr),
56 (aq_man$lock, aq_man$load_var, load_size$a_or_q) entry(ptr,fixed bin),
57 base_man$load_var_and_lock entry(fixed bin,ptr,fixed bin),
58 get_reference entry() returns(ptr),
59 expmac$two_eis entry(fixed bin(15),ptr,ptr),
60 expmac$one_eis entry(fixed bin(15),ptr),
61 generate_constant$char_string entry(char(*) aligned, fixed bin) returns (ptr),
62 expmac$many_eis entry(fixed bin(15),ptr,fixed bin),
63 create_label entry(ptr,ptr,bit(3) aligned) returns(ptr),
64 expmac$fill_usage entry(fixed bin,fixed bin),
65 need_temp entry(ptr,bit(2) aligned),
66 assign_op$length_of_varying entry(ptr,ptr),
67 stack_temp$assign_block entry(ptr,fixed bin),
68 state_man$unlock entry,
69 xr_man$load_const entry(fixed bin,fixed bin),
70 xr_man$super_lock entry(fixed bin);
71 dcl prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
72 dcl base_man$load_var entry(fixed bin,ptr,fixed bin),
73 adjust_ref_count entry(ptr,fixed bin),
74 long_op$extend_stack entry(ptr,fixed bin(15)),
75 store$save_string_temp entry(ptr),
76 copy_temp entry(ptr) returns(ptr),
77 compile_exp entry(ptr),
78 compile_exp$save entry(ptr) returns(ptr),
79 compile_exp$save_exp entry(ptr) returns(ptr),
80 create_list entry(fixed bin) returns(ptr),
81 generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
82 generate_constant entry(bit(*) aligned,fixed bin) returns(ptr);
83 dcl compile_link entry(char(*) aligned,bit(18) aligned,fixed bin) returns(fixed bin);
84 dcl store_bit_address entry(ptr,ptr,fixed bin(18)),
85 expmac entry(fixed bin(15),ptr),
86 expmac$many entry(fixed bin(15),ptr,fixed bin),
87 expmac$zero entry(fixed bin(15)),
88 reserve$declare_lib entry(fixed bin) returns(ptr),
89 state_man$flush entry,
90 state_man$flush_ref entry(ptr),
91 stack_temp$free_temp entry(ptr),
92 load entry(ptr,fixed bin);
93
94 dcl (abs,addr,bit,ceil,divide,fixed,float,index,length,max,mod,null,search,string,substr,unspec) builtin;
95
96 dcl ( make_desc_mac init(275),
97 ldfx1 init(7),
98 prepare_call init(362),
99 alloc_char_temp init(89),
100 move_chars init(98),
101 move_numeric init(438),
102 move_numeric_edit init(221),
103 dtb(2) init(222,223),
104 btd(2) init(224,225),
105 pic_mac(2) init(417,416),
106 conv_mac init(412),
107 zero_cs init(419),
108 zero_4bcs init(739),
109 blank_cs init(472),
110 pic_test init(278),
111 zero_mac(0:1) init(308,307),
112 call_ext_out init(234)) fixed bin(15) int static;
113
114 dcl ( short_work_space init(28),
115 medium_work_space init(44),
116 long_work_space init(158)) fixed bin int static options(constant);
117
118 dcl ( decimal_op init(175),
119 multi_decimal_op init(176),
120 complex_decimal_op init(182),
121 complex_binary_op init(193)) fixed bin int static;
122
123 dcl ( lte init("10000"b),
124 insm init("00001"b),
125 mfls init("00110"b),
126 enf init("00010"b),
127 mvc init("01101"b),
128 insb init("01000"b),
129 mvzb init("00100"b),
130 mvza init("00101"b),
131 mflc init("00111"b)
132 ) bit(5) aligned int static;
133
134 dcl ( integer_header init("100000011000100000000010010"b),
135 scaled_header init("100000011000100000000010001"b)
136 ) bit(27) int static;
137
138 dcl ( mvc_1 init("011010001"b),
139 blank_on_zero init("000110100"b),
140 ses_off init("000110000"b),
141 ses_on init("000111000"b),
142 ses_on_bz init("000111100"b),
143 insb_5 init("011000101"b),
144 enf_sign init("000100000"b),
145 enf_curr init("000101000"b),
146 enf_sign_bz init("000100100"b),
147 enf_curr_bz init("000101100"b),
148 insp_3 init("010110011"b),
149 insn_4 init("010100100"b),
150 insa_0 init("010010000"b),
151 insb_0 init("010000000"b),
152 insb_7 init("010000111"b),
153 insb_8 init("010001000"b)) bit(9) int static aligned options(constant);
154
155 dcl blk_on_zero char(1) aligned based(addr(blank_on_zero));
156
157 dcl ( lte_3_blank init("100000011000100000"b),
158 lte_4_blank init("100000100000100000"b)) bit(18) aligned int static;
159
160 dcl ( insn_cr init("010100000001100011010100000001110010"b),
161 insn_db init("010100000001100100010100000001100010"b)
162 ) bit(36) aligned int static;
163
164 dcl 1 edit_sequence aligned,
165 2 micro_op(68) structure unal,
166 3 op_code bit(5) unal,
167 3 data bit(4) unal;
168
169 dcl 1 edit_seq based(addr(edit_sequence)) aligned,
170 2 header bit(27) unal,
171 2 pad bit(9) unal;
172
173 dcl char_image char(nchars) based(addr(edit_sequence)) aligned;
174
175 %include pl1_descriptor_type_fcn;
176 %include cg_reference;
177 %include symbol;
178 %include token;
179 %include operator;
180 %include list;
181 %include temporary;
182 %include data_types;
183 %include nodes;
184 %include op_codes;
185 %include cgsystem;
186 %include boundary;
187 %include declare_type;
188 %include label;
189 %include mask;
190
191 convert_arithmetic: entry(left,right,check_size,always_round);
192
193 p1, arg(1) = left;
194 p2, arg(2) = right;
195 right = null;
196
197 call state_man$flush_ref(p1);
198
199
200
201 do i = 1 to 2;
202 sym(i) = arg(i) -> reference.symbol;
203 type(i) = arg(i) -> reference.data_type;
204 prec(i) = sym(i) -> symbol.c_dcl_size;
205 scale(i) = sym(i) -> symbol.scale;
206 end;
207
208 if p1 -> reference.temp_ref then p1 -> reference.value_in.storage = "1"b;
209
210
211
212 if ^ check_size
213 then do;
214 if type(1) <= real_fix_bin_2
215 then if scale(1) = 0
216 then if p1 -> reference.aligned_for_store_ref
217 then if abs(scale(2)) <= 31
218 then if type(2) = real_fix_dec | type(2) = real_flt_dec
219 then do;
220 if type(2) = real_flt_dec | scale(2) ^= 0
221 then do;
222 q = get_temp(11*type(1));
223 call expmac$two_eis((move_numeric),q,p2);
224 end;
225 else q = p2;
226 call expmac$two_eis((dtb(type(1))),p1,q);
227 return;
228 end;
229
230 if type(2) <= real_fix_bin_2
231 then if scale(2) = 0
232 then if abs(scale(1)) <= 31
233 then do;
234
235 if type(1) = real_fix_dec
236 then if scale(1) = 0
237 then do;
238 q = p1;
239 call issue_btd;
240 return;
241 end;
242 else do;
243 q = get_temp(11*type(2));
244 call issue_btd;
245 macro = move_numeric;
246 if always_round
247 then macro = macro + 1;
248 call expmac$two_eis(macro,p1,q);
249 return;
250 end;
251
252 if type(1) = real_flt_dec
253 then do;
254
255
256
257
258 q = p1;
259 length_hold = p1 -> reference.c_length;
260
261 if sym(1) -> symbol.unaligned
262 then p1 -> reference.c_length = length_hold - 2;
263 else p1 -> reference.c_length = length_hold - 1;
264
265 p1 -> reference.data_type = real_fix_dec;
266 if ^ p1 -> reference.shared
267 then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
268 call issue_btd;
269 p1 -> reference.c_length = length_hold;
270 p1 -> reference.data_type = real_flt_dec;
271
272 q = get_reference();
273 q -> reference.symbol = sym(1);
274 q -> reference.qualifier = p1;
275 q -> reference.c_offset = prec(1) + 1;
276 q -> reference.data_type = char_string;
277 q -> reference.defined_ref = "1"b;
278
279 if sym(1) -> symbol.unaligned
280 then do;
281 q -> reference.units = digit_;
282 q -> reference.c_length = 2;
283 macro = zero_4bcs;
284 end;
285 else do;
286 q -> reference.units = character_;
287 q -> reference.c_length = 1;
288 macro = zero_cs;
289 end;
290
291 call expmac$one_eis(macro,q);
292
293 return;
294 end;
295
296 if type(1) = char_string
297 then do;
298
299
300
301 prec(2) = fixed(ceil(float(prec(2),23)/3.32) + 1,17);
302 q = get_temp(prec(2));
303 call issue_btd;
304 type(2) = real_fix_dec;
305 arg(2), p2 = q;
306 sym(2) = q -> reference.symbol;
307 end;
308 end;
309
310 if type(1) = char_string
311 then if type(2) = real_fix_dec
312 then if prec(2) >= scale(2)
313 then if scale(2) >= 0
314 then do;
315 iscan = 4;
316
317 if scale(2) = 0
318 then do;
319
320
321
322 edit_seq.header = integer_header;
323 if prec(2) > 1
324 then call fill_seq((mfls),prec(2) - 1);
325 string(micro_op(iscan)) = enf;
326 string(micro_op(iscan+1)) = mvc_1;
327 nchars = iscan + 1;
328 end;
329
330 else do;
331
332
333
334
335 edit_seq.header = scaled_header;
336 i = prec(2) - scale(2) - 1;
337 if i > 0
338 then call fill_seq((mfls),i);
339 string(micro_op(iscan)) = enf;
340 if i < 0
341 then string(micro_op(iscan+1)) = insb_8;
342 else string(micro_op(iscan+1)) = mvc_1;
343 string(micro_op(iscan+2)) = insb_7;
344 iscan = iscan + 3;
345 call fill_seq((mvc),scale(2));
346 nchars = iscan - 1;
347 end;
348
349 tprec = prec(2) + 3;
350
351 varying_target = p1 -> reference.varying_ref & prec(1) >= tprec;
352 if varying_target
353 then do;
354 call assign_op$length_of_varying(p1,generate_constant$real_fix_bin_1(tprec));
355 p1 -> reference.c_length = tprec;
356 end;
357 else if prec(1) ^= tprec
358 then right, arg(1) = get_str_temp(tprec);
359 else call pad_ref(p1);
360
361 call issue_mvne;
362
363 if varying_target then p1 -> reference.c_length = prec(1);
364
365 return;
366 end;
367 end;
368
369
370
371 if arg(1) -> reference.temp_ref
372 then arg(1) -> reference.ref_count = arg(1) -> reference.ref_count + 1;
373
374 if sym(1) -> symbol.packed
375 & (sym(1) -> symbol.bit | sym(1) -> symbol.char)
376 then call pad_ref(p1);
377
378
379 do i = 2 to 1 by -1;
380
381
382
383 if ^ arg(i) -> reference.shared
384 then do;
385 n = arg(i) -> reference.ref_count;
386 check = n = 1;
387 arg(i) -> reference.ref_count = n + 1;
388 end;
389 else check = "0"b;
390
391
392
393 call base_man$load_var_and_lock(2,arg(i),i + 2);
394
395
396
397 if check then call need_temp(arg(i),"11"b);
398
399
400
401 if type(i) < char_string
402 then do;
403 word = prec(i);
404 if scale(i) ^= 0
405 then word = word + 262144*scale(i);
406 q = generate_constant$real_fix_bin_1(word);
407 call aq_man$load_var(q,i);
408 end;
409 else call load_size$a_or_q(arg(i),i);
410
411 if i = 2
412 then call aq_man$lock(null,2);
413
414
415
416 dtype (i) = pl1_descriptor_type (gen_attr (sym (i), arg (i)), sym (i) -> symbol.c_dcl_size);
417
418 word = 2 * dtype(i) + fixed(sym(i) -> symbol.packed,1);
419
420 call xr_man$load_const(word,i+5);
421 if i = 2
422 then call xr_man$super_lock(7);
423
424 end;
425
426
427
428
429
430
431
432 if max(type(1),type(2)) < char_string
433 then if sym(1) -> symbol.unaligned & sym(1) -> symbol.decimal
434 | sym(2) -> symbol.unaligned & sym(2) -> symbol.decimal
435 then n = medium_work_space;
436 else n = short_work_space;
437 else n = long_work_space;
438 q = c_a(n,12);
439 q -> reference.ref_count = 2;
440 call base_man$load_var(2,q,5);
441
442
443
444 call state_man$unlock;
445
446
447
448 i = 2;
449 if n = short_work_space
450 then if sym(1) -> symbol.real
451 then if sym(2) -> symbol.real
452 then i = 0;
453
454 macro = conv_mac + i;
455
456 if always_round
457 then macro = macro + 1;
458 else if sym(1) -> symbol.float
459 then macro = macro + 1;
460 else if sym(1) -> symbol.char
461 then if sym(2) -> symbol.float
462 then macro = macro + 1;
463
464
465
466 call state_man$flush;
467
468 call expmac$zero(macro);
469
470
471
472
473 do i = 1 to 2;
474 if ^ arg(i) -> reference.shared then call adjust_ref_count(arg(i),-1);
475 end;
476
477 call adjust_ref_count(q,-1);
478 return;
479
480
481
482
483 picture_op: entry(node_pt);
484
485 p = node_pt;
486
487 p1 = p -> operand(1);
488
489 call state_man$flush_ref(p1);
490
491 if p1 -> reference.temp_ref then p1 -> reference.value_in.storage = "1"b;
492
493 p2 = p -> operand(2);
494
495 if p2 -> node.type = operator_node
496 then p2 = p2 -> operand(1);
497
498
499
500 iop = fixed(p -> operator.op_code = unpack,1) + 1;
501 arg(1) = p1;
502 arg(2) = p2;
503 q = arg(iop) -> reference.symbol -> symbol.general;
504 if q -> reference.data_type = 0
505 then q = prepare_operand(q,1,atomic);
506
507
508
509 if ^ inline_picture()
510 then do;
511 if p1 -> reference.temp_ref
512 then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
513 arg(2) = q;
514 arg(3) = p2;
515
516 adjust = "0"b;
517 do i = 1 to 3;
518 if arg(i) -> reference.temp_ref & ^ arg(i) -> reference.aggregate
519 then do;
520 arg(i) -> reference.ref_count = arg(i) -> reference.ref_count + 1;
521 substr(adjust,i,1) = "1"b;
522 end;
523 call base_man$load_var_and_lock(2,arg(i),i + 2);
524 end;
525
526 call state_man$unlock;
527 call state_man$flush;
528
529 call expmac$zero((pic_mac(iop)));
530
531
532 if adjust
533 then do i = 1 to 3;
534 if substr(adjust,i,1)
535 then call adjust_ref_count(arg(i),-1);
536 end;
537 end;
538
539 return;
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578 gen_arithmetic_call: entry(node_pt,ref,atom);
579
580 dcl node_pt ptr,
581 ref(3) ptr,
582 atom(3) bit(1) aligned;
583
584 s = ref(2) -> reference.symbol;
585 if s -> symbol.decimal
586 then do;
587 k1 = complex_decimal_op;
588 k2 = decimal_op;
589 end;
590 else k1, k2 = complex_binary_op;
591
592 c, comparison = "0"b;
593 lp = node_pt;
594
595 call prepare_operands;
596
597 arg(2) = ref(1);
598 if arg(2) ^= null
599 then do;
600 c = ref(1) -> reference.symbol -> symbol.complex;
601 arg(3) = get_desc(arg(2));
602 end;
603 else do;
604 comparison = "1"b;
605 arg(2), arg(3) = cg_stat$double_temp;
606 end;
607
608 if comparison then j = 0; else j = fixed(substr(lp -> operator.op_code,6,4),4);
609 arg(1) = generate_constant$real_fix_bin_1(j);
610
611 arg(4) = ref(2);
612 arg(5) = get_desc(arg(4));
613
614 if lp -> operator.op_code = negate then n_args = 5;
615 else do;
616 n_args = 7;
617 arg(6) = ref(3);
618 arg(7) = get_desc(arg(6));
619 c = c | arg(6) -> reference.symbol -> symbol.complex;
620 end;
621
622 if c | s -> symbol.complex then k = k1; else k = k2;
623
624 lp = ref(1);
625 goto l2;
626
627 gen_arithmetic_builtin: entry(node_pt,ref,atom,code);
628
629 dcl code fixed bin;
630
631 lp = node_pt;
632 s = ref(1) -> reference.symbol;
633 if s -> symbol.decimal | ref(2) -> reference.symbol -> symbol.decimal
634 then do;
635 if lp -> operator.number > 3 then k = multi_decimal_op;
636 else if ref(2) -> reference.symbol -> symbol.complex
637 | ref(1) -> reference.symbol -> symbol.complex
638 then k = complex_decimal_op;
639 else k = decimal_op;
640 end;
641 else k = complex_binary_op;
642
643 call prepare_operands;
644
645 arg(1) = generate_constant$real_fix_bin_1(code);
646
647 n_args = 2 * lp -> operator.number + 1;
648
649 do i = 1 to lp -> operator.number-1;
650 j = 2 * i;
651 arg(j) = ref(i);
652 arg(j+1) = get_desc(arg(j));
653 end;
654
655 j = 2 * i;
656 if lp -> operator.op_code = round_fun then arg(j), arg(j+1) = ref(i);
657 else do;
658 arg(j) = ref(i);
659 arg(j+1) = get_desc(arg(j));
660 end;
661
662 lp = ref(1);
663 comparison = "0"b;
664
665 l2: if lp ^= null
666 then if lp -> reference.temp_ref
667 then lp -> reference.value_in.storage = "1"b;
668
669 arg_pt = c_a(2*(n_args+1),12);
670
671 if increment then arg_pt -> reference.ref_count = arg_pt -> reference.ref_count + 1;
672
673 last_freed = arg_pt -> reference.qualifier -> temporary.last_freed;
674
675 arg_pos = arg_pt -> reference.qualifier -> temporary.location;
676 ap = c_a(0,4);
677
678 if arg_pos + 2*n_args + 1 >= 16384
679 then do;
680 call xr_man$load_const(arg_pos,1);
681 ap -> reference.address.tag = "001001"b;
682 arg_pos = 0;
683 string(arg_pt -> reference.address) = string(ap -> reference.address);
684 arg_pt -> reference.perm_address = "1"b;
685 end;
686
687
688
689
690
691
692 adjust = "0"b;
693 do i = 1 to n_args;
694 p = arg(i);
695 if p = null then goto l3;
696
697 if p -> reference.temp_ref
698 then do;
699 p -> reference.ref_count = p -> reference.ref_count + 1;
700 substr(adjust,i,1) = "1"b;
701 end;
702
703 ap -> address.offset = bit(fixed(arg_pos + 2*i,15),15);
704 call store_bit_address(ap,p,last_freed);
705
706 do j = i + 1 to n_args;
707 if p = arg(j)
708 then do;
709 ap -> address.offset = bit(fixed(arg_pos + 2*j,15),15);
710 call store_bit_address(ap,p,last_freed);
711 arg(j) = null;
712 end;
713 end;
714
715 l3: end;
716
717 buff(1) = arg_pt;
718 buff(2) = c_a(n_args*2048,2);
719 buff(3) = reserve$declare_lib(k);
720
721 ap = buff(3) -> reference.symbol;
722 if ^ ap -> symbol.allocated
723 then do;
724 ap -> symbol.location = compile_link(ap -> symbol.token -> token.string,"0"b,0);
725 ap -> symbol.allocated = "1"b;
726
727 q = create_list(2);
728 q -> element(2) = ap;
729 q -> element(1) = cg_stat$ext_proc_list;
730 cg_stat$ext_proc_list = q;
731 end;
732
733 call expmac$many((prepare_call),addr(buff),2);
734 call base_man$load_var(2,buff(3),1);
735 call state_man$flush;
736 call expmac$zero((call_ext_out));
737
738
739 if comparison then call expmac((ldfx1),cg_stat$double_temp);
740
741 if adjust = "0"b then return;
742
743 do i = 1 to n_args;
744 if substr(adjust,i,1)
745 then do;
746 p = arg(i);
747 call adjust_ref_count(p,-1);
748 end;
749 end;
750
751 return;
752
753
754
755 inline_picture: proc() returns(bit(1) aligned);
756
757
758
759
760 dcl (lab,pp) ptr;
761 dcl (picture_pos,type,prec,scale,scalefactor,picture_length,nrands,source_length) fixed bin;
762 dcl (pc,sc,drift,zero_sup_char) char(1) aligned;
763 dcl table_entries char(8) init(" *+-$,.0") int static;
764 dcl (current_micro_op,micro_op_code) bit(5) aligned;
765 dcl micro_inst bit(9) aligned;
766
767 dcl zero_suppression bit(1) aligned;
768 dcl have_drift bit(1) aligned;
769 dcl have_suppression bit(1) aligned;
770 dcl insertion_on_zero bit(1) aligned;
771
772 dcl test_zero bit(1) aligned;
773
774 %include picture_image;
775 %include picture_types;
776
777 if iop = 2
778 then return("0"b);
779 else do;
780
781
782
783 call open_picture;
784
785 if type = char_picture
786 then if verify(substr(pp -> picture_image.chars,1,picture_length),"x") = 0
787 then do;
788 call pad_ref(p1);
789 call expmac$two_eis((move_chars),p1,p2);
790 return("1"b);
791 end;
792 else return("0"b);
793
794 if type > real_fixed_picture then return("0"b);
795
796 if abs(scale) > 31 then return("0"b);
797
798
799
800
801 have_drift, have_suppression, insertion_on_zero, current_micro_op = "0"b;
802 zero_suppression = "1"b;
803 drift, zero_sup_char = " ";
804 iscan = 1;
805
806
807 do picture_pos = 1 to picture_length;
808 pc = substr(pp -> picture_image.chars,picture_pos,1);
809 go to case(index("9y*z$s+-cd/.,bv",pc));
810
811
812
813 case(1): call force_significance;
814 call put((mvc));
815 go to step;
816
817
818
819 case(2): if have_drift
820 then if zero_suppression
821 then return("0"b);
822
823 if picture_pos > 1
824 then call issue((ses_off));
825 call put((mvzb));
826 if substr(pp -> picture_image.chars,picture_pos + 1,1) ^= "y"
827 then call issue((ses_on));
828 zero_suppression = "0"b;
829 go to step;
830
831
832
833 case(3): zero_sup_char = "*";
834 insertion_on_zero = "1"b;
835 call start_suppression;
836 call put((mvza));
837 go to step;
838
839
840
841 case(4): zero_sup_char = " ";
842 call start_suppression;
843 call put((mvzb));
844 go to step;
845
846
847
848 case(5): if pp -> picture_image.drift_character ^= "$"
849 then call non_drifting;
850
851 else do;
852 if ^ have_drift
853 then do;
854 drift = "$";
855 insertion_on_zero,
856 have_drift = "1"b;
857 call start_suppression;
858 end;
859 else call put((mflc));
860 end;
861
862 go to step;
863
864
865
866 case(6): if pp -> picture_image.drift_character ^= "s"
867 then call non_drifting;
868 else call drifting_sign;
869
870
871
872 case(7): if pp -> picture_image.drift_character ^= "+"
873 then do;
874 call issue((insp_3));
875 insertion_on_zero = "1"b;
876 go to step;
877 end;
878
879 call drifting_sign;
880
881
882
883 case(8): if pp -> picture_image.drift_character ^= "-"
884 then do;
885 call issue((insn_4));
886 go to step;
887 end;
888
889 call drifting_sign;
890
891
892
893 case(9): call issue_4((insn_cr));
894 picture_pos = picture_pos + 1;
895 go to step;
896
897
898
899 case(10): call issue_4((insn_db));
900 picture_pos = picture_pos + 1;
901 go to step;
902
903
904
905 case(11):
906 case(12):
907 case(13):
908 insertion_on_zero = "1"b;
909 call insert_pun;
910
911
912
913 case(14): pc = " ";
914 call insert_pun;
915
916
917
918 case(15): if index(substr(pp -> picture_image.chars,picture_pos+1),"9") = 0
919 then call force_significance_bz;
920 else if have_drift & index(substr(pp -> picture_image.chars,picture_pos+1),"y") ^= 0
921 then return("0"b);
922 else call force_significance;
923
924 step: if iscan > 64 then return("0"b);
925 end;
926
927 test_zero = zero_suppression & insertion_on_zero;
928 if test_zero & have_drift
929 then call force_significance_bz;
930
931 call pad_ref(p1);
932
933 call force;
934 nchars = iscan - 1;
935
936 if test_zero & ^ have_drift
937 then do;
938 nchars = nchars + 1;
939 char_image = blk_on_zero || substr(char_image,1,nchars-1);
940 end;
941
942 call issue_mvne;
943
944 end;
945
946 return("1"b);
947
948
949 start_suppression: proc;
950
951 if ^ have_suppression
952 then do;
953 if ^ zero_suppression
954 then do;
955 call issue((ses_off));
956 zero_suppression = "1"b;
957 end;
958
959 have_suppression = "1"b;
960 end;
961
962 end;
963
964
965 force_significance: proc;
966
967 if zero_suppression
968 then do;
969 if have_drift
970 then do;
971 if drift = "$"
972 then micro_inst = enf_curr;
973 else micro_inst = enf_sign;
974 call issue(micro_inst);
975 have_drift = "0"b;
976 end;
977 else call issue(ses_on);
978
979 zero_suppression = "0"b;
980 end;
981
982 end;
983
984
985 force_significance_bz: proc;
986
987
988
989 if zero_suppression
990 then do;
991 if have_drift
992 then do;
993 if drift = "$"
994 then micro_inst = enf_curr_bz;
995 else micro_inst = enf_sign_bz;
996 call issue(micro_inst);
997 end;
998 else call issue(ses_on_bz);
999
1000 zero_suppression = "0"b;
1001 end;
1002
1003 end;
1004
1005
1006 non_drifting: proc;
1007
1008 if have_drift & zero_suppression
1009 then do;
1010 call force_significance;
1011 zero_suppression = "1"b;
1012 end;
1013
1014 if picture_pos > 1
1015 then call issue((ses_off));
1016
1017 if have_suppression & zero_suppression
1018 then if pc = "$"
1019 then micro_inst = enf_curr_bz;
1020 else micro_inst = enf_sign_bz;
1021 else if pc = "$"
1022 then micro_inst = enf_curr;
1023 else micro_inst = enf_sign;
1024
1025 call issue(micro_inst);
1026
1027 zero_suppression = "0"b;
1028
1029 insertion_on_zero = "1"b;
1030 go to step;
1031
1032 end;
1033
1034
1035 drifting_sign: proc;
1036
1037 dcl table_change bit(18) aligned;
1038
1039 if ^ have_drift
1040 then do;
1041 call start_suppression;
1042 insertion_on_zero,
1043 have_drift = "1"b;
1044 drift = pc;
1045 if drift ^= "s"
1046 then do;
1047 if drift = "-"
1048 then table_change = lte_3_blank;
1049 else table_change = lte_4_blank;
1050 call issue_2(table_change);
1051 end;
1052 end;
1053
1054 else call put((mfls));
1055 go to step;
1056
1057 end;
1058
1059
1060
1061 insert_pun: proc;
1062
1063 if zero_suppression
1064 then if ^ have_suppression
1065 then do;
1066 call issue((ses_on));
1067 zero_suppression = "0"b;
1068 end;
1069
1070 if zero_sup_char = "*"
1071 then micro_inst = insa_0;
1072 else micro_inst = insb_0;
1073
1074 if pc = "/"
1075 then do;
1076 call issue(micro_inst);
1077 call issue(unspec(pc));
1078 end;
1079
1080 else do;
1081 substr(micro_inst,6,4) = bit(fixed(index(table_entries,pc),4),4);
1082 call issue(micro_inst);
1083 end;
1084
1085 go to step;
1086
1087 end;
1088
1089
1090
1091 put: proc(micro_op_code);
1092
1093 dcl micro_op_code bit(5) aligned;
1094
1095 if micro_op_code ^= current_micro_op
1096 then call force;
1097
1098 current_micro_op = micro_op_code;
1099 nrands = nrands + 1;
1100
1101 end;
1102
1103
1104
1105 force: proc;
1106
1107 if current_micro_op
1108 then call fill_seq((current_micro_op),nrands);
1109
1110 current_micro_op = "0"b;
1111 nrands = 0;
1112
1113 end;
1114
1115
1116
1117 issue: proc(micro_inst);
1118
1119 dcl micro_inst bit(9) aligned;
1120
1121 call force;
1122
1123 string(micro_op(iscan)) = micro_inst;
1124 iscan = iscan + 1;
1125
1126 end;
1127
1128
1129
1130 issue_4: proc(bit36);
1131
1132 dcl bit36 bit(36) aligned;
1133 dcl (i,n) fixed bin;
1134 dcl p ptr;
1135
1136 n = 4;
1137 p = addr(bit36);
1138 go to join;
1139
1140 issue_2: entry(bit18);
1141
1142 dcl bit18 bit(18) aligned;
1143
1144 dcl 1 array_st based aligned,
1145 2 micro_array(4) bit(9) unal;
1146
1147 n = 2;
1148 p = addr(bit18);
1149
1150 join: call force;
1151
1152 do i = 1 to n;
1153 string(micro_op(iscan)) = p -> micro_array(i);
1154 iscan = iscan + 1;
1155 end;
1156
1157 end;
1158
1159
1160
1161 open_picture: proc;
1162
1163 pp = q -> reference.symbol -> symbol.initial;
1164
1165 type = pp -> picture_image.type;
1166 prec = pp -> picture_image.prec;
1167 scale = pp -> picture_image.scale;
1168 picture_length = pp -> picture_image.piclength;
1169 source_length = pp -> picture_image.varlength;
1170 scalefactor = pp -> picture_image.scalefactor;
1171
1172 end;
1173
1174
1175 end;
1176
1177
1178
1179 prepare_operands: proc;
1180
1181 dcl i fixed bin;
1182
1183 do i = 2 to lp -> operator.number;
1184 if ^ atom(i) then ref(i) = compile_exp$save_exp((lp -> operand(i)));
1185 end;
1186
1187 if ref(1) = null then return;
1188
1189 if ^ ref(1) -> reference.allocate
1190 then do;
1191 lp -> operand(1), ref(1) = copy_temp(ref(1));
1192 ref(1) -> reference.ref_count = 2;
1193 end;
1194 else if ^ cg_stat$save_exp_called
1195 then if ref(1) -> reference.temp_ref
1196 then ref(1) -> reference.ref_count = ref(1) -> reference.ref_count + 1;
1197
1198 end;
1199
1200 get_temp: proc(prec) returns(ptr);
1201
1202 dcl (length,type,prec) fixed bin;
1203 dcl p ptr;
1204 dcl long bit(1) aligned;
1205
1206
1207
1208 length = prec + 1;
1209 type = real_fix_dec;
1210 long = "0"b;
1211 go to join;
1212
1213
1214
1215 get_str_temp: entry(prec) returns(ptr);
1216
1217 length = prec;
1218 long = length > max_short_size(char_string);
1219 type = char_string;
1220
1221 join: p = get_reference();
1222 p -> reference.data_type = type;
1223 p -> reference.c_length = length;
1224 p -> reference.long_ref = long;
1225 p -> reference.temp_ref, p -> reference.allocate, p -> reference.value_in.storage = "1"b;
1226 call stack_temp$assign_block(p,divide(length + chars_per_word - 1,chars_per_word,17,0));
1227
1228 return(p);
1229 end;
1230
1231
1232 issue_btd: proc;
1233
1234 if ^ p2 -> reference.aligned_ref
1235 then p2 = compile_exp$save(p2);
1236
1237 call expmac$two_eis((btd(type(2))),q,p2);
1238
1239 end;
1240
1241
1242 issue_mvne: proc;
1243
1244 arg(3) = generate_constant$char_string(char_image,nchars);
1245
1246 call expmac$many_eis((move_numeric_edit),addr(arg),3);
1247
1248 end;
1249
1250
1251 pad_ref: proc(pt);
1252
1253
1254
1255
1256
1257 dcl (p1,pt) ptr;
1258
1259 dcl size fixed bin(24);
1260
1261 p1 = pt;
1262
1263 if p1 -> reference.data_type = bit_string
1264 then size = p1 -> reference.c_length;
1265 else size = p1 -> reference.c_length * bits_per_char;
1266
1267 if ^ p1 -> reference.long_ref
1268 then if ^ p1 -> reference.varying_ref
1269 then if p1 -> reference.aligned_for_store_ref
1270 then if mod(size,bits_per_word) ^= 0
1271 then do;
1272 if ^ p1 -> reference.shared
1273 then p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
1274 call expmac((zero_mac(fixed(size > bits_per_word,1))),p1);
1275 end;
1276 end ;
1277
1278
1279
1280 fill_seq: proc(pop,pn);
1281
1282 dcl (mop,pop) bit(5) aligned;
1283 dcl (n,pn) fixed bin;
1284
1285 dcl (i,ninst) fixed bin;
1286 dcl j fixed bin(4);
1287
1288 n = pn;
1289 mop = pop;
1290
1291 ninst = divide(n + 15,16,17,0);
1292
1293 do i = 1 to ninst;
1294 string(micro_op(iscan)) = mop;
1295 if i = ninst
1296 then do;
1297 j = mod(n,16);
1298 if j ^= 0
1299 then micro_op(iscan).data = bit(j,4);
1300 end;
1301 iscan = iscan + 1;
1302 end;
1303
1304 end;
1305
1306
1307 get_desc: proc(ref) returns(ptr);
1308
1309 dcl ref ptr;
1310
1311 dcl (p,q,r,s,arg(2)) ptr,
1312 (type,scale,desc_type) fixed bin,
1313 desc bit(36) int static aligned init("1"b);
1314
1315 p = ref;
1316 s = p -> reference.symbol;
1317
1318 substr(desc,8,1) = s -> symbol.packed;
1319
1320 type = p -> reference.data_type;
1321
1322 desc_type = pl1_descriptor_type (gen_attr (s, p), s -> symbol.c_dcl_size);
1323
1324 substr(desc,2,6) = bit(fixed(desc_type,6),6);
1325
1326 if type < char_string
1327 then do;
1328 substr(desc,25,12) = bit(fixed(s -> symbol.c_dcl_size,12),12);
1329
1330 scale = s -> symbol.scale;
1331
1332 if scale < 0
1333 then scale = scale + 1000000000000b;
1334
1335 substr(desc,13,12) = bit(fixed(scale,12),12);
1336
1337 l1: return(generate_constant(desc,1));
1338 end;
1339
1340 q = p -> reference.length;
1341 if q = null
1342 then do;
1343 substr(desc,13,24) = bit(fixed(p -> reference.c_length,24),24);
1344 goto l1;
1345 end;
1346
1347 substr(desc,13,24) = "0"b;
1348
1349 if q -> node.type = operator_node
1350 then r = q -> operand(1);
1351 else r = q;
1352 if ^ r -> reference.shared
1353 then r -> reference.ref_count = r -> reference.ref_count + 1;
1354
1355 call compile_exp(q);
1356
1357 arg(1) = c_a(1,12);
1358 arg(1) -> reference.ref_count = 2;
1359
1360 arg(2) = generate_constant(desc,1);
1361 call expmac$many((make_desc_mac),addr(arg),2);
1362
1363 return(arg(1));
1364 end;
1365
1366
1367
1368 gen_attr:
1369 procedure (symptr, refptr) returns (bit (36) aligned);
1370
1371
1372
1373 dcl symptr ptr;
1374 dcl refptr ptr;
1375
1376
1377
1378 if ^ refptr -> reference.varying_ref & symptr -> symbol.varying
1379 then return (substr (string (symptr -> symbol.attributes), 1, 36) & ^(varying_mask));
1380
1381 return (substr (string (symptr -> symbol.attributes), 1, 36));
1382
1383 end ;
1384
1385 end;