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 expand_assign:
32 proc (blk, stmnt, input_tree, context, agg_ref) returns (ptr);
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48 dcl (agg_ref, blk, stmnt, tree, input_tree, a, b, s, sa, sb, t, p, q, qual, aqual, bqual) ptr,
49 (a_for_return, sa_for_return) ptr,
50 image ptr init (null);
51
52 dcl k fixed bin (15),
53 constant fixed bin,
54 (have_varying, modified) bit (1) aligned,
55 (cross_section, doing_return, no_data_type, interleaved) bit (1) init ("0"b) aligned;
56
57 dcl based_integer fixed bin (15) based;
58
59 dcl pl1_stat_$locator (128) ptr ext static;
60 dcl pl1_stat_$index fixed bin (15) ext static;
61
62 dcl (addr, string, fixed, hbound, null, substr) builtin;
63 %page;
64 s = stmnt;
65 tree = input_tree;
66
67 a = tree -> operand (1);
68 b = tree -> operand (2);
69
70 if a -> node.type ^= reference_node then
71 if a -> node.type = operator_node then
72 if a -> op_code = loop | a -> op_code = join then
73 goto infix;
74 else
75 call semantic_translator$abort (90, null);
76 else
77 call semantic_translator$abort (90, null);
78
79 sa = a -> reference.symbol;
80
81 if sa -> node.type ^= symbol_node then
82 call semantic_translator$abort (91, null);
83
84 if sa -> symbol.constant then
85 call semantic_translator$abort (91, null);
86
87 if a -> reference.array_ref then do;
88 if sa -> symbol.array -> array.interleaved then
89 interleaved = "1"b;
90
91 if a -> reference.offset ^= null then
92 if a -> reference.offset -> node.type = list_node then
93 cross_section = "1"b;
94 end;
95
96 if ^a -> reference.array_ref & ^sa -> symbol.structure & string (sa -> symbol.data_type) ^= "0"b then
97 call semantic_translator$abort (93, b);
98
99 if b -> node.type
100 =
101 token_node
102
103 then
104 b = convert (b, decoded_type (fixed (b -> token.type, 9)));
105
106 if b -> node.type = reference_node then do;
107 sb = b -> reference.symbol;
108 qual = b -> reference.qualifier;
109
110 if b -> reference.array_ref then do;
111
112 if sb -> node.type = label_node then
113 call semantic_translator$abort (83, b);
114 else if sb -> node.type ^= symbol_node then
115 call semantic_translator$abort (195, null);
116
117
118 if b -> reference.offset ^= null then
119 if b -> reference.offset -> node.type = list_node then
120 cross_section = "1"b;
121
122 if sb -> symbol.array -> array.interleaved then
123 interleaved = "1"b;
124 end;
125 end;
126
127 if ^def_context.RHS_aggregate then
128 goto check_context;
129
130 if b -> node.type ^= reference_node then
131 if b -> op_code = loop | b -> op_code = join then
132 sb, qual = null;
133 else do;
134
135
136
137
138
139
140 tree -> operand (2), b = b -> operand (1);
141 sb = b -> reference.symbol;
142 end;
143
144 if stmnt -> statement.LHS_in_RHS then do;
145 stmnt -> statement.LHS_in_RHS = "0"b;
146
147
148 s = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
149
150
151 q = create_operator (assign, 2);
152 p = create_symbol (null, null, by_compiler);
153 p -> symbol.temporary = "1"b;
154 q -> operand (1) = p -> symbol.reference;
155 q -> operand (2) = b;
156
157 s -> statement.root = expand_assign (blk, s, q, context, image);
158
159
160 b, tree -> operand (2) = image;
161 sb = b -> reference.symbol;
162 end;
163
164
165
166
167 if string (sa -> symbol.data_type) = "0"b then do;
168 no_data_type = "1"b;
169
170
171 if sb = null then
172 sb = declare_expression (b, null, 1);
173
174 call maker (sb, sb, sa, "1"b, 1, b);
175
176 tree -> operand (1), agg_ref, a = copy_expression (sa -> symbol.reference);
177
178 if b -> node.type = reference_node then
179 a -> reference.array_ref = b -> reference.array_ref;
180 end;
181
182 check_context:
183 if def_context.arg_list | def_context.return then do;
184 if ^sa -> symbol.star_extents then do;
185 qual = a -> reference.qualifier;
186 call maker (sa, sa, t, "0"b, 1, null);
187 end;
188 else do;
189 if b -> node.type = operator_node then
190 if b -> operator.op_code ^= loop & b -> operator.op_code ^= join then do;
191
192
193
194 b = b -> operand (1);
195 sb = b -> reference.symbol;
196 end;
197
198 if sb = null then
199 sb = declare_expression (b, null, 1);
200
201
202 doing_return = def_context.return;
203 call maker (sa, sb, t, "0"b, 1, b);
204
205 end;
206
207 a_for_return = a;
208 sa_for_return = sa;
209
210 tree -> operand (1), agg_ref, a = copy_expression (t -> symbol.reference);
211
212 sa = t;
213
214 a -> reference.shared = "0"b;
215 a -> reference.ref_count = 2;
216
217 s = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
218 end;
219 else
220 s = stmnt;
221
222 if ^def_context.RHS_aggregate | def_context.by_name_assignment then
223 goto infix;
224
225 if b -> node.type ^= reference_node | cross_section | interleaved then
226 goto infix;
227
228 if ^compare_declaration (a, (b -> reference.symbol), "0"b) then
229 goto infix;
230
231
232 if sa -> symbol.defined | sb -> symbol.defined then
233 goto infix;
234
235 if a -> reference.array_ref ^= b -> reference.array_ref then
236 goto infix;
237
238 if a -> reference.array_ref then
239 if substr (stmnt -> statement.prefix, 7, 1) then
240 if sa -> symbol.refer_extents then do;
241 aqual = a -> reference.qualifier;
242 bqual = b -> reference.qualifier;
243 call check_refers (sa, sb);
244 end;
245
246 call process_offset (a);
247 call process_offset (b);
248
249 tree = make_copy (a, b);
250
251 goto ret;
252
253 infix:
254 tree = expand_infix (blk, s, tree, context);
255
256 goto ret;
257 %page;
258 ret:
259 if def_context.arg_list then do;
260 s -> statement.root = tree;
261 return (t -> symbol.reference);
262 end;
263
264 if def_context.return then do;
265 s -> statement.root = tree;
266
267 if sa_for_return -> symbol.star_extents then do;
268 k = 0;
269 call fill_desc (sa);
270
271
272
273
274
275
276
277 a -> reference.length = null;
278
279 return (a);
280 end;
281
282 p = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
283 p -> statement.root, tree = make_copy (a_for_return, a);
284 end;
285
286 return (tree);
287 %page;
288 process_offset:
289 proc (pt);
290
291
292
293 dcl (pt, a, sa, p) ptr;
294 dcl i fixed bin;
295
296 a = pt;
297
298
299
300
301
302
303 a -> reference.length = null;
304
305
306
307 if a -> reference.offset ^= null then
308 if a -> reference.offset -> node.type = list_node then do;
309 p = a -> reference.offset;
310
311 do i = 1 to p -> list.number;
312 if p -> element (i) -> node.type = token_node then
313 if p -> element (i) -> token.type = asterisk then
314 goto infix;
315 end;
316
317 if a -> reference.qualifier ^= null then do;
318 pl1_stat_$index = pl1_stat_$index + 1;
319 if pl1_stat_$index > hbound (pl1_stat_$locator, 1) then
320 call semantic_translator$abort (70, null);
321 pl1_stat_$locator (pl1_stat_$index) = a;
322 end;
323
324 sa = a -> reference.symbol;
325 a -> reference.offset = copy_expression (sa -> symbol.reference -> reference.offset);
326 a = subscripter (blk, s, a, p, sa);
327
328 if a -> reference.offset ^= null then do;
329 a -> reference.offset = expression_semantics (blk, s, (a -> reference.offset), "0"b);
330 a -> reference.offset = convert$to_integer ((a -> reference.offset), integer_type);
331
332 call simplify_offset (a, "0"b);
333 end;
334
335 if a -> reference.qualifier ^= null then
336 pl1_stat_$index = pl1_stat_$index - 1;
337 end;
338
339 end;
340 %page;
341
342
343 check_refers:
344 proc (asym, bsym);
345
346 dcl (asym, bsym, anext, bnext, abound, bbound, p, q) ptr;
347 dcl (own_bounds, processed_bounds) fixed bin;
348
349 if asym -> symbol.array ^= null then do;
350 processed_bounds = 0;
351 bbound = bsym -> symbol.array -> array.bounds;
352 own_bounds = asym -> symbol.array -> own_number_of_dimensions;
353
354 do abound = asym -> symbol.array -> array.bounds repeat abound -> bound.next
355 while (processed_bounds < own_bounds);
356 if is_refer ((abound -> bound.upper)) then
357 if is_refer ((abound -> bound.lower)) then do;
358 p = subtract_bounds (abound);
359 q = subtract_bounds (bbound);
360 call make_check_stmnt (p, q);
361 end;
362 else
363 call make_check_stmnt (copy_expression (abound -> bound.upper),
364 copy_expression (bbound -> bound.upper));
365 else if is_refer ((abound -> bound.lower)) then
366 call make_check_stmnt (copy_expression (abound -> bound.lower),
367 copy_expression (bbound -> bound.lower));
368 processed_bounds = processed_bounds + 1;
369 bbound = bbound -> bound.next;
370 end;
371 end;
372
373 bnext = bsym -> symbol.son;
374
375 do anext = asym -> symbol.son repeat anext -> symbol.brother while (anext ^= null);
376 call check_refers (anext, bnext);
377 bnext = bnext -> symbol.brother;
378 end;
379
380 end;
381 %page;
382
383
384 is_refer:
385 proc (p) returns (bit (1) aligned);
386
387 dcl p ptr;
388
389 if p ^= null then
390 if p -> node.type = operator_node then
391 if p -> operator.op_code = refer then
392 return ("1"b);
393
394 return ("0"b);
395
396 end;
397 %page;
398
399
400 subtract_bounds:
401 proc (p) returns (ptr);
402
403 dcl (p, r) ptr;
404
405 r = create_operator (sub, 3);
406 r -> operator.operand (2) = copy_expression (p -> bound.upper);
407 r -> operator.operand (3) = copy_expression (p -> bound.lower);
408 return (r);
409
410 end;
411 %page;
412
413
414 make_check_stmnt:
415 proc (p, q);
416
417 dcl (p, q, r) ptr;
418
419 r = create_statement (assignment_statement, (stmnt -> statement.back), null, (stmnt -> statement.prefix));
420 r -> statement.root = create_operator (bound_ck, 4);
421 call refer_extent (p, aqual);
422 call refer_extent (q, bqual);
423 r -> statement.root -> operator.operand (2) = p;
424 r -> statement.root -> operator.operand (3) = q;
425 r -> statement.root -> operator.operand (4) = copy_expression ((q));
426 r -> statement.root = expression_semantics (blk, r, (r -> statement.root), "0"b);
427 end;
428 %page;
429
430
431 fill_desc:
432 proc (sp);
433
434 dcl (sp, s, b) ptr;
435
436 s = sp;
437
438 call fill (s);
439
440 if s -> symbol.dimensioned then do;
441 do b = s -> symbol.array -> array.bounds repeat b -> bound.next while (b ^= null);
442 call fill (b);
443 k = k + 3;
444 end;
445 end;
446
447 do b = s -> symbol.son repeat b -> symbol.brother while (b ^= null);
448 k = k + 1;
449 call fill_desc (b);
450 end;
451 %page;
452 fill:
453 proc (pt);
454
455 dcl (pt, p, r, q, dr, size, d_template) ptr;
456 dcl i fixed bin (15);
457
458 %include pl1_descriptor;
459
460 p = pt;
461
462 if p -> node.type = symbol_node then do;
463 d_template =
464 sa_for_return -> symbol.descriptor -> reference.symbol -> symbol.descriptor -> symbol.initial;
465 if s -> symbol.bit | s -> symbol.char then do;
466 r = copy_expression (p -> symbol.reference);
467 r = expression_semantics (blk, stmnt, r, context);
468 if r -> reference.varying_ref then do;
469 if k > 0 | r -> reference.array_ref then do;
470 if p -> symbol.dcl_size = null then
471 size = declare_constant$integer ((p -> symbol.c_dcl_size));
472 else do;
473 size = copy_expression (p -> symbol.dcl_size);
474 if p -> symbol.refer_extents then
475 call refer_extent (size, (a_for_return -> reference.qualifier));
476 size = expression_semantics (blk, stmnt, size, "0"b);
477 end;
478 end;
479 else do;
480 size = create_operator ((length_fun), 2);
481 size -> operand (1) = declare_temporary (integer_type, max_length_precision, 0, null);
482 size -> operand (2) = r;
483 end;
484 end;
485 else if r -> reference.length = null then
486 size = declare_constant$integer ((r -> reference.c_length));
487 else
488 size = r -> reference.length;
489 q = create_operator (make_desc, 3);
490 q -> operand (3) = size;
491 q -> operand (2) = declare_constant$desc (string (d_template -> descriptor (k).bit_type));
492 end;
493 else do;
494 q = create_operator (assign, 2);
495 q -> operand (2) = declare_constant$desc (string (d_template -> descriptor (k)));
496 end;
497 q -> operand (1), r = copy_expression (sa_for_return -> symbol.descriptor);
498 r -> reference.c_offset = k;
499 r -> reference.shared = "0"b;
500 r -> reference.ref_count = 1;
501 r = expression_semantics (blk, stmnt, r, context);
502 dr = create_statement (assignment_statement, (stmnt -> statement.back), null,
503 (stmnt -> statement.prefix));
504 dr -> statement.root = q;
505 end;
506 else do;
507 if p -> bound.lower = null then
508 p -> bound.lower = declare_constant$integer ((p -> bound.c_lower));
509 if p -> bound.upper = null then
510 p -> bound.upper = declare_constant$integer ((p -> bound.c_upper));
511
512 i = 0;
513 do r = p -> bound.lower, p -> bound.upper, p -> bound.desc_multiplier;
514 i = i + 1;
515 q = create_operator (assign, 2);
516 q -> operand (1), dr = copy_expression (sa_for_return -> symbol.descriptor);
517 dr -> reference.units = word_;
518 dr -> reference.c_offset = k + i;
519 r = copy_expression ((r));
520 if s -> symbol.refer_extents then
521 call refer_extent (r, (a_for_return -> reference.qualifier));
522 q -> operand (2) = expression_semantics (blk, stmnt, r, context);
523 dr = create_statement (assignment_statement, (stmnt -> statement.back), null,
524 (stmnt -> statement.prefix));
525 dr -> statement.root = q;
526 end;
527 end;
528
529 end fill;
530
531 end fill_desc;
532 %page;
533
534
535 make_copy:
536 proc (a, b) returns (ptr);
537
538 dcl (a, b, sb, p, q, ref, arrayp) ptr;
539 dcl opcode bit (9) aligned;
540
541
542
543
544
545
546
547
548
549 if b -> reference.symbol -> symbol.dimensioned & ^a -> reference.symbol -> symbol.dimensioned then
550 ref = a;
551 else
552 ref = b;
553
554 sb = ref -> reference.symbol;
555
556 if sb -> symbol.dimensioned then
557 arrayp = sb -> symbol.array;
558 else
559 arrayp = null;
560
561 if sb -> symbol.packed then
562 opcode = copy_string;
563 else
564 opcode = copy_words;
565
566 if arrayp ^= null & ^ref -> reference.array_ref then
567 if sb -> symbol.packed then
568 if arrayp -> array.element_size_bits = null then
569 p = declare_constant$integer ((arrayp -> array.c_element_size_bits));
570 else
571 p = arrayp -> array.element_size_bits;
572 else if arrayp -> array.element_size = null then
573 p = declare_constant$integer ((arrayp -> array.c_element_size));
574 else
575 p = arrayp -> array.element_size;
576
577 else if sb -> symbol.packed then
578 if sb -> symbol.bit_size = null then
579 p = declare_constant$integer ((sb -> symbol.c_bit_size));
580 else
581 p = sb -> symbol.bit_size;
582 else if sb -> symbol.word_size = null then
583 p = declare_constant$integer ((sb -> symbol.c_word_size));
584 else do;
585 p = sb -> symbol.word_size;
586 if sb -> symbol.temporary then
587 sb -> symbol.word_size = expression_semantics (blk, stmnt, copy_expression ((p)), "0"b);
588 end;
589
590 this_context = "0"b;
591 p = copy_expression ((p));
592 if sb -> symbol.refer_extents then
593 call refer_extent (p, (b -> reference.qualifier));
594 p = expression_semantics (blk, stmnt, p, this_context);
595
596 call simplify_expression (p, constant, modified);
597 if modified then
598 p = declare_constant$integer ((constant));
599
600 q = create_operator (opcode, 3);
601 q -> operand (1) = a;
602 q -> operand (2) = b;
603 q -> operand (3) = p;
604
605 return (q);
606
607 end make_copy;
608 %page;
609
610
611 maker:
612 proc (t, e, s, given, level_number, er);
613
614 dcl (s, p, q, f, a, r, t1, e1, s1, eb, subs) ptr;
615 dcl (t, e) ptr;
616 dcl er ptr;
617 dcl (n, i, level_number, sdims) fixed bin (15);
618 dcl (given, refer_extents, have_subs, ignore_e_array) aligned bit (1);
619
620 n = 0;
621 ignore_e_array, have_subs = "0"b;
622 if ^given then
623 s = create_symbol (blk, null, by_compiler);
624 string (s -> symbol.data_type) = string (t -> symbol.data_type);
625 string (s -> symbol.misc_attributes) = string (t -> symbol.misc_attributes);
626 s -> symbol.star_extents, s -> symbol.member, s -> symbol.external, s -> symbol.initialed = "0"b;
627
628 refer_extents = e -> symbol.refer_extents;
629
630 if t -> symbol.array ^= null then
631 if level_number = 1 then do;
632 n, sdims = t -> symbol.array -> array.number_of_dimensions;
633 if er ^= null then
634 if er -> node.type = reference_node then
635 if ^er -> reference.array_ref then
636 if t = e then
637 n, sdims = 0;
638 else
639 ignore_e_array = "1"b;
640 else if er -> reference.offset ^= null then
641 if er -> reference.offset -> node.type = list_node then do;
642 subs = er -> reference.offset;
643 have_subs = "1"b;
644 sdims = 0;
645 end;
646 end;
647
648 else
649 n, sdims = t -> symbol.array -> array.own_number_of_dimensions;
650
651 s -> symbol.dimensioned = (n ^= 0);
652 s -> symbol.block_node = t -> symbol.block_node;
653 s -> symbol.general = t -> symbol.general;
654
655 s -> symbol.pix = t -> symbol.pix;
656
657 s -> symbol.c_dcl_size = t -> symbol.c_dcl_size;
658
659 if t -> symbol.param_desc then
660 if t -> symbol.dcl_size ^= null then
661 if t -> symbol.dcl_size -> node.type = token_node then
662 if t -> symbol.dcl_size -> token.type = asterisk then
663 if e -> symbol.fixed | e -> symbol.float then do;
664 a = convert$from_builtin ((e -> symbol.reference),
665 (substr (string (t -> symbol.attributes), 1, 36) & string_mask));
666 s -> symbol.c_dcl_size =
667 a -> operator.operand (1) -> reference.symbol -> symbol.c_dcl_size;
668 end;
669 else
670 s -> symbol.c_dcl_size = e -> symbol.c_dcl_size;
671
672 if doing_return then
673 if t -> symbol.dcl_size ^= null then
674 if t -> symbol.dcl_size -> node.type = operator_node then
675 if t -> symbol.dcl_size -> operator.op_code = desc_size then
676 if e -> symbol.fixed | e -> symbol.float then do;
677 a = convert$from_builtin ((e -> symbol.reference),
678 (substr (string (t -> symbol.attributes), 1, 36) & string_mask));
679 s -> symbol.c_dcl_size =
680 a -> operator.operand (1) -> reference.symbol -> symbol.c_dcl_size;
681 end;
682 else
683 s -> symbol.c_dcl_size = e -> symbol.c_dcl_size;
684
685 if s -> symbol.entry then
686 s -> symbol.dcl_size = t -> symbol.dcl_size;
687 else do;
688 s -> symbol.dcl_size = e -> symbol.dcl_size;
689 if s -> symbol.dcl_size ^= null then do;
690 s -> symbol.exp_extents = "1"b;
691 if s -> symbol.dcl_size -> node.type = token_node then
692 if s -> symbol.dcl_size -> token.type = dec_integer then
693 s -> symbol.exp_extents = "0"b;
694 end;
695 end;
696
697 if refer_extents then do;
698 r = copy_expression (s -> symbol.dcl_size);
699 call refer_extent (r, qual);
700 s -> symbol.dcl_size = r;
701 end;
702
703 s -> symbol.scale = t -> symbol.scale;
704 s -> symbol.level = level_number;
705
706 if n ^= 0 then do;
707 s -> symbol.array, a = create_array ();
708 p = t -> symbol.array -> array.bounds;
709
710 if ^ignore_e_array then
711 eb = e -> symbol.array;
712 else
713 eb = null;
714
715 if eb ^= null then
716 eb = eb -> array.bounds;
717
718 do i = 1 to n while (p ^= null);
719 if have_subs then do;
720 if subs -> element (i) -> node.type ^= token_node then
721 goto step;
722 if subs -> element (i) -> token.type ^= asterisk then
723 goto step;
724
725 sdims = sdims + 1;
726 end;
727
728 q = create_bound ();
729 q -> bound.c_lower = p -> bound.c_lower;
730 q -> bound.c_upper = p -> bound.c_upper;
731
732 q -> bound.lower = p -> bound.lower;
733 q -> bound.upper = p -> bound.upper;
734
735 if t -> symbol.param_desc then
736 if q -> bound.lower ^= null then
737 if q -> bound.lower -> node.type = token_node then
738 if q -> bound.lower -> token.type = asterisk then
739 call use_eb;
740
741 if doing_return then
742 if q -> bound.lower ^= null then
743 if q -> bound.lower -> node.type = reference_node then
744 if q -> bound.lower -> reference.symbol -> node.type = symbol_node then
745 if q -> bound.lower -> reference.symbol -> symbol.arg_descriptor then
746 call use_eb;
747
748 if refer_extents then do;
749 r = copy_expression (q -> bound.lower);
750 call refer_extent (r, qual);
751 q -> bound.lower = r;
752 r = copy_expression (q -> bound.upper);
753 call refer_extent (r, qual);
754 q -> bound.upper = r;
755 end;
756
757 if q -> bound.lower ^= null then do;
758 call simplify_expression ((q -> bound.lower), constant, modified);
759
760 if modified then do;
761 q -> bound.lower = null;
762 q -> bound.c_lower = constant;
763 end;
764 else
765 s -> symbol.exp_extents = "1"b;
766 end;
767
768 if q -> bound.upper ^= null then do;
769 call simplify_expression ((q -> bound.upper), constant, modified);
770
771 if modified then do;
772 q -> bound.upper = null;
773 q -> bound.c_upper = constant;
774 end;
775 else
776 s -> symbol.exp_extents = "1"b;
777 end;
778
779 if a -> array.bounds = null then
780 a -> array.bounds = q;
781 else
782 f -> bound.next = q;
783
784 f = q;
785
786 step:
787 p = p -> bound.next;
788
789 if eb ^= null then
790 eb = eb -> bound.next;
791 end;
792
793 a -> array.own_number_of_dimensions = sdims;
794 end;
795
796 f = null;
797 t1 = t -> symbol.son;
798 e1 = e -> symbol.son;
799
800 do while (t1 ^= null);
801 if e -> symbol.son = null then
802 e1 = e;
803
804 if def_context.by_name_assignment then do;
805 s1 = create_symbol (blk, (e1 -> symbol.token), by_compiler);
806 call maker (t1, e1, s1, "1"b, level_number + 1, null);
807 end;
808 else
809 call maker (t1, e1, s1, "0"b, level_number + 1, null);
810
811 s1 -> symbol.member = "1"b;
812 s1 -> symbol.father = s;
813 if f = null then
814 s -> symbol.son = s1;
815 else
816 f -> symbol.brother = s1;
817 f = s1;
818 t1 = t1 -> symbol.brother;
819 e1 = e1 -> symbol.brother;
820 end;
821
822 if level_number = 1 then do;
823 if s -> symbol.dcl_size ^= null then do;
824 call simplify_expression ((s -> symbol.dcl_size), constant, modified);
825
826 if modified then do;
827 s -> symbol.dcl_size = null;
828 s -> symbol.c_dcl_size = constant;
829 end;
830 end;
831
832 s -> symbol.temporary = "1"b;
833 s -> symbol.position = "0"b;
834 call declare (s);
835
836 if s -> symbol.word_size ^= null then do;
837 s -> symbol.word_size =
838 expression_semantics (blk, stmnt, copy_expression (s -> symbol.word_size), "0"b);
839
840 call simplify_expression ((s -> symbol.word_size), constant, modified);
841
842 if modified then do;
843 s -> symbol.word_size = null;
844 s -> symbol.c_word_size = constant;
845 end;
846 end;
847 end;
848
849
850 use_eb:
851 proc;
852
853 if eb ^= null then do;
854 q -> bound.lower = eb -> bound.lower;
855 q -> bound.upper = eb -> bound.upper;
856 q -> bound.c_lower = eb -> bound.c_lower;
857 q -> bound.c_upper = eb -> bound.c_upper;
858 end;
859 else do;
860 q -> bound.lower, q -> bound.upper = null;
861 q -> bound.c_lower, q -> bound.c_upper = 1;
862 end;
863
864 end use_eb;
865
866 end maker;
867 %page;
868
869
870 declare_expression:
871 proc (tree, last, level_number) returns (ptr);
872
873 dcl (tree, last, s, f, a, b) ptr;
874 dcl (i, level_number) fixed bin (15);
875
876 if tree = null then
877 return (null);
878
879 if tree -> node.type = reference_node then do;
880 call maker ((tree -> reference.symbol), (tree -> reference.symbol), a, "0"b, level_number, null);
881 return (a);
882 end;
883
884 if tree -> node.type ^= operator_node then
885 return (tree);
886
887 if tree -> operator.op_code = join then do;
888 b = null;
889 f = create_symbol (blk, null, by_compiler);
890 f -> symbol.structure = "1"b;
891
892 do i = 1 to tree -> operator.number;
893 s = declare_expression ((tree -> operand (i)), null, level_number + 1);
894 s -> symbol.father = f;
895 s -> symbol.member = "1"b;
896
897 if b ^= null then
898 b -> symbol.brother = s;
899 else
900 f -> symbol.son = s;
901
902 b = s;
903 end;
904
905 f -> symbol.level = level_number;
906
907 return (f);
908 end;
909
910 if tree -> operator.op_code = loop then do;
911 b = create_bound ();
912 b -> bound.next = last;
913 last = b;
914 b -> bound.c_lower = 1;
915 b -> bound.upper = tree -> operand (4);
916 if tree -> operand (4) -> node.type = reference_node then
917 if tree -> operand (4) -> reference.symbol -> symbol.constant then do;
918 b -> bound.upper = null;
919 b -> bound.c_upper = tree -> operand (4) -> reference.symbol -> symbol.initial -> based_integer;
920 end;
921
922 s = declare_expression ((tree -> operand (1)), last, level_number);
923
924 if last ^= null then do;
925 s -> symbol.dimensioned = "1"b;
926 s -> symbol.array = create_array ();
927 s -> symbol.array -> array.bounds = last;
928
929 s -> symbol.array -> array.own_number_of_dimensions =
930 s -> symbol.array -> array.own_number_of_dimensions + 1;
931 s -> symbol.array -> array.number_of_dimensions = s -> symbol.array -> array.number_of_dimensions + 1;
932
933 last = null;
934
935 s -> symbol.reference -> reference.array_ref = "1"b;
936 end;
937
938 s -> symbol.array -> array.own_number_of_dimensions =
939 s -> symbol.array -> array.own_number_of_dimensions + 1;
940 s -> symbol.array -> array.number_of_dimensions = s -> symbol.array -> array.number_of_dimensions + 1;
941
942 return (s);
943 end;
944
945 s = tree -> operand (1) -> reference.symbol;
946 call maker (s, s, a, "0"b, level_number, null);
947
948 if last ^= null & (s -> symbol.bit | s -> symbol.char) then do;
949 have_varying = "0"b;
950 a -> symbol.c_dcl_size = 0;
951 a -> symbol.dcl_size = size (tree);
952
953 if no_data_type & have_varying then do;
954 a -> symbol.varying, a -> symbol.aligned = "1"b;
955 a -> symbol.unaligned, a -> symbol.packed = "0"b;
956 end;
957 a -> symbol.exp_extents = "1"b;
958 end;
959
960 if a -> symbol.dcl_size ^= null then do;
961 call simplify_expression ((a -> symbol.dcl_size), constant, modified);
962
963 if modified then do;
964 a -> symbol.dcl_size = null;
965 a -> symbol.c_dcl_size = constant;
966 end;
967 end;
968
969 if level_number = 1 then do;
970 a -> symbol.temporary = "1"b;
971 call declare (a);
972
973 if a -> symbol.word_size ^= null then do;
974 a -> symbol.word_size =
975 expression_semantics (blk, stmnt, copy_expression (a -> symbol.word_size), "0"b);
976 call simplify_expression ((a -> symbol.word_size), constant, modified);
977
978 if modified then do;
979 a -> symbol.word_size = null;
980 a -> symbol.c_word_size = constant;
981 end;
982 end;
983 end;
984
985 return (a);
986
987 end declare_expression;
988 %page;
989
990
991 size:
992 proc (e) returns (ptr);
993
994 dcl (e, s, q) ptr;
995 dcl opcode bit (9) aligned;
996
997 if e = null then
998 call semantic_translator$abort (195, null);
999
1000 if e -> node.type = reference_node then do;
1001 s = e -> reference.symbol;
1002 if s -> symbol.dcl_size = null then
1003 q = declare_constant$integer ((s -> symbol.c_dcl_size));
1004 else
1005 q = s -> symbol.dcl_size;
1006
1007 if s -> symbol.varying then
1008 have_varying = "1"b;
1009
1010 q = copy_expression ((q));
1011 this_context = "0"b;
1012 if s -> symbol.refer_extents then
1013 call refer_extent (q, (e -> reference.qualifier));
1014 q = expression_semantics (blk, stmnt, q, this_context);
1015 return (q);
1016 end;
1017
1018 if e -> node.type ^= operator_node then
1019 call semantic_translator$abort (195, null);
1020
1021 opcode = e -> operator.op_code;
1022
1023 if opcode = cat_string then do;
1024 q = create_operator (add, 3);
1025 q -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1026 q -> operand (2) = size ((e -> operand (2)));
1027 q -> operand (3) = size ((e -> operand (3)));
1028 return (q);
1029 end;
1030
1031 if opcode = or_bits | opcode = and_bits | opcode = xor_bits | opcode = bool_fun then do;
1032 q = create_operator (max_fun, 3);
1033 q -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
1034 q -> operand (2) = size ((e -> operand (2)));
1035 q -> operand (3) = size ((e -> operand (3)));
1036 return (q);
1037 end;
1038
1039 if opcode = repeat_fun then do;
1040 q = create_operator (mult, 3);
1041 q -> operand (2) = size ((e -> operand (2)));
1042 q -> operand (3) = copy_expression (e -> operand (3));
1043 return (q);
1044 end;
1045
1046 q = size ((e -> operand (1)));
1047
1048 if q -> node.type = operator_node then
1049 if q -> operator.op_code = length_fun then
1050 if q -> operand (2) = e -> operand (2) then do;
1051 if ^q -> operand (1) -> reference.shared then
1052 q -> operand (1) -> reference.ref_count = q -> operand (1) -> reference.ref_count - 1;
1053 else do;
1054 q = q -> operand (2);
1055 if q -> node.type = operator_node then
1056 q = q -> operand (1);
1057 if ^q -> reference.shared then
1058 q -> reference.ref_count = q -> reference.ref_count - 1;
1059 end;
1060 return (size ((e -> operand (2))));
1061 end;
1062
1063 return (q);
1064
1065 end size;
1066 %page;
1067 %include semant;
1068 %include array;
1069 %include block;
1070 %include boundary;
1071 %include declare_type;
1072 %include decoded_token_types;
1073 %include list;
1074 %include mask;
1075 %include nodes;
1076 %include op_codes;
1077 %include operator;
1078 %include reference;
1079 %include semantic_bits;
1080 %include statement;
1081 %include statement_types;
1082 %include symbol;
1083 %include symbol_bits;
1084 %include system;
1085 %include token;
1086 %include token_types;
1087
1088 end expand_assign;