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 builtin:
32 proc (cur_block, statement_ptr, input_tree, subscripts, builtin_symbol, context) returns (ptr);
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 dcl (cur_block, builtin_symbol, statement_ptr, subscripts, input_tree, tree) ptr;
61
62 dcl (
63 arg (128),
64 ref (128),
65 arg_symbol (128),
66 length,
67 offset,
68 p,
69 q,
70 r,
71 rlength,
72 s,
73 t,
74 off,
75 save_arg_one
76 ) ptr,
77 cur_length (2) ptr,
78 (agg_ref, dcl_length) ptr init (null),
79 (units, cunits) fixed bin (3),
80 error_number fixed bin (15),
81 constant fixed bin,
82 (arg_number, builtin_number, code, i, indicator, jump_index, m, reserved_number, rprecision, rscale,
83 temp_size) fixed bin (31),
84 (c_length, c_offset, coff, integer, number, substr_index, p1, p2, q1, q2, rcount) fixed bin (31),
85 integer_24 fixed bin (24),
86 based_type bit (36) based,
87 (desc_reqd, decimal_result, arith_size_ck, string_size_ck) bit (1) aligned init ("0"b),
88 pseudo_variable bit (1) aligned init ("0"b),
89 (full_attribute_set, not_flag) bit (1) aligned,
90 bit4 bit (4) aligned,
91 modified bit (1) aligned,
92 opcode bit (9) aligned,
93 constant_string_length fixed bin (21),
94 constant_char_string char (constant_string_length) based,
95 constant_bit_string bit (constant_string_length) based,
96 builtin_string char (8) aligned,
97 collating_sequence char (128) aligned internal static init ("^@^A^B^C^D^E^F^G^H
98 ^K^L^M^N^O^P^Q^R^S^T^U^V^W^X^Y^Z^[^\^]^^^_ !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~^?");
99
100 dcl pl1_data$long_collating_sequence char (512) aligned ext static;
101
102 dcl pl1_stat_$use_old_area bit (1) aligned ext static,
103 pl1_stat_$check_ansi bit (1) aligned ext static,
104 pl1_stat_$eis_mode bit (1) aligned ext static,
105 pl1_stat_$root ptr ext static,
106 pl1_stat_$cur_statement ptr ext static;
107
108 dcl (addr, bit, divide, fixed, max, min, null, reverse, string, substr, unspec) builtin;
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254 ^L
255 dcl 1 rtype like type;
256
257 dcl 1 arg_type (128) like type;
258
259 dcl defined_arg_type (128) bit (36) defined (arg_type);
260
261 dcl 1 as_if_type (128) like type;
262
263 dcl defined_as_if_type (128) bit (36) defined (as_if_type);
264
265 dcl targ_type bit (36) aligned;
266 dcl targ_prec fixed bin (31);
267
268 dcl save_context bit (36),
269 1 def_save_context defined (save_context),
270 2 aggregate bit (1),
271 2 arg_list bit (1),
272 2 left_side bit (1),
273 2 return bit (1),
274 2 evaluate_offset bit (1),
275 2 top bit (1),
276 2 RHS_aggregate bit (1),
277 2 return_from_empty bit (1),
278 2 ignore_based bit (1),
279 2 ext_param bit (1),
280 2 cross_section bit (1),
281 2 string_unspec bit (1);
282 ^L
283 tree = input_tree;
284
285 if def_context.top then
286 if statement_ptr -> statement.statement_type = call_statement then
287 call semantic_translator$abort (224, builtin_symbol);
288
289 if subscripts = null then
290 arg_number = 0;
291 else
292 arg_number = subscripts -> list.number;
293
294 builtin_number = builtin_symbol -> symbol.c_dcl_size;
295 opcode = pl1_data$builtin_name.description (builtin_number).opcode;
296 jump_index = pl1_data$builtin_name.description (builtin_number).jump_index;
297 reserved_number = pl1_data$builtin_name.description (builtin_number).reserve_list_number;
298
299 if pl1_stat_$check_ansi then
300 if pl1_data$builtin_name.description (builtin_number).nonstandard then
301 call semantic_translator$error (202, builtin_symbol);
302
303
304 indicator = pl1_data$builtin_name.description (builtin_number).check_indicator;
305
306 if indicator = 1 then
307 if arg_number ^= pl1_data$builtin_name.description (builtin_number).number1 then
308 call semantic_translator$abort (121, builtin_symbol);
309 else
310 ;
311 else if indicator = 2 then
312 if arg_number < pl1_data$builtin_name.description (builtin_number).number1 then
313 call semantic_translator$abort (122, builtin_symbol);
314 else
315 ;
316 else if indicator = 3 then
317 if arg_number < pl1_data$builtin_name.description (builtin_number).number1
318 | arg_number > pl1_data$builtin_name.description (builtin_number).number2 then
319 call semantic_translator$abort (123, builtin_symbol);
320
321 if def_context.left_side then do;
322 builtin_string = builtin_symbol -> symbol.token -> token.string;
323
324 if builtin_string ^= "real" & builtin_string ^= "imag" & builtin_string ^= "string"
325 & builtin_string ^= "substr" & builtin_string ^= "unspec" & builtin_string ^= "onchar"
326 & builtin_string ^= "onsource" & builtin_string ^= "pageno" then
327 call semantic_translator$abort (244, builtin_symbol);
328 else
329 pseudo_variable = "1"b;
330 end;
331 ^L
332 save_context = "0"b;
333
334 do i = 1 to arg_number;
335
336 this_context = "0"b;
337 if i = 1 & (jump_index = 10 | jump_index = 12 | jump_index = 33) then do;
338 def_this_context.evaluate_offset = "1"b;
339
340 if jump_index ^= 33 then
341 def_this_context.string_unspec = "1"b;
342 end;
343
344 if (jump_index = 46 & i = 1) | jump_index = 47 then
345 def_this_context.ignore_based = "1"b;
346
347 if i = 1
348 & (def_context.f_offset_to_be_added | jump_index = 11
349 | (jump_index >= 55 & jump_index <= 58)) then
350 def_this_context.f_offset_to_be_added = "1"b;
351
352 arg (i) =
353 expression_semantics (cur_block, statement_ptr, (subscripts -> element (arg_number + 1 - i)),
354 this_context);
355
356 if def_this_context.aggregate then do;
357 if pl1_data$builtin_name.description (builtin_number).descriptor (i).check_code = 5 then
358 if jump_index ^= 11 then
359 goto err124;
360
361 if pl1_data$builtin_name.description (builtin_number).aggregate_result then
362 if ^def_context.by_name_assignment then do;
363 subscripts -> element (arg_number + 1 - i), arg (i) =
364 expand_primitive (cur_block, statement_ptr, arg (i), this_context);
365 end;
366 else
367 go to err381;
368 end;
369
370 save_context = save_context | this_context;
371
372 ref (i) = arg (i);
373
374 do while (ref (i) -> node.type = operator_node);
375 ref (i) = ref (i) -> operand (1);
376 end;
377
378 if ref (i) -> node.type = token_node then do;
379 ref (i), arg_symbol (i) = null;
380 if arg (i) -> token.type = dec_integer then
381 defined_arg_type (i) = dec_integer_type;
382 else
383 defined_arg_type (i) = decoded_type (fixed (arg (i) -> token.type, 15));
384 end;
385 else if ref (i) -> node.type = label_node then do;
386 arg_symbol (i) = ref (i);
387 ref (i) = null;
388 defined_arg_type (i) = "0"b;
389 end;
390 else if ref (i) -> node.type = reference_node then do;
391 arg_symbol (i) = ref (i) -> reference.symbol;
392 defined_arg_type (i) =
393 substr (string (arg_symbol (i) -> symbol.attributes), 1, 36) & ^dimensioned_mask
394 & ^initialed_mask;
395 end;
396 end;
397
398 this_context = "0"b;
399 ^L
400
401
402 if def_save_context.aggregate then
403 if pl1_data$builtin_name.description (builtin_number).aggregate_result then do;
404 if jump_index = 24 then
405 call semantic_translator$abort (478, builtin_symbol);
406
407 if def_context.left_side then
408 call propagate_bit (arg_symbol (1), set_bit);
409
410 def_context.aggregate = "1"b;
411 tree = expand_arguments ();
412
413 goto exit;
414 end;
415 ^L
416 do i = 1 to min (arg_number, pl1_data$builtin_name.description (builtin_number).number_of_descriptions);
417
418 code = pl1_data$builtin_name.description (builtin_number).descriptor (i).check_code;
419 string (type) = pl1_data$builtin_name.description (builtin_number).descriptor (i).type;
420
421 if code = 0 then
422 goto next_descriptor;
423
424 if code = 1 then
425 if string (type) & defined_arg_type (i) then
426 goto conv_arg;
427 else
428 goto err124;
429
430 if code = 2 then
431 goto conv_arg;
432
433 if code = 3 | code = 11 then do;
434 if code = 11 then
435 if arg_type (i).complex then
436 goto err124;
437
438 if arg_type (i).picture | arg_type (i).decimal | arg_type (i).char then do;
439 if arg_type (i).decimal then
440 string (type) = defined_arg_type (i) & ^fixed_mask | float_mask;
441 else if arg_type (i).complex then
442 string (type) = float_decimal_complex_mask;
443 else
444 string (type) = float_decimal_real_mask;
445 t = convert$from_builtin ((arg (i)), string (type));
446
447 if t -> node.type = operator_node then
448 t = t -> operand (1) -> reference.symbol;
449 else
450 t = t -> reference.symbol;
451 targ_type = string (type);
452 if decimal_result then
453 targ_prec = max (targ_prec, t -> symbol.c_dcl_size);
454 else if i = 1 then do;
455 decimal_result = "1"b;
456 targ_prec = t -> symbol.c_dcl_size;
457 end;
458 end;
459 string (type) = float_mask | binary_mask;
460 goto conv_arg;
461 end;
462
463 if code = 4 then do;
464 if arg_type (i).bit then
465 string (type) = fixed_binary_real_mask;
466 else if arg_type (i).char then
467 string (type) = fixed_decimal_real_mask;
468 else if arg_type (i).picture then
469 if arg_symbol (i) -> symbol.complex then
470 if arg_symbol (i) -> symbol.pix.pic_float then
471 string (type) = float_decimal_complex_mask;
472 else
473 string (type) = fixed_decimal_complex_mask;
474 else if arg_symbol (i) -> symbol.pix.pic_float then
475 string (type) = float_decimal_real_mask;
476 else
477 string (type) = fixed_decimal_real_mask;
478 else if defined_arg_type (i) & arithmetic_mask then
479 string (type) = defined_arg_type (i);
480 else
481 goto err124;
482
483 goto conv_arg;
484 end;
485
486 if code = 5 then do;
487 string (type) = fixed_binary_real_mask;
488
489 if arg_type (i).fixed | arg_type (i).float then do;
490 ref (i), arg (i) = convert$to_integer (arg (i), integer_type);
491
492 if ref (i) -> node.type = operator_node then do;
493 ref (i) -> operator.processed = "1"b;
494 ref (i) = ref (i) -> operand (1);
495 end;
496
497 arg_symbol (i) = ref (i) -> reference.symbol;
498 defined_arg_type (i) = integer_type;
499
500 goto next_descriptor;
501 end;
502
503 goto conv_arg;
504 end;
505
506 if code = 6 then do;
507 if arg (i) -> node.type = reference_node then
508 if symbol_is_constant (arg_symbol (i)) then
509 if ^arg_type (i).fixed | ^arg_type (i).binary | ^arg_type (i).real then
510 arg (i) = subscripts -> element (arg_number + 1 - i);
511 else
512 goto next_descriptor;
513 else
514 goto err124;
515
516 if arg (i) -> node.type ^= token_node then
517 goto err124;
518
519
520 if arg (i) -> token.type ^= dec_integer then
521 goto err124;
522
523 string (type) = fixed_binary_real_mask;
524
525 goto conv_arg;
526 end;
527
528 if code = 7 then do;
529 if arg_type (i).bit | arg_type (i).char then
530 string (type) = defined_arg_type (i);
531 else if arg_type (i).binary | arg_type (i).picture | arg_type (i).decimal then
532 string (type) = char_mask;
533 else
534 goto err124;
535
536 goto conv_arg;
537 end;
538
539 if code = 8 then do;
540 if arg_type (i).bit then
541 string (type) = bit_mask;
542 else if arg_type (i).fixed | arg_type (i).float then do;
543 ref (i), arg (i) = convert$to_integer (arg (i), integer_type);
544
545 if ref (i) -> node.type = operator_node then do;
546 ref (i) -> operator.processed = "1"b;
547 ref (i) = ref (i) -> operand (1);
548 end;
549
550 arg_symbol (i) = ref (i) -> reference.symbol;
551 defined_arg_type (i) = integer_type;
552
553 go to next_descriptor;
554 end;
555 else
556 string (type) = fixed_binary_real_mask;
557
558 go to conv_arg;
559
560 end;
561
562 if code = 9 then
563 if ref (i) = null then
564 goto err124;
565 else
566 goto next_descriptor;
567
568 if code = 10 then do;
569 if (defined_arg_type (i) & computational_mask) = "0"b then
570 goto err124;
571
572 goto next_descriptor;
573 end;
574
575 if code = 12 then do;
576 if ^arg_type (i).label & ^arg_type (i).entry & ^arg_type (i).format
577 & arg (i) -> node.type ^= label_node then
578 go to err124;
579 go to next_descriptor;
580 end;
581
582 conv_arg:
583 call convert_arg;
584
585 next_descriptor:
586 end;
587 ^L
588 string (rtype) = defined_arg_type (1) & ^unaligned_mask | aligned_mask;
589
590 rprecision, rscale = 0;
591 rlength = null;
592
593 do i = 1 to arg_number;
594 if ref (i) ^= null then
595 if ref (i) -> reference.varying_ref then do;
596 if i = 1 then
597 if jump_index = 9 | jump_index = 24 | jump_index = 27
598 | jump_index = 49 then do;
599 rlength = create_length_fun (arg (1));
600 string (rtype) = string (rtype) & ^varying_mask;
601 end;
602 end;
603 end;
604
605 if arg_number ^= 0 & arg_symbol (1) ^= null then
606 if arg_symbol (1) -> node.type = symbol_node then do;
607 rprecision = arg_symbol (1) -> symbol.c_dcl_size;
608 if arg_type (1).bit | arg_type (1).char then
609 if rlength = null then
610 rprecision = ref (1) -> reference.c_length;
611 else
612 rprecision = 0;
613
614 rscale = fixed (arg_symbol (1) -> symbol.scale, 31, 0);
615
616 if ref (1) ^= null & rlength = null then
617 if jump_index = 9 | jump_index = 24 | jump_index = 27
618 | jump_index = 49 then do;
619 rlength = share_expression ((ref (1) -> reference.length));
620 string (rtype) = string (rtype) & ^varying_mask;
621 end;
622
623 end;
624
625 goto action (jump_index);
626 ^L
627 action (0):
628 call semantic_translator$abort (131, builtin_symbol);
629 goto ret;
630
631 action (1):
632 tree = declare_constant$char (collating_sequence);
633
634 goto ret;
635
636 action (2):
637 string (rtype) = float_mask;
638
639 if arg_number = 2 then
640 rprecision = constant_value (arg_symbol (2));
641 else do;
642 rprecision = 0;
643 if pl1_stat_$check_ansi then
644 call semantic_translator$error (172, builtin_symbol);
645 end;
646
647 goto convert_to_arith;
648
649 action (3):
650
651 if arg (1) -> node.type = token_node then
652 if arg (1) -> token.type = dec_integer then
653 call semantic_translator$error (484, null);
654
655 string (rtype) = fixed_mask;
656
657 if arg_number = 3 then
658 rscale = constant_value (arg_symbol (3));
659 else
660 rscale = 0;
661
662 if arg_number >= 2 then
663 rprecision = constant_value (arg_symbol (2));
664 else do;
665 rprecision = 0;
666 if pl1_stat_$check_ansi then
667 call semantic_translator$error (172, builtin_symbol);
668 end;
669
670 goto convert_to_arith;
671
672 action (4):
673
674 if arg_type (1).char then
675 string (rtype) = fixed_decimal_real_mask | aligned_mask;
676 else if arg_type (1).bit then
677 string (rtype) = fixed_binary_real_mask | aligned_mask;
678
679 if arg_type (1).float & arg_number = 3 then
680 call semantic_translator$abort (167, builtin_symbol);
681
682 if arg_number = 3 then
683 rscale = constant_value (arg_symbol (3));
684
685 rprecision = constant_value (arg_symbol (2));
686
687 full_attribute_set = "1"b;
688
689 goto check_prec_scale;
690
691 action (5):
692 arg (2) = arg (1);
693 ref (2) = ref (1);
694 arg_symbol (2) = arg_symbol (1);
695
696 arg (1), ref (1) = declare_constant ("001111111"b, char_type, 1, 0);
697 arg_symbol (1) = arg (1) -> reference.symbol;
698
699 arg_number = 2;
700 string (rtype) = char_type;
701
702 goto repeat;
703
704 action (6):
705 if arg_type (1).bit & arg_type (2).bit then
706 string (type) = bit_mask;
707 else
708 string (type) = char_mask;
709
710 do i = 1 to 2;
711 call convert_arg;
712 end;
713
714 if type.char then
715 if check_reverse (arg (1)) then do;
716 opcode = index_rev_fun;
717 arg (1) = arg (1) -> operator.operand (2);
718
719 if check_reverse (arg (2)) then
720 arg (2) = arg (2) -> operator.operand (2);
721
722 else
723 arg (2) = make_builtin_reference ("reverse", 1, arg (2), null, null);
724 end;
725
726 string (rtype) = fixed_binary_real_mask;
727 rprecision = max_length_precision;
728
729 goto create_operator_node;
730
731 action (7):
732 action (65):
733 if arg (1) -> node.type = operator_node then
734 if arg (1) -> op_code = std_call then do;
735 s = create_statement (call_statement, (statement_ptr -> statement.back), null,
736 (statement_ptr -> statement.prefix));
737 s -> statement.root = share_expression (arg (1));
738 end;
739
740 if ref (1) -> reference.varying_ref then do;
741 if jump_index = 7 then do;
742
743
744
745 string (rtype) = integer_type;
746 rprecision = max_length_precision;
747 goto create_operator_node;
748 end;
749
750 else do;
751
752
753
754 if arg_symbol (1) -> symbol.dcl_size = null then
755 tree = declare_constant$integer ((arg_symbol (1) -> symbol.c_dcl_size));
756 else do;
757 tree = copy_expression (arg_symbol (1) -> symbol.dcl_size);
758 if arg_symbol (1) -> symbol.refer_extents then
759 call refer_extent (tree, (ref (1) -> reference.qualifier));
760 tree = expression_semantics ((arg_symbol (1) -> symbol.block_node), statement_ptr, tree, "0"b);
761 tree = convert$to_integer (tree, integer_type);
762 end;
763
764 goto ret;
765 end;
766 end;
767
768 if ref (1) -> reference.length = null then
769 tree = declare_constant$integer ((ref (1) -> reference.c_length));
770 else
771 tree = ref (1) -> reference.length;
772
773 goto ret;
774
775 action (8):
776 arg (2) = arg (1);
777 ref (2) = ref (1);
778 arg_symbol (2) = arg_symbol (1);
779
780 arg (1), ref (1) = declare_constant ("000000000"b, char_type, 1, 0);
781 arg_symbol (1) = arg (1) -> reference.symbol;
782
783 arg_number = 2;
784 string (rtype) = char_type;
785
786 goto repeat;
787
788 action (9):
789 repeat:
790 if symbol_is_constant (arg_symbol (2)) then
791 m = constant_value (arg_symbol (2));
792
793 if ref (1) -> reference.varying_ref then
794 length = rlength;
795 else if ref (1) -> reference.length ^= null then
796 length = ref (1) -> reference.length;
797 else if ^symbol_is_constant (arg_symbol (2)) then
798 length = declare_constant$integer ((ref (1) -> reference.c_length));
799 else
800 length = null;
801
802 if length ^= null then do;
803 rprecision = 0;
804 arg (2) = share_expression (arg (2));
805 if ref (1) -> reference.c_length = 1 then
806 rlength = arg (2);
807 else do;
808 rlength = create_operator (mult, 3);
809 rlength -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
810 rlength -> operand (2) = length;
811 rlength -> operand (3) = arg (2);
812 rlength -> operator.processed = "1"b;
813 end;
814 end;
815 else do;
816 rprecision = ref (1) -> reference.c_length * max (m, 0);
817 if jump_index ^= 9 then
818 if m = 1 then
819 goto return_arg1;
820 end;
821
822 goto create_operator_node;
823 ^L
824 action (10):
825 if arg (1) -> node.type = token_node then do;
826 i = 1;
827 if arg_type (1).bit then
828 string (type) = defined_arg_type (1);
829 else
830 string (type) = char_mask;
831
832 call convert_arg;
833
834 if def_context.left_side then
835 call semantic_translator$abort (141, builtin_symbol);
836
837 goto return_arg1;
838 end;
839
840 if arg (1) -> node.type = reference_node & arg (1) = arg_symbol (1) -> symbol.reference then
841 arg (1), ref (1) = copy_expression ((ref (1)));
842
843 string (rtype) = defined_arg_type (1);
844
845 if def_context.left_side then
846 call propagate_bit (arg_symbol (1), set_bit);
847
848 if arg (1) -> node.type = operator_node then do;
849 if arg (1) -> operator.op_code = loop | arg (1) -> operator.op_code = join | arg_type (1).structure
850 | ref (1) -> reference.array_ref then
851 call semantic_translator$abort (294, builtin_symbol);
852
853 i = 1;
854 if arg_type (1).bit then
855 string (type) = defined_arg_type (1);
856 else
857 string (type) = char_mask;
858
859 call convert_arg;
860
861 if def_context.left_side then
862 call semantic_translator$abort (141, builtin_symbol);
863
864 goto return_arg1;
865 end;
866
867 if arg_type (1).structure then do;
868 p = arg_symbol (1);
869 do while (p -> symbol.structure);
870 p = p -> symbol.son;
871 end;
872
873 if p -> symbol.bit then
874 units = bit_;
875 else if p -> symbol.char | p -> symbol.picture then
876 units = character_;
877 else
878 goto err124;
879
880 call check_strings ((arg_symbol (1) -> symbol.son));
881
882 goto aggregate;
883 end;
884
885 if arg_type (1).bit | arg_type (1).char | arg_type (1).picture then do;
886 if ^ref (1) -> reference.array_ref then do;
887 if ^arg_type (1).picture then
888 goto return_arg1;
889 else do;
890 units = character_;
891 c_length = ref (1) -> reference.c_length;
892 length = null;
893 goto make_reference;
894 end;
895 end;
896
897 if arg_type (1).bit then
898 units = bit_;
899 else
900 units = character_;
901
902 if arg_symbol (1) -> symbol.packed then
903 goto aggregate;
904
905 if def_context.left_side then
906 call semantic_translator$abort (141, builtin_symbol);
907 else
908 call semantic_translator$abort (142, builtin_symbol);
909 goto ret;
910 end;
911 else do;
912 if arg (1) -> reference.array_ref then
913 call semantic_translator$abort (139, arg_symbol (1));
914
915 i = 1;
916 string (type) = char_mask;
917 call convert_arg;
918
919 goto return_arg1;
920 end;
921 ^L
922 action (11):
923 if rtype.bit then
924 units = bit_;
925 else
926 units = character_;
927
928 if arg (1) -> node.type = operator_node then do;
929 if def_context.left_side then
930 call semantic_translator$abort (148, builtin_symbol);
931
932 ref (1) = arg (1) -> operand (1);
933 end;
934 else if def_context.left_side then do;
935 call propagate_bit (arg_symbol (1), set_bit);
936 arg_symbol (1) -> symbol.passed_as_arg = "1"b;
937 end;
938
939
940
941
942 if arg_number = 2 | substr (statement_ptr -> statement.prefix, 8, 1) then do;
943 if ref (1) -> reference.varying_ref then do;
944 length = create_length_fun (arg (1));
945 c_length = 0;
946 end;
947 else do;
948 length = ref (1) -> reference.length;
949 c_length = ref (1) -> reference.c_length;
950 if length ^= null then
951 if arg (1) -> node.type = operator_node | ref (1) -> reference.ref_count > 1 then
952 length = share_expression (length);
953 end;
954
955 if arg_number = 2 & substr (statement_ptr -> statement.prefix, 8, 1) then
956 if length ^= null then
957 length = share_expression (length);
958 end;
959
960
961
962 if symbol_is_constant (arg_symbol (2)) then do;
963 offset = null;
964 c_offset = constant_value (arg_symbol (2)) - 1;
965 end;
966 else do;
967 c_offset = 0;
968
969 if arg (2) -> node.type = operator_node then
970 if arg (2) -> operator.op_code = add then
971 if arg (2) -> operand (3) -> node.type = reference_node then
972 if symbol_is_constant ((arg (2) -> operand (3) -> reference.symbol)) then
973 if constant_value ((arg (2) -> operand (3) -> reference.symbol)) = 1 then
974 if fb1_value ((arg (2) -> operand (3) -> reference.symbol)) then do;
975 r = arg (2) -> operand (2);
976 if r -> node.type = operator_node then
977 r = r -> operand (1);
978
979 if fb1_value ((r -> reference.symbol)) then do;
980 offset = arg (2) -> operand (2);
981 go to chk_context;
982 end;
983 end;
984
985 offset = create_operator (sub, 3);
986 offset -> operand (2) = arg (2);
987 offset -> operand (3) = declare_constant$integer (1);
988 end;
989
990 chk_context:
991 if def_context.arg_list then do;
992 tree, p = create_operator (assign, 2);
993 r = create_symbol (null, null, by_compiler);
994 r -> symbol.temporary = "1"b;
995 p -> operand (1) = r -> symbol.reference;
996 p -> operand (2) = arg (1);
997 end;
998
999 if arg (1) -> node.type = operator_node | arg_symbol (1) -> symbol.picture then do;
1000 s = create_symbol (null, null, by_compiler);
1001 p = s -> symbol.reference;
1002 t = ref (1) -> reference.symbol;
1003 s -> symbol = t -> symbol;
1004 s -> symbol.next = null;
1005 s -> symbol.reference = p;
1006 s -> symbol.defined, s -> symbol.overlayed, s -> symbol.position = "1"b;
1007 s -> symbol.return_value, s -> symbol.temporary = "0"b;
1008 p -> reference.qualifier = arg (1);
1009 p -> reference.shared = "0"b;
1010 p -> reference.ref_count = 1;
1011
1012 if s -> symbol.picture then do;
1013 s -> symbol.picture = "0"b;
1014 s -> symbol.char = "1"b;
1015 s -> symbol.general = null;
1016 end;
1017
1018 if arg (1) -> node.type ^= operator_node then do;
1019
1020
1021
1022 if ref (1) = arg_symbol (1) -> symbol.reference then
1023 p -> reference.qualifier, ref (1) = copy_expression ((ref (1)));
1024 else if ref (1) -> reference.ref_count > 1 then do;
1025 ref (1) -> reference.ref_count = ref (1) -> reference.ref_count - 1;
1026 r = create_reference (null);
1027 r -> reference = ref (1) -> reference;
1028 r -> reference.ref_count = 1;
1029 call reuse_qual_and_offset (r);
1030 p -> reference.qualifier, ref (1) = r;
1031 end;
1032 p -> reference.offset = ref (1) -> reference.offset;
1033 p -> reference.c_offset = ref (1) -> reference.c_offset;
1034 p -> reference.units = ref (1) -> reference.units;
1035 p -> reference.modword_in_offset = ref (1) -> reference.modword_in_offset;
1036 ref (1) -> reference.offset = null;
1037 ref (1) -> reference.c_offset = 0;
1038 ref (1) -> reference.modword_in_offset = "0"b;
1039
1040
1041
1042 ref (1) -> reference.inhibit = "1"b;
1043 end;
1044 end;
1045 else do;
1046 p = create_reference ((ref (1) -> reference.symbol));
1047 p -> reference = ref (1) -> reference;
1048 p -> reference.shared = "0"b;
1049 p -> reference.ref_count = 1;
1050 if ^ref (1) -> reference.shared then do;
1051 rcount, ref (1) -> reference.ref_count = ref (1) -> reference.ref_count - 1;
1052 if rcount > 0 then
1053 call reuse_qual_and_offset (p);
1054 end;
1055 end;
1056
1057
1058
1059
1060
1061 save_arg_one = arg (1);
1062 arg (1) = p;
1063
1064 arg (1) -> reference.varying_ref, arg (1) -> reference.padded_ref, arg (1) -> reference.aligned_ref = "0"b;
1065
1066 off = arg (1) -> reference.offset;
1067 coff = arg (1) -> reference.c_offset;
1068 cunits = arg (1) -> reference.units;
1069 call offset_adder (off, coff, cunits, (arg (1) -> reference.modword_in_offset), (offset), (c_offset), units,
1070 "0"b, arg (1) -> reference.fo_in_qual);
1071 arg (1) -> reference.offset = off;
1072 arg (1) -> reference.c_offset = coff;
1073 arg (1) -> reference.units = cunits;
1074 arg (1) -> reference.modword_in_offset = "0"b;
1075
1076 if ^pl1_stat_$eis_mode then
1077 if arg (1) -> reference.offset ^= null then
1078 if arg (1) -> reference.units <= half_ then do;
1079 if arg (1) -> reference.units = bit_ then
1080 opcode = mod_bit;
1081 else if arg (1) -> reference.units = character_ then
1082 opcode = mod_byte;
1083 else
1084 opcode = mod_half;
1085
1086 p = create_operator (opcode, 3);
1087 p -> operand (1), p -> operand (2) =
1088 declare_temporary (integer_type, default_fix_bin_p, 0, null);
1089 p -> operand (3) = arg (1) -> reference.offset;
1090
1091 arg (1) -> reference.offset = p;
1092 end;
1093
1094
1095
1096 if arg_number = 2 then
1097 if length = null & offset = null then
1098 arg (1) -> reference.c_length = c_length - c_offset;
1099 else do;
1100 p = create_operator (sub, 3);
1101 p -> operand (1) = declare_temporary (fixed_binary_real_mask, default_fix_bin_p, 0, null);
1102 p -> operand (2) = length;
1103 p -> operand (3) = offset;
1104
1105 arg (1) -> reference.length = p;
1106 arg (1) -> reference.c_length = 0;
1107
1108 if length = null then
1109 p -> operand (2) = declare_constant$integer (c_length);
1110
1111 if offset = null then
1112 p -> operand (3) = declare_constant$integer (c_offset);
1113 else do;
1114 if offset -> node.type = operator_node then
1115 offset = expression_semantics (cur_block, statement_ptr, offset, "0"b);
1116
1117 offset = share_expression (offset);
1118 end;
1119 end;
1120 else if symbol_is_constant (arg_symbol (3)) then do;
1121 arg (1) -> reference.c_length = constant_value (arg_symbol (3));
1122 arg (1) -> reference.length = null;
1123 end;
1124 else do;
1125 arg (1) -> reference.c_length = 0;
1126 arg (1) -> reference.length = arg (3);
1127 end;
1128
1129 if substr (statement_ptr -> statement.prefix, 8, 1) then
1130 if symbol_is_constant (arg_symbol (2))
1131 & arg (1) -> reference.length = null
1132 & length = null then do;
1133
1134 substr_index = constant_value (arg_symbol (2));
1135
1136 if substr_index < 1 then
1137 call semantic_translator$error (147, builtin_symbol);
1138
1139
1140 if arg (1) -> reference.c_length < 0 then
1141 c_length = substr_index - 1;
1142
1143 if c_length < (substr_index + arg (1) -> reference.c_length - 1) then
1144 call semantic_translator$error (147, builtin_symbol);
1145 end;
1146 else do;
1147 if arg (1) -> reference.length = null then do;
1148 arg (1) -> reference.length = declare_constant$integer ((arg (1) -> reference.c_length));
1149 arg (1) -> reference.c_length = 0;
1150 end;
1151
1152
1153
1154
1155 p = create_operator (range_ck, 4);
1156 p -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1157 p -> operand (2) = arg (1) -> reference.length;
1158 p -> operand (3) = declare_constant$integer (0);
1159
1160 p -> operand (4) = create_operator (sub, 3);
1161 p -> operand (4) -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1162
1163
1164
1165 if length = null then
1166 p -> operand (4) -> operand (2) = declare_constant$integer (c_length);
1167 else
1168 p -> operand (4) -> operand (2) = length;
1169
1170 if offset = null then
1171 p -> operand (4) -> operand (3) = declare_constant$integer (c_offset);
1172 else
1173 p -> operand (4) -> operand (3) = copy_expression ((offset));
1174
1175 if offset = null & length = null then
1176 if c_offset < 0 | c_offset > c_length then
1177 call semantic_translator$abort (147, builtin_symbol);
1178 else
1179 ;
1180 else do;
1181 r = create_operator (range_ck, 4);
1182 r -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1183 r -> operand (2) = p -> operand (4) -> operand (3);
1184 r -> operand (3) = declare_constant$integer (0);
1185 r -> operand (4) = copy_expression ((p -> operand (4) -> operand (2)));
1186
1187 p -> operand (4) -> operand (3) = r;
1188 end;
1189
1190 arg (1) -> reference.length = p;
1191 end;
1192
1193
1194
1195 if arg (1) -> reference.c_length < 0 then do;
1196 call semantic_translator$error (147, builtin_symbol);
1197 arg (1) -> reference.c_length = 0;
1198 end;
1199
1200 arg (1) -> reference.length =
1201 expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.length), "0"b);
1202 if arg (1) -> reference.length ^= null then
1203 arg (1) -> reference.length = convert$to_integer ((arg (1) -> reference.length), integer_type);
1204
1205 arg (1) -> reference.offset =
1206 expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.offset), "0"b);
1207 if arg (1) -> reference.offset ^= null then
1208 arg (1) -> reference.offset = convert$to_integer ((arg (1) -> reference.offset), integer_type);
1209
1210 arg (1) -> reference.substr = "1"b;
1211
1212 call simplify_offset (arg (1), context);
1213
1214 if def_context.arg_list then do;
1215 tree -> operand (2) = arg (1);
1216 tree = operator_semantics (cur_block, statement_ptr, tree, this_context);
1217 goto ret;
1218 end;
1219
1220 goto return_arg1;
1221 ^L
1222 action (12):
1223 if arg (1) -> node.type = token_node then do;
1224 call semantic_translator$error (485, null);
1225 i = 1;
1226 string (type) = defined_arg_type (1);
1227 call convert_arg;
1228 end;
1229
1230 if arg (1) -> node.type = reference_node & arg (1) = arg_symbol (1) -> symbol.reference then
1231 arg (1), ref (1) = copy_expression ((ref (1)));
1232
1233 string (rtype) = bit_mask;
1234 units = bit_;
1235
1236 if def_context.left_side then
1237 if arg (1) -> node.type = operator_node then
1238 call semantic_translator$abort (148, builtin_symbol);
1239 else do;
1240 call propagate_bit (arg_symbol (1), set_bit);
1241 arg_symbol (1) -> symbol.passed_as_arg = "1"b;
1242 end;
1243
1244 if arg_type (1).structure | ref (1) -> reference.array_ref then do;
1245 if pl1_stat_$check_ansi then
1246 call semantic_translator$error (172, builtin_symbol);
1247 goto aggregate;
1248 end;
1249
1250 if ref (1) -> reference.varying_ref then do;
1251 length = create_length_fun (arg (1));
1252 c_length = 0;
1253 end;
1254 else do;
1255 length = ref (1) -> reference.length;
1256 c_length = ref (1) -> reference.c_length;
1257 end;
1258
1259 if arg_symbol (1) -> symbol.bit then
1260 goto make_reference;
1261
1262 if arg_symbol (1) -> symbol.char | arg_symbol (1) -> symbol.picture then do;
1263 if length ^= null then do;
1264 p = create_operator (mult, 3);
1265 p -> operand (2) = length;
1266 p -> operand (3) = declare_constant$integer (bits_per_character);
1267 length = p;
1268 end;
1269 else
1270 c_length = c_length * bits_per_character;
1271
1272 goto make_reference;
1273 end;
1274
1275 aggregate:
1276 if arg (1) -> node.type = operator_node then
1277 call semantic_translator$abort (294, builtin_symbol);
1278
1279 if arg_symbol (1) -> symbol.array ^= null & ^ref (1) -> reference.array_ref then do;
1280 c_length = arg_symbol (1) -> symbol.array -> array.c_element_size_bits;
1281 length = copy_expression (arg_symbol (1) -> symbol.array -> array.element_size_bits);
1282 end;
1283 else do;
1284 c_length = arg_symbol (1) -> symbol.c_bit_size;
1285 length = copy_expression (arg_symbol (1) -> symbol.bit_size);
1286
1287 if ref (1) -> reference.offset ^= null then
1288 if ref (1) -> reference.offset -> node.type = list_node then
1289 call semantic_translator$abort (338, ref (1));
1290 end;
1291
1292 if units = character_ then
1293 if length ^= null then do;
1294 p = create_operator (bit_to_char, 2);
1295 p -> operand (2) = length;
1296
1297 length = p;
1298 end;
1299 else
1300 c_length = divide (c_length, bits_per_character, 15, 0);
1301
1302
1303 if arg_symbol (1) -> symbol.defined then
1304 if arg_symbol (1) -> symbol.structure | ref (1) -> reference.array_ref then
1305 arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);
1306
1307 make_reference:
1308 if arg (1) -> node.type = operator_node then do;
1309 call make_assignment;
1310
1311 if agg_ref = null then
1312 arg (1) = p -> operand (1);
1313 else do;
1314 arg (1) = agg_ref;
1315 defined_arg_type (1) = string (agg_ref -> reference.symbol -> symbol.attributes);
1316 c_length = agg_ref -> reference.symbol -> symbol.c_bit_size;
1317 length = copy_expression (agg_ref -> reference.symbol -> symbol.bit_size);
1318 end;
1319
1320 if arg_type (1).bit | jump_index = 12 then
1321 units = bit_;
1322 else
1323 units = character_;
1324 end;
1325
1326 if def_context.arg_list then do;
1327 tree, p = create_operator (assign, 2);
1328 r = create_symbol (null, null, by_compiler);
1329 r -> symbol.temporary = "1"b;
1330 p -> operand (1) = r -> symbol.reference;
1331 p -> operand (2) = arg (1);
1332 end;
1333
1334 if units = character_ then
1335 string (rtype) = char_mask;
1336 else
1337 string (rtype) = bit_mask;
1338
1339 rtype.unaligned = arg_symbol (1) -> symbol.packed;
1340
1341 if ^arg_symbol (1) -> symbol.overlayed_by_builtin then
1342 call propagate_bit (arg_symbol (1), overlayed_by_builtin_bit);
1343
1344 p = declare_defined_overlay (string (rtype), c_length, 0, length, arg (1));
1345
1346
1347
1348 ref (1) -> reference.length = null;
1349
1350 p -> reference.padded_ref = "0"b;
1351
1352
1353
1354
1355 p -> reference.qualifier = arg (1);
1356 p -> reference.fo_in_qual = ref (1) -> reference.fo_in_qual;
1357 p -> reference.offset = arg (1) -> reference.offset;
1358 p -> reference.c_offset = arg (1) -> reference.c_offset;
1359 p -> reference.units = arg (1) -> reference.units;
1360 p -> reference.modword_in_offset = arg (1) -> reference.modword_in_offset;
1361
1362 if ^pl1_stat_$eis_mode then
1363 if p -> reference.offset ^= null then
1364 if p -> reference.units <= half_ then do;
1365 if p -> reference.units = bit_ then
1366 opcode = mod_bit;
1367 else if p -> reference.units = character_ then
1368 opcode = mod_byte;
1369 else
1370 opcode = mod_half;
1371
1372 offset = create_operator (opcode, 3);
1373 offset -> operand (1), offset -> operand (2) =
1374 declare_temporary (integer_type, default_fix_bin_p, 0, null);
1375 offset -> operand (3) = p -> reference.offset;
1376
1377 p -> reference.offset = offset;
1378 end;
1379
1380 if (p -> reference.units = character_ | p -> reference.units = digit_) & units = bit_ & pl1_stat_$eis_mode
1381 then do;
1382 p -> reference.c_offset = p -> reference.c_offset * bits_per_character;
1383
1384 if p -> reference.units = digit_ then
1385 p -> reference.c_offset = divide (p -> reference.c_offset, packed_digits_per_character, 24, 0);
1386
1387 if p -> reference.offset ^= null & ^p -> reference.modword_in_offset then
1388 if p -> reference.units = character_ then do;
1389 offset = create_operator (mult, 3);
1390 offset -> operand (2) = declare_constant$integer (bits_per_character);
1391 offset -> operand (3) = p -> reference.offset;
1392 p -> reference.offset = offset;
1393 end;
1394 else do;
1395 offset = create_operator (digit_to_bit, 2);
1396 offset -> operand (2) = p -> reference.offset;
1397 p -> reference.offset = offset;
1398 end;
1399 p -> reference.units = bit_;
1400 end;
1401
1402 if p -> reference.qualifier -> node.type = reference_node then do;
1403 p -> reference.qualifier -> reference.c_offset = 0;
1404 p -> reference.qualifier -> reference.offset = null;
1405 p -> reference.qualifier -> reference.modword_in_offset = "0"b;
1406 p -> reference.qualifier -> reference.inhibit = "1"b;
1407 end;
1408
1409 p -> reference.length = fill_refer ((p -> reference.length), (ref (1) -> reference.qualifier), "1"b);
1410 p -> reference.length = expression_semantics (cur_block, statement_ptr, (p -> reference.length), "0"b);
1411 if p -> reference.length ^= null then
1412 p -> reference.length = convert$to_integer ((p -> reference.length), integer_type);
1413
1414 p -> reference.offset = expression_semantics (cur_block, statement_ptr, (p -> reference.offset), "0"b);
1415 if p -> reference.offset ^= null then
1416 p -> reference.offset = convert$to_integer ((p -> reference.offset), integer_type);
1417
1418 call simplify_offset (p, context);
1419
1420 if def_context.arg_list then do;
1421 tree -> operand (2) = p;
1422 tree = operator_semantics (cur_block, statement_ptr, tree, this_context);
1423 end;
1424 else
1425 tree = p;
1426
1427 goto ret;
1428 ^L
1429 action (13):
1430 string (rtype) = defined_arg_type (1) & ^unaligned_mask & ^complex_mask | real_mask | aligned_mask;
1431
1432 goto create_operator_node;
1433
1434 action (14):
1435
1436
1437
1438 string (rtype) = "0"b;
1439
1440 do i = 1 to 2;
1441 defined_as_if_type (i) = defined_arg_type (i);
1442
1443 if as_if_type (i).bit then
1444 defined_as_if_type (i) = fixed_binary_real_mask;
1445 else if as_if_type (i).char then
1446 defined_as_if_type (i) = fixed_decimal_real_mask;
1447 else if as_if_type (i).picture then
1448 if arg_symbol (i) -> symbol.complex then
1449 if arg_symbol (i) -> symbol.pix.pic_float then
1450 defined_as_if_type (i) = float_decimal_complex_mask;
1451 else
1452 defined_as_if_type (i) = fixed_decimal_complex_mask;
1453 else if arg_symbol (i) -> symbol.pix.pic_float then
1454 defined_as_if_type (i) = float_decimal_real_mask;
1455 else
1456 defined_as_if_type (i) = fixed_decimal_real_mask;
1457 end;
1458
1459 if as_if_type (1).fixed & as_if_type (2).fixed then
1460 string (rtype) = string (rtype) | fixed_mask;
1461 else
1462 string (rtype) = string (rtype) & ^fixed_mask | float_mask;
1463
1464 if as_if_type (1).decimal & as_if_type (2).decimal then
1465 string (rtype) = string (rtype) | decimal_mask;
1466 else
1467 string (rtype) = string (rtype) & ^decimal_mask | binary_mask;
1468
1469 if ^as_if_type (1).complex & ^as_if_type (2).complex then
1470 string (rtype) = string (rtype) | real_mask;
1471 else
1472 string (rtype) = string (rtype) & ^real_mask | complex_mask;
1473
1474 string (type) = string (rtype);
1475
1476 do i = 1 to 2;
1477 call convert_arg;
1478 end;
1479
1480 if rtype.float & arg_number = 4 then
1481 call semantic_translator$abort (167, builtin_symbol);
1482
1483 if arg_number = 4 then
1484 rscale = constant_value (arg_symbol (4));
1485
1486 rprecision = constant_value (arg_symbol (3));
1487
1488 if rtype.decimal & rprecision > max_p_dec then
1489 goto err146;
1490
1491 if rtype.fixed & rprecision > max_p_fix_bin_2 | rtype.float & rprecision > max_p_flt_bin_2 then
1492 goto err146;
1493
1494 arg_number = 2;
1495
1496 goto create_operator_node;
1497
1498 action (15):
1499
1500
1501
1502 string (rtype) = pl1_data$builtin_name.description (builtin_number).descriptor (1).type | aligned_mask;
1503
1504 if arg_number = 3 then
1505 rscale = constant_value (arg_symbol (3));
1506 else
1507 rscale = 0;
1508
1509 if arg_number >= 2 then
1510 rprecision = constant_value (arg_symbol (2));
1511 else
1512 rprecision = 0;
1513
1514 goto convert_to_arith;
1515
1516 action (16):
1517
1518
1519 if arg_type (1).complex then
1520 goto err124;
1521
1522 if arg_type (1).fixed then
1523 if arg_type (1).binary then
1524 rprecision = min (max_p_fix_bin_2, max (rprecision - rscale + 1, 1));
1525 else
1526 rprecision = min (max_p_dec, max (rprecision - rscale + 1, 1));
1527 rscale = 0;
1528
1529 goto create_operator_node;
1530
1531 action (17):
1532
1533 string (rtype) = "0"b;
1534
1535 do i = 1 to 2;
1536 defined_as_if_type (i) = defined_arg_type (i);
1537
1538 if as_if_type (i).bit then
1539 defined_as_if_type (i) = fixed_binary_real_mask;
1540 else if as_if_type (i).char then
1541 defined_as_if_type (i) = fixed_decimal_real_mask;
1542 else if as_if_type (i).picture then
1543 if arg_symbol (i) -> symbol.pix.pic_float then
1544 defined_as_if_type (i) = float_decimal_real_mask;
1545 else
1546 defined_as_if_type (i) = fixed_decimal_real_mask;
1547
1548 if as_if_type (i).complex then
1549 goto err124;
1550 end;
1551
1552 if as_if_type (1).fixed & as_if_type (2).fixed then
1553 string (rtype) = string (rtype) | fixed_mask;
1554 else
1555 string (rtype) = string (rtype) & ^fixed_mask | float_mask;
1556
1557 if as_if_type (1).decimal & as_if_type (2).decimal then
1558 string (rtype) = string (rtype) | decimal_mask;
1559 else
1560 string (rtype) = string (rtype) & ^decimal_mask | binary_mask;
1561
1562 string (type) = string (rtype);
1563 string (rtype) = string (rtype) & ^real_mask | complex_mask;
1564
1565 do i = 1 to 2;
1566 call convert_arg;
1567 end;
1568
1569 p1 = arg_symbol (1) -> symbol.c_dcl_size;
1570 p2 = arg_symbol (2) -> symbol.c_dcl_size;
1571 q1 = fixed (arg_symbol (1) -> symbol.scale, 31, 0);
1572 q2 = fixed (arg_symbol (2) -> symbol.scale, 31, 0);
1573
1574 rscale = max (q1, q2);
1575
1576 if rtype.fixed & rtype.binary then
1577 rprecision = min (max_p_fix_bin_2, max (p1 - q1, p2 - q2) + rscale);
1578 else
1579 rprecision = min (max_p_flt_bin_2, max (p1 - q1, p2 - q2) + rscale);
1580
1581 if rtype.decimal then
1582 rprecision = min (max_p_dec, max (p1 - q1, p2 - q2) + rscale);
1583
1584 goto create_operator_node;
1585
1586 action (18):
1587
1588 string (rtype) = pl1_data$builtin_name.description (builtin_number).descriptor (1).type | aligned_mask;
1589
1590 string_size_ck = "1"b;
1591
1592 if arg_number = 2 then
1593 if symbol_is_constant (arg_symbol (2)) then do;
1594 rprecision = constant_value (arg_symbol (2));
1595 rlength = null;
1596 end;
1597 else do;
1598 rprecision = 0;
1599 rlength = copy_expression ((arg (2)));
1600 end;
1601
1602 full_attribute_set = arg_number > 1;
1603
1604 if arg (1) -> node.type = token_node then do;
1605 arg (1) = convert$from_builtin (arg (1), string (rtype));
1606 if ^full_attribute_set then
1607 rprecision = arg (1) -> reference.c_length;
1608 opcode = assign;
1609 arg_number = 1;
1610
1611 goto create_operator_node;
1612 end;
1613
1614 goto convert_label;
1615
1616 action (19):
1617
1618 string (rtype) = string (rtype) & ^complex_mask | real_mask;
1619
1620 if ^def_context.arg_list then do;
1621 if arg_symbol (1) -> symbol.packed then
1622 string (rtype) = string (rtype) & ^aligned_mask | unaligned_mask;
1623
1624 t = declare_defined_overlay (string (rtype), rprecision, (rscale), rlength, arg (1));
1625 s = t -> reference.symbol;
1626
1627 s -> symbol.boundary = arg_symbol (1) -> symbol.boundary;
1628
1629 if def_context.left_side then
1630 call propagate_bit (arg_symbol (1), set_bit);
1631
1632 arg_symbol (1) -> symbol.overlayed_by_builtin = "1"b;
1633
1634 if opcode = imag_fun then
1635 if s -> symbol.decimal then do;
1636 if s -> symbol.unaligned then do;
1637 t -> reference.units = digit_;
1638 t -> reference.c_offset = divide (s -> symbol.c_bit_size, bits_per_digit, 15, 0);
1639 end;
1640 else do;
1641 t -> reference.units = character_;
1642 t -> reference.c_offset = divide (s -> symbol.c_bit_size, bits_per_character, 15, 0);
1643 end;
1644 end;
1645 else do;
1646 if s -> symbol.packed then do;
1647 t -> reference.units = bit_;
1648 t -> reference.c_offset = s -> symbol.c_bit_size;
1649 end;
1650 else do;
1651 t -> reference.units = word_;
1652 t -> reference.c_offset = s -> symbol.c_word_size;
1653 end;
1654 end;
1655
1656 if arg (1) -> node.type = operator_node then do;
1657 r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
1658 (statement_ptr -> statement.prefix));
1659 r -> statement.root = share_expression (arg (1));
1660 r -> statement.generated = "1"b;
1661
1662 ref (1) = arg (1) -> operand (1);
1663 end;
1664 else if arg (1) = arg_symbol (1) -> symbol.reference then
1665 arg (1), ref (1) = copy_expression ((arg (1)));
1666
1667 off = t -> reference.offset;
1668 coff = t -> reference.c_offset;
1669 cunits = t -> reference.units;
1670
1671 call offset_adder (off, coff, cunits, "0"b, (ref (1) -> reference.offset), (ref (1) -> reference.c_offset),
1672 (ref (1) -> reference.units), (ref (1) -> reference.modword_in_offset),
1673 ref (1) -> reference.fo_in_qual);
1674
1675 t -> reference.offset = off;
1676 t -> reference.c_offset = coff;
1677 t -> reference.units = cunits;
1678 ref (1) -> reference.offset = null;
1679 ref (1) -> reference.c_offset = 0;
1680 ref (1) -> reference.modword_in_offset = "0"b;
1681 ref (1) -> reference.inhibit = "1"b;
1682 t -> reference.qualifier = arg (1);
1683 t -> reference.fo_in_qual = ref (1) -> reference.fo_in_qual;
1684
1685 if t -> reference.offset ^= null then do;
1686 t -> reference.offset =
1687 expression_semantics (cur_block, statement_ptr, (t -> reference.offset), "0"b);
1688 call simplify_offset (t, "0"b);
1689 end;
1690
1691
1692 tree = t;
1693 goto ret;
1694 end;
1695
1696 goto create_operator_node;
1697
1698 action (20):
1699
1700 string (rtype) = "0"b;
1701 rprecision, rscale = 0;
1702
1703 do i = 1 to arg_number;
1704 defined_as_if_type (i) = defined_arg_type (i);
1705
1706 if as_if_type (i).bit then
1707 defined_as_if_type (i) = fixed_binary_real_mask;
1708 else if as_if_type (i).char then
1709 defined_as_if_type (i) = fixed_decimal_real_mask;
1710 else if as_if_type (i).picture then
1711 if arg_symbol (i) -> symbol.pix.pic_float then
1712 defined_as_if_type (i) = float_decimal_real_mask;
1713 else
1714 defined_as_if_type (i) = fixed_decimal_real_mask;
1715
1716 if as_if_type (i).complex then
1717 goto err124;
1718 end;
1719
1720 do i = 1 to arg_number;
1721 rtype.float = rtype.float | as_if_type (i).float;
1722 rtype.binary = rtype.binary | as_if_type (i).binary;
1723 end;
1724
1725 if ^rtype.float then
1726 rtype.fixed = "1"b;
1727
1728 if ^rtype.binary then
1729 rtype.decimal = "1"b;
1730
1731 rtype.real = "1"b;
1732
1733 string (type) = string (rtype);
1734
1735 do i = 1 to arg_number;
1736 call convert_arg;
1737 rprecision = max (rprecision, arg_symbol (i) -> symbol.c_dcl_size);
1738 rscale = max (rscale, fixed (arg_symbol (i) -> symbol.scale, 31, 0));
1739 end;
1740
1741 goto create_operator_node;
1742
1743 action (21):
1744 string (rtype) = real_mask | aligned_mask;
1745 rprecision, rscale = 0;
1746
1747 do i = 1 to 2;
1748 defined_as_if_type (i) = defined_arg_type (i);
1749
1750 if as_if_type (i).bit then
1751 defined_as_if_type (i) = fixed_binary_real_mask;
1752 else if as_if_type (i).char then
1753 defined_as_if_type (i) = fixed_decimal_real_mask;
1754 else if as_if_type (i).picture then
1755 if arg_symbol (i) -> symbol.pix.pic_float then
1756 defined_as_if_type (i) = float_decimal_real_mask;
1757 else
1758 defined_as_if_type (i) = fixed_decimal_real_mask;
1759
1760 if as_if_type (i).complex then
1761 goto err124;
1762 end;
1763
1764 if as_if_type (1).fixed & as_if_type (2).fixed then
1765 string (rtype) = string (rtype) | fixed_mask;
1766 else
1767 string (rtype) = string (rtype) & ^fixed_mask | float_mask;
1768
1769 if as_if_type (1).decimal & as_if_type (2).decimal then
1770 string (rtype) = string (rtype) | decimal_mask;
1771 else
1772 string (rtype) = string (rtype) & ^decimal_mask | binary_mask;
1773
1774 string (type) = string (rtype);
1775
1776 do i = 1 to 2;
1777 call convert_arg;
1778 end;
1779
1780 p1 = arg_symbol (1) -> symbol.c_dcl_size;
1781 p2 = arg_symbol (2) -> symbol.c_dcl_size;
1782 q1 = fixed (arg_symbol (1) -> symbol.scale, 31, 0);
1783 q2 = fixed (arg_symbol (2) -> symbol.scale, 31, 0);
1784
1785 rscale = max (q1, q2);
1786
1787 if rtype.float then
1788 rprecision = max (p1, p2);
1789 else if rtype.binary then
1790 rprecision = min (max_p_fix_bin_2, p2 - q2 + rscale);
1791 else
1792 rprecision = min (max_p_dec, p2 - q2 + rscale);
1793
1794 goto create_operator_node;
1795
1796 action (22):
1797 i = constant_value (arg_symbol (2));
1798
1799 if rtype.fixed then do;
1800 if rtype.decimal then
1801 rprecision =
1802 max (1,
1803 min (arg_symbol (1) -> symbol.c_dcl_size - arg_symbol (1) -> symbol.scale + 1 + i, max_p_dec));
1804 else
1805 rprecision =
1806 max (1,
1807 min (arg_symbol (1) -> symbol.c_dcl_size - arg_symbol (1) -> symbol.scale + 1 + i,
1808 max_p_fix_bin_2));
1809 rscale = i;
1810 end;
1811 if rtype.float then do;
1812 if i <= 0 then
1813 call semantic_translator$abort (271, builtin_symbol);
1814
1815 if rtype.decimal then
1816 rprecision = min (i, max_p_dec);
1817 else
1818 rprecision = min (i, max_p_flt_bin_2);
1819 end;
1820
1821 goto create_operator_node;
1822
1823 action (23):
1824 do i = 1 to 2;
1825 if ref (i) -> reference.varying_ref then
1826 cur_length (i) = create_length_fun (arg (i));
1827 else if ref (i) -> reference.length ^= null then
1828 cur_length (i) = share_expression ((ref (i) -> reference.length));
1829 else
1830 cur_length (i) = null;
1831 end;
1832
1833 if cur_length (1) = null & cur_length (2) = null then
1834 rprecision = max (ref (1) -> reference.c_length, ref (2) -> reference.c_length);
1835 else do;
1836 rprecision = 0;
1837 rlength = create_operator (max_fun, 3);
1838 rlength -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1839 rlength -> operand (2) = cur_length (1);
1840 rlength -> operand (3) = cur_length (2);
1841
1842 if cur_length (1) = null then
1843 rlength -> operand (2) = declare_constant$integer ((ref (1) -> reference.c_length));
1844
1845 if cur_length (2) = null then
1846 rlength -> operand (3) = declare_constant$integer ((ref (2) -> reference.c_length));
1847 end;
1848
1849 if ^arg_symbol (3) -> symbol.constant then do;
1850 t = declare_temporary (bit_mask, 4, 0, null);
1851 arg (3) = convert$to_target (arg (3), t);
1852 goto create_operator_node;
1853 end;
1854
1855 if rlength ^= null | rprecision > bits_per_double then
1856 goto create_operator_node;
1857
1858 bit4 = substr (arg_symbol (3) -> symbol.initial -> based_type, 1, 4);
1859 not_flag = substr (bit4, 1, 1);
1860
1861 if not_flag then
1862 bit4 = ^bit4;
1863
1864 if bit4 = "0000"b then do;
1865 tree = create_operator (assign, 2);
1866 tree -> operand (2) = declare_constant$bit ("000000000000000000000000000000000000"b);
1867 end;
1868 else if bit4 = "0011"b then do;
1869 tree = create_operator (assign, 2);
1870 tree -> operand (2) = arg (1);
1871 end;
1872 else if bit4 = "0101"b then do;
1873 tree = create_operator (assign, 2);
1874 tree -> operand (2) = arg (2);
1875 end;
1876
1877 else do;
1878 if bit4 = "0001"b then
1879 opcode = and_bits;
1880 else if bit4 = "0111"b then
1881 opcode = or_bits;
1882 else if bit4 = "0110"b then
1883 opcode = xor_bits;
1884
1885 else do;
1886 opcode = and_bits;
1887
1888 if bit4 = "0100"b then
1889 m = 1;
1890 else
1891 m = 2;
1892
1893 r = create_operator (assign, 2);
1894 r -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
1895 r -> operand (2) = arg (m);
1896
1897 p = create_operator (not_bits, 2);
1898 p -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
1899 p -> operand (2) = r;
1900
1901 arg (m) = p;
1902 end;
1903
1904 tree = create_operator (opcode, 3);
1905 tree -> operand (2) = arg (1);
1906 tree -> operand (3) = arg (2);
1907 end;
1908
1909 tree -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
1910
1911 if not_flag then do;
1912 p = create_operator (not_bits, 2);
1913 p -> operand (1) = declare_temporary (bit_mask, rprecision, 0, rlength);
1914 p -> operand (2) = tree;
1915
1916 tree = p;
1917 end;
1918
1919 goto ret;
1920
1921 action (24):
1922 if arg_type (1).bit & arg_type (2).bit then
1923 string (type) = bit_mask;
1924 else do;
1925 string (type) = char_mask;
1926 reserved_number = reserved_number + 1;
1927 end;
1928
1929 do i = 1 to 2;
1930 call convert_arg;
1931 end;
1932
1933 string (type) = bit_mask;
1934 call convert_arg;
1935
1936 do i = 1 to arg_number;
1937 if ref (i) -> reference.varying_ref then do;
1938 length = create_length_fun (arg (i));
1939
1940 p = create_operator (assign, 2);
1941 ref (i), p -> operand (1) = declare_temporary (string (rtype) & ^varying_mask, 0, 0, length);
1942 p -> operand (2) = arg (i);
1943
1944 arg (i) = p;
1945 arg_symbol (i) = ref (i) -> reference.symbol;
1946 end;
1947 end;
1948
1949 desc_reqd = "1"b;
1950
1951 goto create_call;
1952
1953 action (25):
1954
1955
1956
1957
1958
1959 if arg_type (1).complex then
1960 reserved_number = reserved_number + 2;
1961
1962 if rprecision > max_p_flt_bin_1 then
1963 reserved_number = reserved_number + 1;
1964
1965 goto create_call;
1966
1967 action (26):
1968
1969
1970 if arg_symbol (1) = null then
1971 call semantic_translator$abort (127, builtin_symbol);
1972
1973 if arg_symbol (1) -> node.type = label_node then do;
1974
1975
1976 if ^(arg_symbol (1) -> label.array) then
1977 call semantic_translator$abort (127, builtin_symbol);
1978 if reserved_number = 1 then
1979 number = arg_symbol (1) -> label.low_bound;
1980 else if reserved_number = 2 then
1981 number = arg_symbol (1) -> label.high_bound;
1982 else
1983 number = arg_symbol (1) -> label.high_bound - arg_symbol (1) -> label.low_bound + 1;
1984
1985 tree = declare_constant (unspec (number), integer_type, max_offset_precision, 0);
1986
1987 goto ret;
1988 end;
1989
1990 if arg_symbol (1) -> symbol.array = null then
1991 call semantic_translator$abort (127, builtin_symbol);
1992
1993 if arg_symbol (1) -> symbol.defined then
1994 arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);
1995
1996 p = arg_symbol (1) -> symbol.array;
1997
1998 if ^symbol_is_constant (arg_symbol (2)) then do;
1999 ref (3), arg (3) = declare_constant$integer ((p -> array.number_of_dimensions));
2000 arg_symbol (3) = arg (3) -> reference.symbol;
2001
2002 ref (4), arg (4) = declare_constant$integer (reserved_number);
2003 arg_symbol (4) = arg (4) -> reference.symbol;
2004
2005 reserved_number = 6;
2006 arg_number = 4;
2007 string (rtype) = fixed_binary_real_mask;
2008 rprecision = max_offset_precision;
2009 rscale = 0;
2010
2011 goto create_call;
2012 end;
2013
2014 integer = constant_value (arg_symbol (2));
2015
2016 if integer > p -> array.number_of_dimensions | integer < 1 then
2017 call semantic_translator$abort (128, builtin_symbol);
2018
2019 p = p -> array.bounds;
2020 do i = 1 to arg_symbol (1) -> symbol.array -> array.number_of_dimensions - integer;
2021 p = p -> bound.next;
2022 end;
2023
2024 if p -> bound.lower ^= null then do;
2025 call simplify_expression ((p -> bound.lower), constant, modified);
2026 if modified then do;
2027 p -> bound.c_lower = constant;
2028 p -> bound.lower = null;
2029 end;
2030 end;
2031
2032 if p -> bound.upper ^= null then do;
2033 call simplify_expression ((p -> bound.upper), constant, modified);
2034 if modified then do;
2035 p -> bound.c_upper = constant;
2036 p -> bound.upper = null;
2037 end;
2038 end;
2039
2040 if reserved_number = 1 then
2041 if p -> bound.lower = null then do;
2042 tree = declare_constant (unspec (p -> bound.c_lower), integer_type, max_offset_precision, 0);
2043 goto ret;
2044 end;
2045 else do;
2046 tree = copy_expression (p -> bound.lower);
2047 tree = fill_refer (tree, (ref (1) -> reference.qualifier), "1"b);
2048 tree = expression_semantics (cur_block, statement_ptr, tree, this_context);
2049
2050 arg (1) = tree;
2051 goto create_assign;
2052 end;
2053
2054 if reserved_number = 2 then
2055 if p -> bound.upper = null then do;
2056 tree = declare_constant (unspec (p -> bound.c_upper), integer_type, max_offset_precision, 0);
2057 goto ret;
2058 end;
2059 else do;
2060 tree = copy_expression (p -> bound.upper);
2061 tree = fill_refer (tree, (ref (1) -> reference.qualifier), "1"b);
2062 tree = expression_semantics (cur_block, statement_ptr, tree, this_context);
2063
2064 arg (1) = tree;
2065 goto create_assign;
2066 end;
2067
2068 if p -> bound.upper = null & p -> bound.lower = null then do;
2069 number = p -> bound.c_upper - p -> bound.c_lower + 1;
2070 tree = declare_constant (unspec (number), integer_type, max_offset_precision, 0);
2071
2072 goto ret;
2073 end;
2074
2075 arg (1) = copy_expression (p -> bound.upper);
2076 if arg (1) = null then
2077 arg (1) = declare_constant$integer ((p -> bound.c_upper));
2078 else do;
2079 arg (1) = fill_refer (arg (1), (ref (1) -> reference.qualifier), "1"b);
2080
2081 if arg (1) -> node.type = token_node then
2082 arg (1) = expression_semantics (cur_block, statement_ptr, arg (1), "0"b);
2083
2084 if arg (1) -> node.type = reference_node then
2085 if arg (1) -> reference.symbol -> symbol.arg_descriptor then do;
2086 t = create_operator (assign, 2);
2087 t -> operand (1) = declare_temporary (integer_type, max_offset_precision, 0, null);
2088 t -> operand (2) = arg (1);
2089 arg (1) = t;
2090 end;
2091 end;
2092
2093 arg (2) = copy_expression (p -> bound.lower);
2094 if arg (2) = null then
2095 arg (2) = declare_constant$integer (p -> bound.c_lower - 1);
2096 else do;
2097 arg (2) = fill_refer (arg (2), (ref (1) -> reference.qualifier), "1"b);
2098
2099 if arg (2) -> node.type = token_node then
2100 arg (2) = expression_semantics (cur_block, statement_ptr, arg (2), "0"b);
2101
2102 if arg (2) -> node.type = reference_node then
2103 if arg (2) -> reference.symbol -> symbol.arg_descriptor then do;
2104 t = create_operator (assign, 2);
2105 t -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
2106 t -> operand (2) = arg (2);
2107 arg (2) = t;
2108 end;
2109
2110 p = create_operator (sub, 3);
2111 p -> operand (1) = declare_temporary (fixed_binary_real_mask, max_offset_precision, 0, null);
2112 p -> operand (2) = arg (2);
2113 p -> operand (3) = declare_constant$integer (1);
2114
2115 arg (2) = p;
2116 end;
2117
2118 do i = 1 to 2;
2119 arg (i) = expression_semantics (cur_block, statement_ptr, arg (i), "0"b);
2120 end;
2121
2122 string (rtype) = fixed_binary_real_mask;
2123 rprecision = max_offset_precision;
2124 rscale = 0;
2125
2126 goto create_operator_node;
2127
2128 action (27):
2129 if check_reverse (arg (1)) then do;
2130 tree = arg (1) -> operator.operand (2);
2131 go to ret;
2132 end;
2133 if is_this_constant (arg (1)) then do;
2134 constant_string_length = arg (1) -> reference.c_length;
2135 if arg_type (1).bit then
2136 tree = declare_constant$bit (reverse (arg_symbol (1) -> symbol.initial -> constant_bit_string));
2137 else
2138 tree = declare_constant$char (reverse (arg_symbol (1) -> symbol.initial -> constant_char_string));
2139 go to exit;
2140 end;
2141 if ref (1) -> reference.c_length = 1 then do;
2142 tree = arg (1);
2143 go to ret;
2144 end;
2145 goto create_operator_node;
2146
2147 action (28):
2148 if pl1_stat_$cur_statement -> statement.root -> operand (2) ^= tree
2149 & pl1_stat_$cur_statement -> statement.root -> operand (2) ^= tree -> reference.symbol -> symbol.token then
2150 call semantic_translator$abort (187, builtin_symbol);
2151
2152 arg (2) = pl1_stat_$cur_statement -> statement.root -> operand (1);
2153 arg_symbol (2) = arg (2) -> reference.symbol;
2154
2155 if string (arg_symbol (2) -> symbol.data_type) = "0"b then do;
2156 arg_symbol (2) -> symbol.area = "1"b;
2157 arg_symbol (2) -> symbol.c_dcl_size, arg_symbol (2) -> symbol.c_word_size = min_area_size;
2158 integer_24 = min_area_size;
2159 end;
2160 else if ^arg_symbol (2) -> symbol.area then
2161 call semantic_translator$abort (188, arg (2));
2162 else if arg_symbol (2) -> symbol.dcl_size = null then
2163 integer_24 = arg_symbol (2) -> symbol.c_dcl_size;
2164 else
2165 integer_24 = 0;
2166
2167
2168 if arg_symbol (2) -> symbol.structure then
2169 call semantic_translator$abort (265, arg_symbol (2));
2170
2171 if arg (2) -> reference.array_ref then do;
2172 t = expand_primitive (cur_block, statement_ptr, arg (2), "0"b);
2173
2174 do r = t repeat t -> operand (1) while (r -> operand (1) -> node.type = operator_node);
2175 end;
2176
2177 arg (2) = r -> operand (1);
2178 end;
2179 else
2180 r = null;
2181
2182 if ^pl1_stat_$use_old_area then do;
2183 p = create_operator (empty_area, 2);
2184 p -> operand (1) = arg (2);
2185 if integer_24 ^= 0 then
2186 p -> operand (2) = declare_constant$integer ((integer_24));
2187 else do;
2188 q = copy_expression (arg_symbol (2) -> symbol.dcl_size);
2189
2190 if arg_symbol (2) -> symbol.refer_extents then
2191 q = fill_refer (q, (arg (2) -> reference.qualifier), "1"b);
2192
2193 q = expression_semantics (cur_block, statement_ptr, q, "0"b);
2194 p -> operand (2) = q;
2195 end;
2196 end;
2197
2198 else do;
2199
2200 p = create_operator (copy_words, 3);
2201 p -> operand (1) = arg (2);
2202 p -> operand (2) = declare_constant$bit ((84)"0"b || bit (integer_24, 24) || (36)"0"b);
2203 p -> operand (3) = declare_constant$integer (4);
2204
2205 if arg_symbol (2) -> symbol.dcl_size ^= null then do;
2206 if arg (2) -> reference.offset ^= null | arg (2) -> reference.c_offset ^= 0 then do;
2207
2208 q = create_reference (null);
2209 q -> reference = arg (2) -> reference;
2210 arg (2) = q;
2211 if ^q -> reference.shared then do;
2212 q -> reference.ref_count = 0;
2213 if q -> reference.offset ^= null then
2214 q -> reference.offset = copy_expression (q -> reference.offset);
2215 if q -> reference.qualifier ^= null then
2216 q -> reference.qualifier = copy_expression (q -> reference.qualifier);
2217 end;
2218 end;
2219
2220 q = create_operator (assign, 2);
2221 q -> operand (1) = declare_integer (cur_block);
2222 q -> operand (2) = copy_expression (arg_symbol (2) -> symbol.dcl_size);
2223
2224 if arg_symbol (2) -> symbol.refer_extents then
2225 q -> operand (2) = fill_refer ((q -> operand (2)), (arg (2) -> reference.qualifier), "1"b);
2226
2227 q -> operand (2) = expression_semantics (cur_block, p, (q -> operand (2)), "0"b);
2228
2229 arg (2) = expression_semantics (cur_block, statement_ptr, arg (2), "0"b);
2230
2231 q -> operand (1) -> reference.units = word_;
2232 q -> operand (1) -> reference.offset = arg (2) -> reference.offset;
2233 q -> operand (1) -> reference.c_offset = arg (2) -> reference.c_offset + 2;
2234
2235 q -> operand (1) -> reference.qualifier = copy_expression ((arg (2)));
2236
2237 arg (2) -> reference.offset = null;
2238 arg (2) -> reference.c_offset = 0;
2239
2240 q -> operand (1) -> reference.symbol -> symbol.defined,
2241 q -> operand (1) -> reference.symbol -> symbol.position,
2242 q -> operand (1) -> reference.symbol -> symbol.overlayed, q -> operator.processed = "1"b;
2243
2244 q -> operand (1) -> reference.shared, q -> operand (1) -> reference.symbol -> symbol.auto = "0"b;
2245 q -> operand (1) -> reference.ref_count = 1;
2246
2247
2248 tree = create_operator (join, 2);
2249 tree -> operand (1) = p;
2250 tree -> operand (2) = q;
2251
2252 p = tree;
2253 end;
2254 end;
2255
2256 if r ^= null then do;
2257 r -> operand (1) = p;
2258 tree = t;
2259 end;
2260 else
2261 tree = p;
2262
2263
2264 def_context.return_from_empty = "1"b;
2265
2266 goto ret;
2267
2268 action (29):
2269 p = null;
2270 tree = declare_constant (unspec (p), pointer_type, 0, 0);
2271
2272 goto exit;
2273
2274 action (30):
2275
2276 if def_save_context.aggregate then
2277 goto err124;
2278 if def_context.left_side then do;
2279 tree = create_operator (std_call, 3);
2280 tree -> operand (2) = reserve$declare_lib (reserved_number - 7);
2281 tree -> operand (3) = create_operator (std_arg_list, 3);
2282 tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 6, 0, null);
2283 tree -> operand (3) -> operand (2) = create_list (2);
2284 tree -> operand (3) -> operand (2) -> element (1) = arg (1);
2285
2286 tree -> operand (3) -> operand (2) -> element (2) =
2287 convert$to_integer ((pl1_stat_$cur_statement -> statement.root -> operand (2)), integer_type);
2288
2289 def_context.return_from_empty = "1"b;
2290
2291 goto ret;
2292 end;
2293
2294 rprecision = max_p_fix_bin_1;
2295 string (rtype) = integer_type;
2296
2297 goto create_call;
2298
2299 action (31):
2300 string (rtype) = char_mask;
2301 rprecision = 6;
2302
2303 goto create_call;
2304
2305 action (32):
2306 string (rtype) = char_mask;
2307 rprecision = 12;
2308
2309 goto create_call;
2310
2311 action (33):
2312 if arg (1) -> node.type ^= reference_node & pl1_stat_$check_ansi then
2313 call semantic_translator$abort (132, builtin_symbol);
2314 else if arg (1) -> reference.temp_ref then
2315 call semantic_translator$error (299, builtin_symbol);
2316
2317
2318 if arg_symbol (1) -> symbol.constant then
2319 if arg_symbol (1) -> symbol.initial ^= null then
2320 call semantic_translator$abort (132, builtin_symbol);
2321
2322 call propagate_bit (arg_symbol (1), aliasable_bit);
2323 call propagate_bit (arg_symbol (1), set_bit);
2324 if arg_symbol (1) -> symbol.cross_references ^= null then
2325 arg_symbol (1) -> symbol.cross_references -> cross_reference.set_reference = "0"b;
2326
2327
2328 if arg_symbol (1) -> symbol.defined & (arg (1) -> reference.array_ref | arg_symbol (1) -> symbol.structure)
2329 then do;
2330 arg (1) = defined_reference (cur_block, statement_ptr, arg (1), null, arg_symbol (1), "0"b);
2331 if arg (1) -> reference.offset ^= null then
2332 arg (1) -> reference.offset =
2333 expression_semantics (cur_block, statement_ptr, (arg (1) -> reference.offset), "0"b);
2334 end;
2335
2336 if arg (1) -> reference.units < word_ & arg (1) -> reference.units ^= 0 | arg (1) -> reference.fo_in_qual then
2337 opcode = addr_fun_bits;
2338
2339 goto prepare_pointer;
2340
2341 action (34):
2342
2343 if def_save_context.aggregate then
2344 goto err124;
2345 if arg_type (1).offset then
2346 if ^arg_type (2).area then
2347 call semantic_translator$abort (437, arg (2));
2348 else
2349 goto prepare_pointer;
2350
2351 if ^arg_type (1).ptr then
2352 call semantic_translator$abort (438, arg (1));
2353
2354 if pl1_stat_$check_ansi then
2355 call semantic_translator$error (172, builtin_symbol);
2356
2357 if ^arg_type (1).aligned then do;
2358 p = create_operator (assign, 2);
2359 p -> operand (1) = declare_temporary (pointer_type, 0, 0, null);
2360 p -> operand (2) = arg (1);
2361 arg (1) = p;
2362 end;
2363
2364 if arg_type (2).bit then do;
2365 i = 2;
2366 string (type) = bit_mask;
2367 call convert_arg;
2368
2369 goto prepare_pointer;
2370 end;
2371
2372 if arg_type (2).char | defined_arg_type (2) & arithmetic_mask then do;
2373 i = 2;
2374 string (type) = fixed_binary_real_mask;
2375 call convert_arg;
2376
2377 goto prepare_pointer;
2378 end;
2379 else
2380 call semantic_translator$abort (436, arg (2));
2381
2382 action (35):
2383 if def_save_context.aggregate then
2384 goto err124;
2385 string (rtype) = offset_mask;
2386
2387 goto create_operator_node;
2388
2389 action (36):
2390 if arg_symbol (1) -> symbol.father ^= null | ^arg_symbol (1) -> symbol.controlled then
2391 call semantic_translator$abort (124, builtin_symbol);
2392
2393
2394
2395
2396 if ^arg (1) -> reference.shared then
2397 arg (1) -> reference.length = null;
2398
2399 string (rtype) = integer_type;
2400 rprecision = default_fix_bin_p;
2401 rscale = 0;
2402 rlength = null;
2403
2404 goto create_operator_node;
2405
2406 action (37):
2407
2408 if check_reverse (arg (1)) then do;
2409 arg (1) = arg (1) -> operator.operand (2);
2410 if opcode = search_fun then
2411 opcode = search_rev_fun;
2412 else
2413 opcode = verify_rev_fun;
2414 end;
2415
2416 string (rtype) = fixed_binary_real_mask;
2417 rprecision = max_length_precision;
2418
2419 goto create_operator_node;
2420
2421 action (38):
2422 if rtype.complex then
2423 goto err124;
2424
2425 string (rtype) = fixed_binary_real_mask;
2426 rprecision = default_fix_bin_p;
2427 rscale = 0;
2428
2429 goto create_operator_node;
2430
2431 action (39):
2432
2433 if def_save_context.aggregate then
2434 goto err124;
2435 if ^arg_type (1).ptr then
2436 goto err124;
2437
2438 string (rtype) = bit_mask;
2439 rprecision = 18;
2440
2441 goto create_operator_node;
2442
2443 action (70):
2444 rprecision = 15;
2445 go to pointer_decomp_common;
2446 action (71):
2447 rprecision = 18;
2448 go to pointer_decomp_common;
2449 action (72):
2450 rprecision = 21;
2451 go to pointer_decomp_common;
2452 action (73):
2453 rprecision = 24;
2454
2455 pointer_decomp_common:
2456 if def_save_context.aggregate then
2457 goto err124;
2458 if ^arg_type (1).ptr then
2459 goto err124;
2460
2461 string (rtype) = fixed_binary_real_mask;
2462 rscale = 0;
2463 rlength = null;
2464
2465 goto create_operator_node;
2466
2467 action (74):
2468 if def_save_context.aggregate then
2469 goto err124;
2470
2471 go to prepare_pointer;
2472
2473 action (40):
2474 string (rtype) = bit_mask;
2475 rprecision = 1;
2476
2477 goto create_operator_node;
2478
2479 action (41):
2480
2481 if def_save_context.aggregate then
2482 goto err124;
2483 goto prepare_pointer;
2484
2485 action (42):
2486
2487
2488
2489 arg (1) = declare_temporary (char_mask, 256, 0, null);
2490 arg_symbol (1) = arg (1) -> reference.symbol;
2491
2492 desc_reqd = "1"b;
2493
2494 goto create_call;
2495
2496 action (43):
2497
2498 if arg_symbol (1) = null then
2499 call semantic_translator$abort (127, builtin_symbol);
2500
2501 if arg_type (1).bit then do;
2502 string (rtype) = fixed_binary_real_mask;
2503 rprecision = max_p_fix_bin_2;
2504 rscale = 0;
2505 end;
2506 else if arg_type (1).char then do;
2507 string (rtype) = fixed_decimal_real_mask;
2508 rprecision = max_p_dec;
2509 rscale = 0;
2510 end;
2511 else if arg_type (1).picture then do;
2512 rprecision = arg_symbol (1) -> symbol.pix.pic_size;
2513 rscale = arg_symbol (1) -> symbol.pix.pic_scale;
2514 if arg_type (1).complex then
2515 if arg_symbol (1) -> symbol.pix.pic_float then
2516 string (rtype) = float_decimal_complex_mask;
2517 else
2518 string (rtype) = fixed_decimal_complex_mask;
2519 else if arg_symbol (1) -> symbol.pix.pic_float then
2520 string (rtype) = float_decimal_real_mask;
2521 else
2522 string (rtype) = fixed_decimal_real_mask;
2523 end;
2524
2525 if rtype.fixed then
2526 if opcode = mult & rscale ^= 0 then do;
2527 if rtype.binary then
2528 rprecision = max_p_flt_bin_2;
2529 else
2530 rprecision = max_p_dec;
2531 rscale = 0;
2532 string (type), string (rtype) = string (rtype) & ^fixed_mask | float_mask;
2533 end;
2534 else if rtype.binary then
2535 rprecision = max_p_fix_bin_2;
2536 else
2537 rprecision = max_p_dec;
2538
2539 if arg (1) -> node.type ^= operator_node then
2540 arg (1) = expand_primitive (cur_block, statement_ptr, arg (1), "0"b);
2541
2542 if arg (1) -> operator.op_code ^= loop then
2543 call semantic_translator$abort (127, builtin_symbol);
2544
2545 product:
2546 p = arg (1);
2547 do while (p -> operand (1) -> node.type = operator_node);
2548 if p -> operand (1) -> operator.op_code = loop then
2549 p = p -> operand (1);
2550 else
2551 goto leave;
2552 end;
2553
2554 leave:
2555 r = create_operator (opcode, 3);
2556 r -> operand (3) = p -> operand (1);
2557
2558 q = create_operator (assign, 2);
2559 q -> operand (2) = r;
2560
2561 t = create_symbol (cur_block, null, by_compiler);
2562 substr (string (t -> symbol.attributes), 1, 36) = string (rtype) & undesirable_mask & ^unaligned_mask;
2563 t -> symbol.c_dcl_size = rprecision;
2564 t -> symbol.scale = rscale;
2565 t -> symbol.auto, t -> symbol.precision, t -> symbol.allocate = "1"b;
2566
2567 call declare (t);
2568
2569 t = t -> symbol.reference;
2570
2571 q -> operand (1), r -> operand (2) = t;
2572
2573 p -> operand (1) = expression_semantics (cur_block, statement_ptr, q, this_context);
2574
2575 r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
2576 (statement_ptr -> statement.prefix));
2577 r -> statement.generated = "1"b;
2578
2579 p = create_operator (assign, 2);
2580 p -> operand (1) = t;
2581 if opcode = add then
2582 p -> operand (2) = create_token ("0", dec_integer);
2583 else
2584 p -> operand (2) = create_token ("1", dec_integer);
2585
2586 r -> statement.root = operator_semantics (cur_block, r, p, this_context);
2587
2588 r = create_statement (assignment_statement, r, null, (r -> statement.prefix));
2589 r -> statement.generated = "1"b;
2590 r -> statement.root = operator_semantics (cur_block, r, arg (1), this_context);
2591
2592 tree = t;
2593
2594 goto ret;
2595
2596 action (44):
2597 i = -1;
2598 tree = declare_constant (unspec (i), offset_mask, 0, 0);
2599
2600 goto exit;
2601
2602 action (45):
2603 p = create_operator (mult, 3);
2604 p -> operand (2) = arg (1);
2605 p -> operand (3) = arg (2);
2606
2607 p = expand_infix (cur_block, statement_ptr, p, "0"b);
2608
2609 if p -> operator.op_code ^= loop then
2610 call semantic_translator$abort (190, builtin_symbol);
2611 if p -> operand (1) -> operator.op_code ^= mult then
2612 call semantic_translator$abort (190, builtin_symbol);
2613
2614 r = p -> operand (1) -> operand (1);
2615 string (rtype) = string (r -> reference.symbol -> symbol.attributes);
2616 rprecision = constant_value (arg_symbol (3));
2617 if arg_number = 4 then
2618 rscale = constant_value (arg_symbol (4));
2619
2620 arg (1) = p;
2621
2622 goto product;
2623
2624 action (46):
2625 arith_size_ck, string_size_ck = "1"b;
2626
2627 if def_save_context.aggregate then
2628 goto err124;
2629 if arg (1) -> node.type ^= reference_node then
2630 goto err124;
2631
2632 tree = convert$to_target_fb (arg (2), arg (1));
2633
2634 goto ret;
2635
2636 action (47):
2637 action (64):
2638 if arg (1) -> node.type ^= reference_node then
2639 goto err124;
2640 if arg (1) -> reference.symbol -> symbol.father ^= null then
2641 goto err124;
2642
2643 p = arg (1) -> reference.symbol -> symbol.word_size;
2644
2645 if p = null then
2646 tree =
2647 declare_constant (unspec (arg (1) -> reference.symbol -> symbol.c_word_size), integer_type,
2648 max_offset_precision, 0);
2649 else do;
2650 tree = copy_expression ((p));
2651 if jump_index = 64 then
2652 if arg_symbol (1) -> symbol.refer_extents then
2653 call refer_extent (tree, (arg (1) -> reference.qualifier));
2654
2655 tree =
2656 expression_semantics ((arg (1) -> reference.symbol -> symbol.block_node), statement_ptr, tree,
2657 this_context);
2658 arg (1) = tree;
2659
2660 goto create_assign;
2661 end;
2662
2663 goto ret;
2664
2665 action (48):
2666 if def_save_context.aggregate then
2667 goto err124;
2668 if arg (1) -> node.type ^= reference_node then
2669 goto err124;
2670 if ^arg_symbol (1) -> symbol.picture then
2671 goto err124;
2672
2673 string (rtype) = bit_mask;
2674 rprecision = 1;
2675
2676 arg_number = 2;
2677 arg (2) = arg_symbol (1) -> symbol.general;
2678 if arg (2) -> node.type ^= reference_node then
2679 call semantic_translator$abort (440, arg_symbol (1));
2680
2681 goto create_call;
2682
2683 action (49):
2684 goto create_operator_node;
2685
2686 action (50):
2687 goto create_operator_node;
2688
2689 action (51):
2690 string (rtype) = char_mask;
2691 rprecision = 1;
2692
2693 goto create_call;
2694
2695 action (52):
2696 goto action (42);
2697
2698 make_call:
2699 if pl1_stat_$cur_statement -> statement.root -> operand (1) ^= input_tree
2700 & pl1_stat_$cur_statement -> statement.root -> operand (1)
2701 ^= input_tree -> reference.symbol -> symbol.token then
2702 if pl1_stat_$cur_statement -> statement.root -> op_code = assign then
2703 call semantic_translator$abort (187, builtin_symbol);
2704 else
2705 arg (1) = null;
2706
2707 else do;
2708 def_context.return_from_empty = "1"b;
2709 arg (1) =
2710 expression_semantics (cur_block, statement_ptr,
2711 (pl1_stat_$cur_statement -> statement.root -> operand (2)), "0"b);
2712
2713 if arg (1) -> node.type = token_node then
2714 arg (1) = convert (arg (1), char_mask);
2715
2716 if arg (1) -> node.type = operator_node then
2717 ref (1) = arg (1) -> operand (1);
2718 else
2719 ref (1) = arg (1);
2720 end;
2721
2722 if arg (1) = null | jump_index = 52 then do;
2723 s = create_symbol (cur_block, null, by_compiler);
2724 s -> symbol.char, s -> symbol.auto, s -> symbol.passed_as_arg, s -> symbol.reference -> reference.shared =
2725 "1"b;
2726
2727 if jump_index = 52 then do;
2728 s -> symbol.varying = "1"b;
2729 s -> symbol.c_dcl_size = 256;
2730 end;
2731 else
2732 s -> symbol.c_dcl_size = 1;
2733
2734 s -> symbol.reference -> reference.c_length = s -> symbol.c_dcl_size;
2735
2736 call declare (s);
2737
2738 if ^def_context.return_from_empty then
2739 arg (1) = s -> symbol.reference;
2740 else do;
2741 p = create_operator (assign, 2);
2742 p -> operand (1) = s -> symbol.reference;
2743 p -> operand (2) = arg (1);
2744
2745 p -> operand (1) -> reference.c_length = t -> operand (1) -> reference.c_length;
2746 p -> operand (1) -> reference.length = share_expression ((t -> operand (1) -> reference.length));
2747
2748 q = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
2749 (statement_ptr -> statement.prefix));
2750 q -> statement.root = p;
2751
2752 arg (1) = p -> operand (1);
2753 end;
2754 end;
2755
2756 tree = create_operator (std_call, 3);
2757 tree -> operand (2) = reserve$declare_lib ((reserved_number));
2758 tree -> operand (3) = create_operator (std_arg_list, 3);
2759 tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 4, 0, null);
2760 tree -> operand (3) -> operand (2) = create_list (1);
2761 tree -> operand (3) -> operand (2) -> element (1) = arg (1);
2762
2763 if ^def_context.return_from_empty then do;
2764 p = tree;
2765 tree = create_operator (join, 3);
2766 tree -> operand (1) = create_operator (assign, 2);
2767 tree -> operand (1) -> operand (1) = share_expression (arg (1));
2768 tree -> operand (1) -> operand (2) = share_expression (t);
2769
2770 tree -> operand (2) = share_expression (arg (1));
2771 tree -> operand (3) = p;
2772 end;
2773
2774 goto exit;
2775
2776 action (53):
2777 string (rtype) = integer_type;
2778 rprecision = default_fix_bin_p;
2779
2780 goto create_call;
2781
2782 action (54):
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797 if arg_number > 1 then
2798 rprecision = max (rprecision, arg_symbol (2) -> symbol.c_dcl_size);
2799
2800 if arg_type (1).complex then
2801 goto action (25);
2802
2803 goto create_operator_node;
2804
2805 action (55):
2806 if arg_type (1).bit & arg_type (2).bit then
2807 string (type) = bit_mask;
2808 else
2809 string (type) = char_mask;
2810
2811 do i = 1 to 2;
2812 call convert_arg;
2813 end;
2814
2815 make_add:
2816 offset = create_operator (add, 3);
2817 offset -> operand (2) = create_index_or_verify ();
2818 offset -> operand (3) = declare_constant$integer (1);
2819
2820 tree = make_builtin_reference ("substr", 2, arg (1), offset, null);
2821 go to exit;
2822
2823 action (56):
2824 if arg_type (1).bit & arg_type (2).bit then
2825 string (type) = bit_mask;
2826 else
2827 string (type) = char_mask;
2828
2829 do i = 1 to 2;
2830 call convert_arg;
2831 end;
2832
2833 tree = make_builtin_reference ("substr", 3, arg (1), declare_constant$integer (1), create_index_or_verify ());
2834 go to exit;
2835
2836 action (57):
2837 if arg_number = 1 then
2838 arg (2) = declare_constant$char (" ");
2839
2840 go to make_add;
2841
2842 action (58):
2843 if arg_number = 1 then
2844 arg (2) = declare_constant$char (" ");
2845
2846 if ref (1) -> reference.varying_ref then
2847 p = create_length_fun (arg (1));
2848 else if ref (1) -> reference.length = null then
2849 p = declare_constant$integer ((ref (1) -> reference.c_length));
2850 else
2851 p = share_expression ((ref (1) -> reference.length));
2852
2853 length = create_operator (sub, 3);
2854 length -> operand (2) = p;
2855 length -> operand (3) = create_index_or_verify ();
2856
2857 tree = make_builtin_reference ("substr", 3, arg (1), declare_constant$integer (1), length);
2858 go to exit;
2859
2860 action (59):
2861 tree = declare_constant$char (pl1_data$long_collating_sequence);
2862
2863 goto ret;
2864
2865 action (60):
2866 arg (2) = arg (1);
2867 ref (2) = ref (1);
2868 arg_symbol (2) = arg_symbol (1);
2869
2870 arg (1), ref (1) = declare_constant ("111111111"b, char_type, 1, 0);
2871 arg_symbol (1) = ref (1) -> reference.symbol;
2872
2873 arg_number = 2;
2874 string (rtype) = char_type;
2875
2876 goto repeat;
2877
2878 action (61):
2879
2880 go to prepare_pointer;
2881
2882 action (62):
2883
2884 string (rtype) = integer_type;
2885 rprecision = 71;
2886 go to create_operator_node;
2887
2888 action (63):
2889
2890 go to prepare_pointer;
2891
2892 action (66):
2893 string (rtype) = bit_mask;
2894 rprecision = 1;
2895 go to create_operator_node;
2896
2897 action (67):
2898 go to err359;
2899
2900 action (68):
2901 string (rtype) = char_type;
2902 rprecision = 1;
2903 go to create_operator_node;
2904
2905 action (69):
2906 if ^constant_length (ref (1), 1) then
2907 call semantic_translator$abort (390, arg_symbol (1));
2908
2909
2910 string (rtype) = integer_type;
2911 rprecision = 9;
2912 go to create_operator_node;
2913 ^L
2914 prepare_pointer:
2915 rprecision, rscale = 0;
2916
2917 rlength = null;
2918
2919 string (rtype) = pointer_type;
2920
2921 goto create_operator_node;
2922
2923 create_call:
2924 p = create_list (arg_number + 1);
2925 do i = 1 to arg_number;
2926 p -> element (i) = arg (i);
2927 end;
2928
2929 tree = create_operator (std_call, 3);
2930 tree -> operand (2) = reserve$declare_lib ((reserved_number));
2931
2932 if jump_index = 24 | jump_index = 25 | jump_index = 26
2933 then do;
2934 tree -> operand (2) -> reference.symbol -> symbol.irreducible = "0"b;
2935 tree -> operand (2) -> reference.symbol -> symbol.reducible = "1"b;
2936 end;
2937
2938 tree -> operand (3) = create_operator (std_arg_list, 3);
2939 tree -> operand (3) -> operand (2) = p;
2940
2941 if desc_reqd then do;
2942
2943
2944
2945 tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, 4 * arg_number + 6, 0, null);
2946 q, tree -> operand (3) -> operand (3) = create_list (arg_number + 1);
2947
2948 s = create_symbol (cur_block, null, by_compiler);
2949
2950 string (s -> symbol.data_type) = string (arg_symbol (1) -> symbol.data_type);
2951 string (s -> symbol.misc_attributes) = string (arg_symbol (1) -> symbol.misc_attributes);
2952
2953 s -> symbol.dimensioned, s -> symbol.initialed, s -> symbol.variable, s -> symbol.position,
2954 s -> symbol.internal, s -> symbol.external, s -> symbol.like, s -> symbol.member = "0"b;
2955
2956 s -> symbol.return_value, s -> symbol.passed_as_arg, s -> symbol.star_extents = "1"b;
2957
2958 s -> symbol.dcl_size = create_token ("*", asterisk);
2959
2960 call declare (s);
2961
2962 q -> element (arg_number + 1) = s -> symbol.descriptor;
2963
2964 do i = 1 to arg_number;
2965 q -> element (i) =
2966 declare_descriptor (cur_block, statement_ptr, arg_symbol (i), (ref (i) -> reference.qualifier),
2967 "0"b);
2968 end;
2969
2970 p -> element (p -> list.number), tree -> operand (1) = s -> symbol.reference;
2971
2972 tree -> operand (1) -> reference.ref_count = 3;
2973 tree -> operand (1) -> reference.shared = "0"b;
2974 tree -> operand (1) -> reference.length -> operand (1) =
2975 declare_temporary (integer_type, max_offset_precision, 0, null);
2976 tree -> operand (1) -> reference.length -> operator.processed = "1"b;
2977
2978 call check_star_extents ((tree -> operand (2) -> reference.symbol), p);
2979
2980 statement_ptr -> statement.force_nonquick = "1"b;
2981 call make_non_quick ((statement_ptr -> statement.root), "001"b);
2982
2983 p = create_statement (call_statement, (statement_ptr -> statement.back), null,
2984 (statement_ptr -> statement.prefix));
2985 p -> statement.root = tree;
2986 p -> statement.processed = "1"b;
2987 end;
2988 else do;
2989 t = declare_temporary (string (rtype), rprecision, (rscale), rlength);
2990 s = copy_expression (t -> reference.symbol);
2991 s -> symbol.passed_as_arg = "1"b;
2992 q = s -> symbol.reference;
2993 q -> reference.shared = "0"b;
2994 q -> reference.ref_count = 2;
2995
2996 p -> element (p -> list.number), tree -> operand (1) = q;
2997
2998 temp_size = 2 * (arg_number + 1) + 2;
2999
3000 if jump_index = 26 then do;
3001
3002
3003
3004 temp_size = 4 * (arg_number + 1) + 2;
3005
3006 tree -> operand (3) -> operand (3), q = create_list (arg_number + 1);
3007
3008 ref (5) = q;
3009 arg_symbol (5) = s;
3010
3011 do i = 1 to q -> list.number;
3012 q -> element (i) =
3013 declare_descriptor (cur_block, statement_ptr, arg_symbol (i),
3014 (ref (i) -> reference.qualifier), (ref (i) -> reference.array_ref));
3015 end;
3016 end;
3017
3018 tree -> operand (3) -> operand (1) = declare_temporary (storage_block_type, temp_size, 0, null);
3019 end;
3020
3021 if def_context.left_side then do;
3022 if jump_index = 51 then
3023 reserved_number = 11;
3024 else
3025 reserved_number = 194;
3026
3027 tree -> operand (2) -> reference.symbol -> symbol.irreducible = "1"b;
3028 t = tree;
3029
3030 goto make_call;
3031 end;
3032
3033 goto exit;
3034
3035 create_assign:
3036 t = create_operator (assign, 2);
3037 t -> operand (1) = declare_temporary (integer_type, max_offset_precision, 0, null);
3038 t -> operand (2) = arg (1);
3039
3040 tree = t;
3041
3042 goto exit;
3043
3044 convert_to_arith:
3045 arith_size_ck = "1"b;
3046 string (rtype) = string (rtype) | aligned_mask;
3047
3048 if arg_type (1).char then
3049 defined_arg_type (1) = fixed_decimal_real_mask;
3050 else if arg_type (1).bit then
3051 defined_arg_type (1) = fixed_binary_real_mask;
3052 else if arg_type (1).picture then
3053 if arg_symbol (1) -> symbol.complex then
3054 if arg_symbol (1) -> symbol.pix.pic_float then
3055 defined_arg_type (1) = float_decimal_complex_mask;
3056 else
3057 defined_arg_type (1) = fixed_decimal_complex_mask;
3058 else if arg_symbol (1) -> symbol.pix.pic_float then
3059 defined_arg_type (1) = float_decimal_real_mask;
3060 else
3061 defined_arg_type (1) = fixed_decimal_real_mask;
3062
3063 if ^rtype.fixed & ^rtype.float then do;
3064 rtype.fixed = arg_type (1).fixed;
3065 rtype.float = arg_type (1).float;
3066 end;
3067
3068 if ^rtype.decimal & ^rtype.binary then do;
3069 rtype.decimal = arg_type (1).decimal;
3070 rtype.binary = arg_type (1).binary;
3071 end;
3072
3073 if ^rtype.real & ^rtype.complex then do;
3074 rtype.real = arg_type (1).real;
3075 rtype.complex = arg_type (1).complex;
3076 end;
3077
3078 full_attribute_set = arg_number > 1;
3079
3080 check_prec_scale:
3081 rlength = null;
3082
3083 if rscale < min_scale | rscale > max_scale then
3084 goto err146;
3085
3086 if rtype.decimal then
3087 if rprecision > max_p_dec then
3088 goto err146;
3089 else
3090 ;
3091
3092 else if rtype.fixed then
3093 if rprecision > max_p_fix_bin_2 then
3094 goto err146;
3095 else
3096 ;
3097 else if rprecision > max_p_flt_bin_2 then
3098 goto err146;
3099
3100 convert_label:
3101 if rprecision < 0 then
3102 goto err481;
3103
3104 if full_attribute_set then do;
3105 t = declare_temporary (string (rtype), rprecision, (rscale), rlength);
3106 tree = convert$to_target_fb (arg (1), t);
3107 end;
3108 else
3109 tree = convert$from_builtin (arg (1), string (rtype));
3110
3111 goto ret;
3112
3113 create_operator_node:
3114 if rprecision < 0 then
3115 goto err481;
3116
3117 t = declare_temporary (string (rtype), rprecision, (rscale), rlength);
3118
3119 tree = create_operator (opcode, arg_number + 1);
3120 tree -> operand (1) = t;
3121
3122 do i = 1 to arg_number;
3123 tree -> operand (i + 1) = arg (i);
3124 end;
3125
3126 tree -> operator.processed = "1"b;
3127
3128 goto exit;
3129
3130 return_arg1:
3131 tree = arg (1);
3132
3133 goto ret;
3134 ^L
3135 expand_arguments:
3136 proc () returns (ptr);
3137
3138 dcl (p, q, r) ptr,
3139 (lpp, jpp) ptr init (null),
3140 (lp, jp, cp) (128) ptr init ((128) null),
3141 (i, j, k, lll) fixed bin (15),
3142 (jcount, lcount) fixed bin (15) init (0),
3143 ll (128) fixed bin (15) init ((128) 0);
3144
3145 dcl (full_processing, pure_array) bit (1) aligned init ("0"b);
3146
3147 do i = 1 to arg_number;
3148 p = subscripts -> element (i);
3149
3150 if p -> node.type = operator_node then
3151 if p -> op_code = loop then do;
3152 lp (i) = p;
3153 lcount = lcount + 1;
3154
3155 do q = p repeat q -> operand (1) while (q -> op_code = loop);
3156 ll (i) = ll (i) + 1;
3157 end;
3158
3159 p = q;
3160
3161 if lpp = null then do;
3162 lpp = lp (i);
3163 lll = ll (i);
3164 end;
3165 end;
3166
3167 if p -> node.type = operator_node then
3168 if p -> op_code = join then do;
3169 jp (i) = p;
3170 jcount = jcount + 1;
3171 end;
3172
3173 if jp (i) ^= null then
3174 if jpp = null then
3175 jpp = p;
3176 else
3177 ;
3178 else
3179 cp (i) = p;
3180
3181 if lp (i) ^= null & cp (i) ^= null then
3182 pure_array = "1"b;
3183 end;
3184
3185 if lpp ^= null then
3186 do i = 1 to arg_number;
3187 if ll (i) ^= lll & ll (i) ^= 0 then
3188 call semantic_translator$abort (79, null);
3189 end;
3190
3191 if pure_array then
3192 if jpp ^= null then
3193 call semantic_translator$abort (79, null);
3194 else do;
3195 p = create_list ((arg_number));
3196 do i = 1 to arg_number;
3197 p -> element (i) = cp (i);
3198 end;
3199
3200 p = builtin (cur_block, statement_ptr, tree, p, builtin_symbol, "0"b);
3201 end;
3202
3203 if jpp ^= null then
3204 jpp = merge (jpp, jp);
3205
3206 if lpp = null then
3207 return (jpp);
3208
3209 q = lpp;
3210
3211 do i = 2 to lll;
3212 q = q -> operand (1);
3213 end;
3214
3215 if jpp ^= null then
3216 q -> operand (1) = jpp;
3217 else
3218 q -> operand (1) = p;
3219
3220 if lcount = 1 then
3221 return (lpp);
3222
3223 do i = 1 to arg_number;
3224
3225 p = lpp;
3226 q = lp (i);
3227
3228 if q ^= null & q ^= p then
3229 do j = 1 to lll;
3230
3231 if ^compare_expression ((p -> operand (4)), (q -> operand (4))) then do;
3232 if p -> operand (4) -> node.type = reference_node then
3233 if p -> operand (4) -> reference.symbol -> symbol.constant then
3234 if q -> operand (4) -> node.type = reference_node then
3235 if q -> operand (4) -> reference.symbol -> symbol.constant then
3236 call semantic_translator$abort (79, null);
3237
3238 full_processing = "1"b;
3239 end;
3240
3241 p = p -> operand (1);
3242 q = q -> operand (1);
3243 end;
3244 end;
3245
3246 if ^full_processing then
3247 return (lpp);
3248
3249 if lcount = 2 then do;
3250 p = lpp;
3251 q = null;
3252
3253 do i = arg_number to 1 by -1 while (q = null);
3254 q = lp (i);
3255 end;
3256
3257 do i = 1 to lll;
3258
3259 jpp = create_operator (bound_ck, 4);
3260 jpp -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
3261 jpp -> operand (2) = p -> operand (4);
3262 jpp -> operand (3) = q -> operand (4);
3263 jpp -> operand (4) = share_expression ((q -> operand (4)));
3264
3265 p -> operand (4) = jpp;
3266 p = p -> operand (1);
3267 q = q -> operand (1);
3268 end;
3269
3270 return (lpp);
3271 end;
3272
3273 r = lpp;
3274
3275 do i = 1 to lll;
3276
3277 jpp = create_operator (bound_ck, 4);
3278 p = create_operator (min_fun, lcount + 1);
3279 q = create_operator (max_fun, lcount + 1);
3280 p -> operand (1), q -> operand (1), jpp -> operand (1) =
3281 declare_temporary (integer_type, default_fix_bin_p, 0, null);
3282 jpp -> operand (2) = p;
3283 jpp -> operand (3) = q;
3284 jpp -> operand (4) = share_expression (q);
3285
3286 r -> operand (4) = jpp;
3287 r = r -> operand (1);
3288
3289 k = 2;
3290
3291 do j = 1 to arg_number;
3292 if lp (j) ^= null then do;
3293 p -> operand (k) = share_expression ((lp (j) -> operand (4)));
3294 q -> operand (k) = share_expression ((lp (j) -> operand (4)));
3295
3296 k = k + 1;
3297 lp (j) = lp (j) -> operand (1);
3298 end;
3299 end;
3300 end;
3301
3302 return (lpp);
3303 ^L
3304 merge:
3305 proc (p, rp) returns (ptr);
3306
3307 dcl (
3308 p,
3309 pp,
3310 q,
3311 o1,
3312 o2,
3313 o3,
3314 rp (128),
3315 rpp (128)
3316 ) ptr,
3317 (i, j, k) fixed bin (15),
3318 unmatch_bound bit (1) aligned init ("0"b);
3319
3320 if p -> node.type = operator_node then do;
3321 if p -> op_code = loop then do;
3322 do i = 1 to arg_number;
3323 if cp (i) = null then do;
3324 if rp (i) -> node.type ^= operator_node then
3325 call semantic_translator$abort (79, null);
3326 if rp (i) -> op_code ^= loop then
3327 call semantic_translator$abort (79, null);
3328
3329 if ^compare_expression ((p -> operand (4)), (rp (i) -> operand (4))) then
3330 unmatch_bound = "1"b;
3331 end;
3332 end;
3333
3334 if unmatch_bound then do;
3335 o1 = create_operator (bound_ck, 4);
3336 o2 = create_operator (min_fun, jcount + 1);
3337 o3 = create_operator (max_fun, jcount + 1);
3338
3339 o2 -> operand (1), o3 -> operand (1), o1 -> operand (1) =
3340 declare_temporary (integer_type, default_fix_bin_p, 0, null);
3341 o1 -> operand (2) = o2;
3342 o1 -> operand (3) = o3;
3343 o1 -> operand (4) = share_expression (o3);
3344
3345 k = 2;
3346
3347 do i = 1 to arg_number;
3348 if cp (i) = null then do;
3349 o2 -> operand (k) = share_expression ((rp (i) -> operand (4)));
3350 o3 -> operand (k) = share_expression ((rp (i) -> operand (4)));
3351 k = k + 1;
3352 end;
3353 end;
3354
3355 p -> operand (4) = o1;
3356 end;
3357
3358 pp = p -> operand (1);
3359
3360 do i = 1 to arg_number;
3361 if cp (i) = null then
3362 rpp (i) = rp (i) -> operand (1);
3363 end;
3364
3365 p -> operand (1) = merge (pp, rpp);
3366
3367 return (p);
3368 end;
3369
3370 if p -> op_code = join then do;
3371 do i = 1 to arg_number;
3372 if cp (i) = null then do;
3373 if rp (i) -> node.type ^= operator_node then
3374 call semantic_translator$abort (79, null);
3375 if rp (i) -> op_code ^= join then
3376 call semantic_translator$abort (79, null);
3377 end;
3378 end;
3379
3380 do j = 1 to p -> operator.number;
3381 pp = p -> operand (j);
3382
3383 do i = 1 to arg_number;
3384 if cp (i) = null then
3385 rpp (i) = rp (i) -> operand (j);
3386 else if j > 1 then
3387 cp (i) = share_expression (cp (i));
3388 end;
3389
3390 p -> operand (j) = merge (pp, rpp);
3391 end;
3392
3393 return (p);
3394 end;
3395 end;
3396
3397 do i = 1 to arg_number;
3398 if cp (i) = null then
3399 if rp (i) -> node.type = operator_node then
3400 if rp (i) -> op_code = loop | rp (i) -> op_code = join then
3401 call semantic_translator$abort (79, null);
3402 end;
3403
3404 q = create_list ((arg_number));
3405
3406 do i = 1 to arg_number;
3407 if cp (i) = null then
3408 q -> element (i) = rp (i);
3409 else
3410 q -> element (i) = cp (i);
3411 end;
3412
3413 return (builtin (cur_block, statement_ptr, tree, q, builtin_symbol, "0"b));
3414
3415 end merge;
3416
3417 end expand_arguments;
3418 ^L
3419 check_reverse:
3420 proc (p) returns (bit (1) aligned);
3421
3422
3423 dcl p ptr;
3424
3425 if p -> node.type = operator_node then
3426 if p -> operator.op_code = reverse_fun then
3427 if p -> operator.operand (1) -> reference.shared
3428 | p -> operator.operand (1) -> reference.ref_count = 1 then
3429 return ("1"b);
3430 return ("0"b);
3431
3432 end check_reverse;
3433 ^L
3434 is_this_constant:
3435 proc (p) returns (bit (1) aligned);
3436
3437 dcl p ptr;
3438
3439 if p -> node.type = reference_node then
3440 if p -> reference.symbol -> symbol.constant then
3441 if ^p -> reference.varying_ref then
3442 if p -> reference.length = null & p -> reference.offset = null & p -> reference.c_offset = 0 then
3443 return ("1"b);
3444 return ("0"b);
3445
3446 end is_this_constant;
3447 ^L
3448 check_strings:
3449 proc (pt);
3450
3451 dcl (p, pt) ptr;
3452
3453 p = pt;
3454
3455 do while (p ^= null);
3456
3457 if p -> symbol.structure then
3458 call check_strings ((p -> symbol.son));
3459
3460 else if units = bit_ & ^p -> symbol.bit | units = character_ & ^p -> symbol.char & ^p -> symbol.picture
3461 then
3462 call semantic_translator$abort (139, arg_symbol (1));
3463
3464 p = p -> symbol.brother;
3465 end;
3466
3467 end check_strings;
3468 ^L
3469 convert_arg:
3470 proc;
3471
3472 dcl suppress_diagnostic bit (1) aligned;
3473
3474 if defined_arg_type (i) & structure_mask then
3475 return;
3476
3477 if string (type) & arithmetic_mask then do;
3478 if defined_arg_type (i) & arithmetic_mask then
3479 ;
3480 else if arg_type (i).bit then do;
3481 type.fixed = ^type.float;
3482 type.binary = ^type.decimal;
3483 type.real = ^type.complex;
3484 end;
3485
3486 else if arg_type (i).char then do;
3487 type.fixed = ^type.float;
3488 type.decimal = ^type.binary;
3489 type.real = ^type.complex;
3490 end;
3491
3492 if ^type.fixed & ^type.float then do;
3493 type.fixed = arg_type (i).fixed;
3494 type.float = arg_type (i).float;
3495 end;
3496
3497 if ^type.decimal & ^type.binary then do;
3498 type.decimal = arg_type (i).decimal;
3499 type.binary = arg_type (i).binary;
3500 end;
3501
3502 if ^type.real & ^type.complex then do;
3503 type.real = arg_type (i).real;
3504 type.complex = arg_type (i).complex;
3505 end;
3506 end;
3507
3508 suppress_diagnostic = i = 1 & (jump_index = 17 | jump_index = 19);
3509
3510 if arg (i) -> node.type = token_node then
3511 if suppress_diagnostic then
3512 arg (i) = convert$from_builtin (arg (i), string (type));
3513 else
3514 arg (i) = convert (arg (i), string (type));
3515
3516 else if type.decimal & arg_type (i).decimal & ^arg_symbol (i) -> symbol.char then
3517 ;
3518 else if type.binary & arg_type (i).binary & type.real = arg_type (i).real & type.fixed = arg_type (i).fixed then
3519 ;
3520 else if suppress_diagnostic then
3521 arg (i) = convert$from_builtin (arg (i), string (type));
3522 else
3523 arg (i) = convert (arg (i), string (type));
3524
3525 ref (i) = arg (i);
3526 defined_arg_type (i) = string (type);
3527
3528 if ref (i) -> node.type = operator_node then do;
3529 ref (i) -> operator.processed = "1"b;
3530 ref (i) = ref (i) -> operand (1);
3531 end;
3532
3533 arg_symbol (i) = ref (i) -> reference.symbol;
3534
3535 end convert_arg;
3536 ^L
3537 make_assignment:
3538 proc;
3539
3540 p = create_operator (assign, 2);
3541 r = create_symbol (null, null, by_compiler);
3542 r -> symbol.temporary = "1"b;
3543 p -> operand (1) = r -> symbol.reference;
3544 p -> operand (2) = arg (1);
3545
3546 r = create_statement (assignment_statement, (statement_ptr -> statement.back), null,
3547 (statement_ptr -> statement.prefix));
3548 r -> statement.root = p;
3549 r -> statement.generated = "1"b;
3550
3551 if arg (1) -> node.type = operator_node then
3552 if arg (1) -> operator.op_code = loop | arg (1) -> operator.op_code = join then do;
3553 def_this_context.RHS_aggregate = "1"b;
3554
3555 r -> statement.root = expand_assign (cur_block, r, (r -> statement.root), this_context, agg_ref);
3556 return;
3557 end;
3558
3559 r -> statement.root = operator_semantics (cur_block, r, (r -> statement.root), this_context);
3560 agg_ref = r -> statement.root -> operand (1);
3561 if agg_ref -> reference.shared then do;
3562 agg_ref -> reference.shared = "0"b;
3563 agg_ref -> reference.ref_count = 1;
3564 end;
3565
3566 end make_assignment;
3567
3568
3569 declare_defined_overlay:
3570 proc (p_type, p_precision, p_scale, p_length, qual) returns (ptr);
3571
3572
3573
3574
3575 dcl p_type bit (36) aligned,
3576 (p_precision, precision) fixed bin (31),
3577 (p_scale, scale) fixed bin (15),
3578 (p_length, length) ptr,
3579 qual ptr;
3580
3581 dcl units fixed bin (3);
3582 dcl c_offset fixed bin (24);
3583 dcl (r, s, t) ptr;
3584 dcl pl1_stat_$defined_list ptr ext;
3585 dcl (addr, null) builtin;
3586 dcl bit36 bit (36) based (addr (s -> symbol.data_type));
3587 dcl found bit (1) aligned;
3588
3589
3590
3591
3592
3593 precision = p_precision;
3594 scale = p_scale;
3595 length = p_length;
3596
3597
3598
3599
3600 if qual -> node.type = reference_node then do;
3601 units = qual -> reference.units;
3602 c_offset = qual -> reference.c_offset;
3603 end;
3604 else
3605 units, c_offset = 0;
3606
3607 found = "0"b;
3608
3609
3610
3611 s = pl1_stat_$defined_list;
3612
3613 do while (s ^= null & ^found);
3614 if bit36 = p_type & s -> symbol.position = "1"b & s -> symbol.c_dcl_size = precision
3615 & s -> symbol.scale = scale & s -> symbol.dcl_size = length
3616 & s -> symbol.reference -> reference.shared & s -> symbol.reference -> reference.c_offset = c_offset
3617 & s -> symbol.reference -> reference.units = units then
3618 found = "1"b;
3619 else
3620 s = s -> symbol.multi_use;
3621 end;
3622
3623 if ^found then do;
3624
3625
3626 Note
3627
3628
3629 r = copy_expression (declare_temporary (p_type, precision, scale, length));
3630
3631 s = create_symbol (null, null, by_compiler);
3632 t = r -> reference.symbol;
3633 s -> symbol = t -> symbol;
3634 s -> symbol.next = null;
3635 s -> symbol.reference = r;
3636 r -> reference.symbol = s;
3637 r -> reference.units = units;
3638 r -> reference.c_offset = c_offset;
3639
3640 s -> symbol.packed = s -> symbol.unaligned;
3641 s -> symbol.defined, s -> symbol.overlayed, s -> symbol.position = "1"b;
3642 s -> symbol.temporary = "0"b;
3643
3644 s -> symbol.multi_use = pl1_stat_$defined_list;
3645 pl1_stat_$defined_list = s;
3646 end;
3647
3648
3649
3650 r = copy_expression (s -> symbol.reference);
3651 r -> reference.shared = "0"b;
3652 r -> reference.ref_count = 1;
3653 r -> reference.units = 0;
3654 r -> reference.c_offset = 0;
3655
3656 return (r);
3657
3658 end;
3659
3660
3661
3662 create_length_fun:
3663 proc (op2) returns (ptr);
3664
3665 dcl (op2, p) pointer;
3666 p = create_operator (length_fun, 2);
3667 p -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
3668 p -> operand (2) = share_expression (op2);
3669 p -> operator.processed = "1"b;
3670 return (p);
3671 end create_length_fun;
3672
3673
3674
3675
3676
3677
3678
3679
3680 reuse_qual_and_offset:
3681 proc (p_param);
3682
3683 dcl (p, p_param) ptr;
3684
3685 p = p_param;
3686
3687 if p -> reference.qualifier ^= null then
3688 p -> reference.qualifier = share_expression ((p -> reference.qualifier));
3689 if p -> reference.offset ^= null then
3690 p -> reference.offset = share_expression ((p -> reference.offset));
3691
3692 end reuse_qual_and_offset;
3693
3694
3695
3696
3697 fb1_value:
3698 proc (s) returns (bit (1) aligned);
3699
3700 dcl s ptr;
3701
3702 if s -> symbol.fixed & s -> symbol.binary & ^s -> symbol.complex & ^s -> symbol.packed
3703 & s -> symbol.c_dcl_size <= max_p_fix_bin_1 & s -> symbol.scale = 0 then
3704 return ("1"b);
3705
3706 else
3707 return ("0"b);
3708
3709 end fb1_value;
3710
3711
3712
3713
3714 create_index_or_verify:
3715 proc returns (ptr);
3716
3717 dcl p ptr;
3718
3719 p = create_operator (opcode, 3);
3720 p -> operand (1) = declare_temporary (fixed_binary_real_mask, max_length_precision, 0, null);
3721 p -> operand (2) = share_expression (arg (1));
3722 p -> operand (3) = arg (2);
3723 p -> operator.processed = "1"b;
3724 return (p);
3725
3726 end create_index_or_verify;
3727
3728
3729
3730 constant_value:
3731 procedure (sym_ptr) returns (fixed bin (17));
3732
3733
3734
3735 dcl sym_ptr ptr;
3736
3737
3738
3739 dcl integer_1 based fixed bin (35);
3740 dcl integer_2 based fixed bin (71);
3741
3742
3743
3744 dcl max_24_bit_integer fixed bin (24) int static options (constant) init (111111111111111111111111b);
3745
3746
3747
3748 dcl abs builtin;
3749
3750
3751
3752 dcl initial_value fixed bin (71);
3753
3754 dcl convert builtin;
3755
3756
3757
3758 if sym_ptr -> symbol.constant then
3759 if sym_ptr -> symbol.c_dcl_size > max_p_fix_bin_1 then
3760 initial_value = sym_ptr -> symbol.initial -> integer_2;
3761 else
3762 initial_value = sym_ptr -> symbol.initial -> integer_1;
3763
3764
3765
3766 else if sym_ptr -> symbol.alloc_in_text then
3767 if sym_ptr -> symbol.initial -> list.element (1) -> token.string = "1" then
3768 initial_value =
3769 convert (initial_value, sym_ptr -> symbol.initial -> list.element (2) -> token.string);
3770
3771 else
3772 initial_value = max_24_bit_integer + 1;
3773 else
3774 initial_value = max_24_bit_integer + 1;
3775
3776 if abs (initial_value) > max_24_bit_integer then
3777 go to err146;
3778
3779 return (initial_value);
3780
3781 end ;
3782
3783
3784
3785 symbol_is_constant:
3786 proc (sym_ptr) returns (bit (1));
3787
3788 dcl sym_ptr ptr;
3789
3790 if sym_ptr -> symbol.constant | (sym_ptr -> symbol.alloc_in_text & sym_ptr -> symbol.array = null ()) then
3791 return ("1"b);
3792 else
3793 return ("0"b);
3794 end symbol_is_constant;
3795 make_builtin_reference:
3796 proc (builtin_name, nargs, arg1, arg2, arg3) returns (ptr);
3797
3798
3799
3800
3801 dcl builtin_name char (*),
3802 nargs fixed bin (15),
3803 (arg1, arg2, arg3) ptr;
3804
3805 dcl (p, s, subs) ptr;
3806 dcl (i, n) fixed bin (15);
3807
3808
3809
3810
3811 n = nargs;
3812 p = create_token ("cp.bif." || builtin_name, identifier);
3813
3814 if p -> token.declaration = null then do;
3815
3816
3817
3818 do i = number_of_names to 1 by -1 while (pl1_data$builtin_name (i).name ^= builtin_name);
3819 end;
3820
3821 s = create_symbol ((pl1_stat_$root), p, by_compiler);
3822
3823 s -> symbol.builtin = "1"b;
3824 s -> symbol.c_dcl_size = i;
3825 p -> token.declaration = s;
3826 end;
3827
3828 else
3829 s = p -> token.declaration;
3830
3831 subs = create_list (n);
3832 if n > 0 then do;
3833 subs -> element (n) = arg1;
3834 if n > 1 then do;
3835 subs -> element (n - 1) = arg2;
3836 if n > 2 then
3837 subs -> element (n - 2) = arg3;
3838 end;
3839 end;
3840
3841 return (builtin (cur_block, statement_ptr, (s -> symbol.reference), subs, s, context));
3842
3843 end;
3844
3845
3846 err124:
3847 error_number = 124;
3848 goto abort;
3849
3850 err146:
3851 error_number = 146;
3852 goto abort;
3853
3854 err481:
3855 error_number = 481;
3856 goto abort;
3857
3858 err359:
3859 error_number = 359;
3860 goto abort;
3861
3862 err381:
3863 error_number = 381;
3864 goto abort;
3865
3866 abort:
3867 call semantic_translator$abort (error_number, builtin_symbol);
3868
3869 ret:
3870 if def_context.arg_list & tree -> node.type = reference_node & ^pseudo_variable then do;
3871 arg (1) = tree;
3872 string (rtype) = string (tree -> reference.symbol -> symbol.attributes);
3873 if jump_index ^= 46 then
3874 rtype.varying = "0"b;
3875 arg_number = 1;
3876 opcode = assign;
3877 goto create_operator_node;
3878 end;
3879
3880 if arith_size_ck then
3881
3882
3883
3884 if substr (statement_ptr -> statement.prefix, 6, 1) then
3885 if arg_type (1).fixed | arg_type (1).float then
3886 if tree -> node.type = operator_node then
3887 if tree -> operator.op_code = assign then
3888 tree -> operator.op_code = assign_size_ck;
3889
3890 if string_size_ck then
3891 if substr (statement_ptr -> statement.prefix, 9, 1) then
3892 if arg_type (1).char | arg_type (1).bit then
3893 if tree -> node.type = operator_node then
3894 if tree -> operator.op_code = assign then
3895 tree -> operator.op_code = assign_size_ck;
3896
3897 exit:
3898 if decimal_result then do;
3899 targ_type = targ_type & ^dimensioned_mask & ^initialed_mask;
3900 t = declare_temporary (targ_type, targ_prec, 0, null);
3901 tree = convert$to_target_fb (tree, t);
3902 end;
3903
3904 if tree -> node.type = operator_node then
3905 tree -> operator.processed = "1"b;
3906 else
3907 tree -> reference.processed = "1"b;
3908
3909 return (tree);
3910
3911
3912
3913 %include semant;
3914 %include array;
3915 %include block;
3916 %include boundary;
3917 %include builtin_table;
3918 %include cross_reference;
3919 %include decoded_token_types;
3920 %include declare_type;
3921 %include label;
3922 %include list;
3923 %include mask;
3924 %include nodes;
3925 %include operator;
3926 %include op_codes;
3927 %include reference;
3928 %include semantic_bits;
3929 %include statement;
3930 %include statement_types;
3931 %include symbol;
3932 %include pl1_symbol_type;
3933 %include symbol_bits;
3934 %include system;
3935 %include token;
3936 %include token_types;
3937
3938 end builtin;