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_primitive:
32 proc (blk, stmnt, input_tree, context) returns (ptr);
33
34 dcl (blk, stmnt, tree, input_tree, one, subs, loops, last, qual, p, a, b, s, symbols_block, bna)
35 ptr;
36 dcl (i, given, ndims, n, stars_given)
37 fixed bin (15);
38 dcl pds bit (1) aligned;
39 dcl pl1_stat_$eis_mode bit (1) aligned ext static;
40 dcl pl1_stat_$by_name_parts_tree
41 ptr aligned ext static;
42
43 dcl null builtin;
44 ^L
45 if input_tree -> node.type = operator_node
46 then return (input_tree);
47 ^L
48
49
50 last, loops = null;
51 this_context = "0"b;
52 one = declare_constant$integer (1);
53 stars_given, n = 0;
54
55 if def_context.by_name_assignment
56 then bna = pl1_stat_$by_name_parts_tree;
57 else bna = null;
58
59 s = input_tree -> reference.symbol;
60
61 if s -> symbol.block_node = null
62 then symbols_block = blk;
63 else symbols_block = s -> symbol.block_node;
64
65 if s -> symbol.reference = input_tree | input_tree -> reference.array_ref
66 then do;
67 tree = create_reference ((input_tree -> reference.symbol));
68 tree -> reference = input_tree -> reference;
69 end;
70 else tree = input_tree;
71
72
73
74 if s -> node.type = label_node
75 then do;
76 b = create_bound ();
77 b -> bound.c_lower = s -> label.low_bound;
78 b -> bound.c_upper = s -> label.high_bound;
79 b -> bound.c_multiplier = 1;
80 subs = create_list (1);
81 subs -> list.element (1) = create_token ("*", asterisk);
82 given = 1;
83 end;
84 else do;
85 qual = tree -> reference.qualifier;
86
87 subs = tree -> reference.offset;
88
89 if subs = null
90 then given = 0;
91 else if subs -> node.type ^= list_node
92 then do;
93 given = 0;
94
95
96 pds = tree -> reference.put_data_sw;
97 tree -> reference = tree -> reference.symbol -> symbol.reference -> reference;
98 tree -> reference.put_data_sw = pds;
99 tree -> reference.shared = "0"b;
100 tree -> reference.ref_count = 1;
101 subs = null;
102 end;
103 else do;
104 subs = copy_expression ((subs));
105
106 given = subs -> list.number;
107 end;
108
109 a = s -> symbol.array;
110
111 if a ^= null
112 then ndims = a -> array.number_of_dimensions;
113 else ndims = 0;
114
115
116 if given = 0 & ndims = 0
117 then return (expander (tree, bna));
118
119 if ndims ^= given & given ^= 0
120 then call semantic_translator$abort (81, s);
121
122 b = a -> array.bounds;
123 tree -> reference.offset = copy_expression (s -> symbol.reference -> reference.offset);
124 if tree -> reference.length ^= null
125 then tree -> reference.length = copy_expression (tree -> reference.length);
126 end;
127
128
129
130
131 if given = 0
132 then do;
133 n, given = ndims;
134 subs = create_list (ndims);
135
136 subs -> list.element (*) = create_token ("*", asterisk);
137 end;
138 else do i = 1 to given;
139 p = subs -> list.element (i);
140
141 if p -> node.type = token_node
142 then if p -> token.type = asterisk
143 then n = n + 1;
144 end;
145
146 stars_given = n;
147
148 do i = 1 to given;
149 p = subs -> list.element (i);
150
151 if p -> node.type = token_node
152 then if p -> token.type = asterisk
153 then do;
154 p = make_loop (n, b, s);
155 n = n - 1;
156 p -> operand (1) = loops;
157 loops = p;
158 if last = null
159 then last = p;
160
161 if b -> bound.c_lower ^= 1
162 then do;
163 if b -> bound.lower = null
164 then b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
165 subs -> list.element (i) =
166 addf ((p -> operand (2)), subf (copy_expression (b -> bound.lower), one));
167 end;
168 else subs -> list.element (i) = p -> operand (2);
169 end;
170
171 b = b -> bound.next;
172 end;
173
174 tree -> reference.array_ref = "0"b;
175
176 if s -> node.type = label_node
177 then do;
178 p = subscripter (blk, stmnt, tree, subs, s);
179 p -> reference.offset = expression_semantics (blk, stmnt, (p -> reference.offset), "0"b);
180 call simplify_offset (p, context);
181 end;
182 else if s -> symbol.structure
183 then p = expander (tree, bna);
184 else p = process_subscripted_reference (tree, subs);
185
186 if last = null
187 then return (p);
188
189 last -> operand (1) = p;
190
191 return (loops);
192 ^L
193
194
195 expander:
196 proc (tree, bna) returns (ptr);
197
198
199
200 dcl tree ptr;
201 dcl bna ptr;
202
203
204
205
206 dcl (s, a, q, qt, b, p, bnm, join_operator)
207 ptr;
208 dcl (k, i, n, m, our_last_index)
209 fixed bin (15);
210 dcl first_time bit (1) aligned;
211 dcl number_of_members fixed bin (35);
212
213 first_time = "1"b;
214 s = tree -> reference.symbol;
215 a = s -> symbol.array;
216
217 if a ^= null
218 then do;
219 n = a -> array.number_of_dimensions;
220 m = n + 1 - a -> array.own_number_of_dimensions;
221 our_last_index = n - given + stars_given;
222 end;
223
224
225
226 if s -> symbol.structure
227 then do;
228
229 k = 0;
230 bnm = null;
231
232
233
234
235
236
237
238 if ^def_context.by_name_assignment
239 then do;
240 number_of_members = 0;
241 do q = s -> symbol.son repeat q -> symbol.brother while (q ^= null);
242 number_of_members = number_of_members + 1;
243 end;
244
245 if number_of_members > max_number_of_operands
246 then call semantic_translator$abort (383, s);
247
248 join_operator = create_operator (join, (number_of_members));
249 do q = s -> symbol.son repeat q -> symbol.brother while (q ^= null);
250 call expand_son (q, bnm);
251 end;
252 end;
253 else do;
254 number_of_members = 0;
255 do bnm = bna -> by_name_agg.son repeat bnm -> by_name_agg.right_brother while (bnm ^= null);
256 number_of_members = number_of_members + 1;
257 end;
258
259 if number_of_members > max_number_of_operands
260 then call semantic_translator$abort (383, s);
261
262 join_operator = create_operator (join, (number_of_members));
263 do bnm = bna -> by_name_agg.son repeat bnm -> by_name_agg.right_brother while (bnm ^= null);
264 do q = s -> symbol.son repeat q -> symbol.brother
265 while (q -> symbol.token ^= bnm -> by_name_agg.token);
266 end;
267 call expand_son (q, bnm);
268 end;
269 end;
270
271
272
273 if ^tree -> reference.array_ref
274 then return (join_operator);
275
276 q = join_operator;
277 goto make_my_loops;
278 end;
279
280
281 if ^tree -> reference.array_ref
282 then do;
283 if ^tree -> reference.processed
284 then do;
285 tree -> reference.qualifier = qual;
286
287 tree = expression_semantics (blk, stmnt, tree, this_context);
288 end;
289
290 return (tree);
291 end;
292
293
294
295
296
297 b = a -> array.bounds;
298 q = create_list ((a -> array.number_of_dimensions));
299
300 do i = 1 to n - given;
301 p = declare_index (our_last_index + 1 - i);
302 if b -> bound.c_lower ^= 1
303 then do;
304 if b -> bound.lower = null
305 then b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
306 q -> list.element (i) = addf (p, subf (copy_expression (b -> bound.lower), one));
307 end;
308 else q -> list.element (i) = p;
309
310 b = b -> bound.next;
311 end;
312
313 k = 0;
314
315 do i = n - given + 1 to n;
316 k = k + 1;
317 q -> list.element (i) = copy_expression (subs -> list.element (k));
318 end;
319
320 q = process_subscripted_reference (tree, q);
321
322
323
324
325
326 make_my_loops:
327 b = a -> array.bounds;
328
329 k = 0;
330
331 if n ^= given
332 then do i = m to n;
333 p = make_loop (our_last_index - k, b, s);
334 p -> operand (1) = q;
335 q = p;
336 b = b -> bound.next;
337 k = k + 1;
338 end;
339
340
341
342 return (q);
343
344
345
346 expand_son:
347 procedure (q, bnm);
348
349
350
351 dcl q ptr;
352 dcl bnm ptr;
353
354 k = k + 1;
355
356 qt = create_reference (q);
357 qt -> reference = q -> symbol.reference -> reference;
358 qt -> reference.shared = "0"b;
359 qt -> reference.ref_count = 1;
360 qt -> reference.length = copy_expression (qt -> reference.length);
361 qt -> reference.offset = copy_expression (qt -> reference.offset);
362
363 if ^first_time
364 then qt -> reference.qualifier = share_expression (qual);
365 else do;
366 first_time = "0"b;
367 qt -> reference.qualifier = qual;
368
369
370
371
372 if qual ^= null
373 then if qual -> node.type = operator_node
374 then if qual -> operand (1) -> reference.shared
375 then do;
376 qual -> operand (1) = copy_expression (qual -> operand (1));
377 qual -> operand (1) -> reference.shared = "0"b;
378 qual -> operand (1) -> reference.ref_count = 1;
379 end;
380 end;
381
382 qt -> reference.put_data_sw = tree -> reference.put_data_sw;
383
384 if tree -> reference.array_ref
385 then qt -> reference.array_ref = "1"b;
386 else if qt -> reference.symbol -> symbol.array ^= null
387 then if qt -> reference.symbol -> symbol.array -> array.own_number_of_dimensions ^= 0
388 then qt -> reference.array_ref = "1"b;
389 else qt -> reference.array_ref = "0"b;
390 else qt -> reference.array_ref = "0"b;
391
392 if ^qt -> reference.array_ref & subs ^= null
393 then qt = process_subscripted_reference (qt, copy_expression ((subs)));
394
395 join_operator -> operator.operand (k) = expander (qt, bnm);
396
397 return;
398
399 end ;
400
401 end ;
402 ^L
403 process_subscripted_reference:
404 proc (tree, subs) returns (ptr);
405
406 dcl (tree, subs, p, s) ptr;
407
408 dcl constant fixed bin,
409 modified bit (1) aligned;
410
411 dcl pl1_stat_$locator (128) ptr ext static,
412 pl1_stat_$index fixed bin (15) ext static;
413
414 s = tree -> reference.symbol;
415
416 if qual ^= null
417 then do;
418 pl1_stat_$index = pl1_stat_$index + 1;
419 if pl1_stat_$index > hbound (pl1_stat_$locator, 1)
420 then do;
421 call semantic_translator$abort (70, s);
422 return (null);
423 end;
424 pl1_stat_$locator (pl1_stat_$index) = tree;
425 end;
426
427 if s -> symbol.defined
428 then p = defined_reference (blk, stmnt, tree, subs, s, this_context);
429 else p = subscripter (blk, stmnt, tree, (subs), s);
430
431 p -> reference.array_ref = "0"b;
432
433 if s -> symbol.defined
434 then ;
435 else p -> reference.qualifier = qual;
436
437 if p -> reference.offset ^= null
438 then do;
439 if ^pl1_stat_$eis_mode
440 then call bit_ptr ((p -> reference.offset), qual);
441 p -> reference.offset =
442 expression_semantics (symbols_block, stmnt, (p -> reference.offset), this_context);
443
444 p -> reference.offset = convert$to_integer ((p -> reference.offset), integer_type);
445
446 call simplify_expression ((p -> reference.offset), constant, modified);
447
448 if modified
449 then do;
450 p -> reference.offset = null;
451 p -> reference.c_offset = constant;
452 end;
453 end;
454
455 if p -> reference.length ^= null
456 then do;
457 p -> reference.length =
458 expression_semantics (symbols_block, stmnt, (p -> reference.length), this_context);
459 p -> reference.length = convert$to_integer ((p -> reference.length), integer_type);
460 end;
461
462 call simplify_offset (p, context);
463
464 if qual ^= null
465 then pl1_stat_$index = pl1_stat_$index - 1;
466
467 p -> reference.processed = "1"b;
468
469 return (p);
470
471 end process_subscripted_reference;
472 ^L
473
474
475 make_loop:
476 proc (i, b, s) returns (ptr);
477
478 dcl i fixed bin (15);
479 dcl constant_field fixed bin;
480 dcl (p, q, b, s, lower, upper)
481 ptr;
482 dcl (constant, modified)
483 bit (1) aligned;
484
485 if b -> bound.lower = null
486 then lower, b -> bound.lower = declare_constant$integer ((b -> bound.c_lower));
487 else lower = copy_expression (b -> bound.lower);
488
489 if b -> bound.upper = null
490 then upper, b -> bound.upper = declare_constant$integer ((b -> bound.c_upper));
491 else upper = copy_expression (b -> bound.upper);
492
493 p = create_operator (loop, 5);
494 p -> operand (2) = declare_index ((i));
495 p -> operand (3) = one;
496
497 if lower -> node.type = reference_node & upper -> node.type = reference_node
498 then if lower -> reference.symbol -> node.type = symbol_node
499 & upper -> reference.symbol -> node.type = symbol_node
500 then if lower -> reference.symbol -> symbol.constant & upper -> reference.symbol -> symbol.constant
501 then constant = "1"b;
502 else constant = "0"b;
503 else constant = "0"b;
504 else constant = "0"b;
505
506 if b -> bound.c_lower = 1
507 then p -> operand (4) = upper;
508 else if constant
509 then p -> operand (4) = declare_constant$integer (b -> bound.c_upper - b -> bound.c_lower + 1);
510 else p -> operand (4) = subf (upper, subf (lower, one));
511
512 q = p -> operand (4);
513 call refer_extent (q, qual);
514
515 p -> operand (4) = expression_semantics (symbols_block, stmnt, q, this_context);
516 p -> operand (4) = convert$to_integer ((p -> operand (4)), integer_type);
517
518 call simplify_expression ((p -> operand (4)), constant_field, modified);
519
520 if modified
521 then p -> operand (4) = declare_constant$integer ((constant_field));
522
523 return (p);
524
525 end make_loop;
526 ^L
527
528
529 declare_index:
530 proc (i) returns (ptr);
531
532 dcl i fixed bin (7);
533 dcl (t, d) ptr;
534
535 t = create_token ("s." || bindec$vs ((i)), identifier);
536
537 do d = t -> token.declaration repeat d -> symbol.multi_use while (d ^= null);
538 if d -> symbol.block_node = blk
539 then return (d -> symbol.reference);
540 end;
541
542 d = create_symbol (blk, t, by_compiler);
543 d -> symbol.fixed, d -> symbol.binary, d -> symbol.real, d -> symbol.auto, d -> symbol.allocate = "1"b;
544
545 call declare (d);
546
547 return (d -> symbol.reference);
548
549 end declare_index;
550 ^L
551
552
553 addf:
554 proc (a, b) returns (ptr);
555
556 dcl (a, b, c) ptr;
557 dcl opcode bit (9) aligned;
558
559 opcode = add;
560
561 go to common;
562
563 subf:
564 entry (a, b) returns (ptr);
565
566 opcode = sub;
567 common:
568 c = create_operator (opcode, 3);
569 c -> operand (2) = a;
570 c -> operand (3) = b;
571
572 return (c);
573
574 end addf;
575 ^L
576 bit_ptr:
577 proc (exp, q);
578
579 dcl (exp, q) ptr;
580 dcl i fixed bin (15);
581
582 if exp = null
583 then return;
584 if exp -> node.type ^= operator_node
585 then return;
586
587 if exp -> op_code = bit_pointer
588 then do;
589 exp -> operand (1) = declare_temporary (integer_type, default_fix_bin_p, 0, null);
590 exp -> operand (2) = share_expression (q);
591 exp -> operator.processed = "1"b;
592 end;
593 else do i = 2 to exp -> operator.number;
594 call bit_ptr ((exp -> operand (i)), q);
595 end;
596
597 end bit_ptr;
598 ^L
599 %include semant;
600 %include array;
601 %include by_name_agg;
602 %include declare_type;
603 %include label;
604 %include list;
605 %include nodes;
606 %include op_codes;
607 %include operator;
608 %include reference;
609 %include semantic_bits;
610 %include symbol;
611 %include system;
612 %include token;
613 %include token_types;
614
615 end expand_primitive;