1
2
3
4
5
6
7
8
9
10
11 defined_reference: proc(blk,stmnt,input_tree,subs,s,context) returns(ptr);
12
13
14
15
16 dcl (blk,stmnt,tree,subs,new_subs,p,s,br,bs,a,input_tree,off,father_s) ptr;
17 dcl (t,k,n,i,nsubs,ndims,nsubs_minus_ndims) fixed bin(15);
18 dcl (father_dims,listdims(128)) fixed bin(15);
19 dcl (co,coff) fixed bin(31);
20 dcl cunits fixed bin(3);
21
22 dcl op_table(4) bit(9) aligned initial(mod_bit,""b,mod_byte,mod_half);
23 dcl dims_processed bit(1) aligned;
24
25 dcl pl1_stat_$eis_mode bit(1) aligned ext static,
26 pl1_stat_$check_ansi bit(1) aligned ext static,
27
28 pl1_stat_$root external static ptr;
29
30 dcl (addr,null,fixed,string,substr) builtin;
31 ^L
32 this_context = "0"b;
33 t,k,n = 0;
34
35
36
37
38
39
40 tree = copy_expression((input_tree));
41 br = copy_expression(s->symbol.equivalence);
42
43 father_s=s;
44 do while(father_s->symbol.member);
45 father_s=father_s->symbol.father;
46 end;
47
48 if father_s->symbol.dimensioned then father_dims=father_s->symbol.array->array.number_of_dimensions;
49 else father_dims=0;
50
51
52
53
54 if ^lookup((s->symbol.block_node),stmnt,br,bs,this_context)
55 then if br->node.type = token_node
56 then do;
57 call semantic_translator$error(77,br);
58 bs = create_symbol((pl1_stat_$root->block.son),br,by_implication);
59 call declare(bs);
60 bs->symbol.allocate = "1"b;
61 end;
62 else call print(175);
63 else if br->node.type=reference_node
64 then do;
65 br->reference.symbol = bs->symbol.token;
66 br->reference.length = copy_expression(s->symbol.equivalence->reference.length);
67 br->reference.offset = copy_expression(s->symbol.equivalence->reference.offset);
68 br->reference.qualifier = copy_expression(s->symbol.equivalence->reference.qualifier);
69 end;
70
71 if bs->node.type ^= symbol_node then call print(176);
72 if pl1_stat_$check_ansi
73 then if bs->symbol.based
74 then call semantic_translator$error(173,s);
75 if bs->symbol.defined | bs->symbol.constant then call print(176);
76
77
78
79
80
81 s -> symbol.reference -> reference.qualifier = bs -> symbol.reference;
82 call propagate_bit(bs,aliasable_bit);
83 if def_context.left_side then call propagate_bit(bs,set_bit);
84
85 a = s->symbol.array;
86 if a ^= null
87 then ndims = a->array.number_of_dimensions;
88 else ndims = 0;
89
90 dims_processed = "0"b;
91 if subs ^= null
92 then do;
93 nsubs = subs->list.number;
94 if s->symbol.dimensioned
95 then do;
96 tree->reference.array_ref = "0"b;
97 if nsubs < ndims then call print(81);
98 if nsubs > ndims & ^s->symbol.entry then call print(82);
99 if ^isubs_or_stars()
100 then do;
101 tree = subscripter(blk,stmnt,tree,subs,s);
102 dims_processed = "1"b;
103 end;
104 end;
105 else if isubs_or_stars() then call print(183);
106 end;
107 else do;
108 nsubs = 0;
109 if isubs_or_stars() & ^s->symbol.dimensioned then call print(183);
110 end;
111
112
113
114
115 if father_s->symbol.position
116 then do;
117
118 if n>0 then call print(177);
119 if ^(string_overlay(father_s)&string_overlay(bs)) then call print(178);
120 father_s->symbol.overlayed, s->symbol.overlayed = "1"b;
121 p = father_s -> symbol.initial;
122 if p -> node.type = token_node
123 then if p -> token.type & is_arith_constant
124 then do;
125 co = token_to_binary(p) - 1;
126 p = null;
127 goto l1;
128 end;
129
130 co = 0;
131 p = copy_expression((p));
132
133 this_context = "0"b;
134 a = create_operator(sub,3);
135 a->operand(2) = p;
136 a->operand(3) = declare_constant$integer(1);
137 p = a;
138 p = expression_semantics((s->symbol.block_node),stmnt,p,this_context);
139 if def_this_context.aggregate then call print(185);
140 p = convert(p,integer_type);
141 l1:
142 off = tree->reference.offset;
143 coff = tree->reference.c_offset;
144 cunits = tree->reference.units;
145
146 call offset_adder(off,coff,cunits,(tree->reference.modword_in_offset),p,co,(t),"0"b,tree->reference.fo_in_qual);
147
148 tree->reference.offset = off;
149 tree->reference.c_offset = coff;
150 tree->reference.units = cunits;
151 tree->reference.modword_in_offset = "0"b;
152 end;
153
154 else do;
155 if match(father_s,bs) then goto build_ref;
156 if n>0 then call print(179);
157 if string_overlay(father_s) & string_overlay(bs)
158 then father_s->symbol.overlayed, s->symbol.overlayed = "1"b;
159 else call print(179);
160 end;
161
162
163
164 build_ref:
165 if pl1_stat_$check_ansi
166 then if s->symbol.varying
167 then call semantic_translator$error(174,s);
168
169 this_context = "0"b;
170 def_this_context.evaluate_offset = "1"b;
171 def_this_context.f_offset_to_be_added = "1"b;
172 br = expression_semantics((s->symbol.block_node),stmnt,br,this_context);
173 if bs->symbol.reference=br then br=copy_expression((br));
174 if br->reference.units ^= 0
175 then do;
176 off = tree->reference.offset;
177 coff = tree->reference.c_offset;
178 cunits = tree->reference.units;
179
180 call offset_adder(off,coff,cunits,(tree->reference.modword_in_offset),
181 (br->reference.offset),(br->reference.c_offset),(br->reference.units),(br->reference.modword_in_offset),
182 tree->reference.fo_in_qual);
183
184 tree->reference.offset = off;
185 tree->reference.c_offset = coff;
186 tree->reference.units = cunits;
187 tree->reference.modword_in_offset = "0"b;
188 end;
189
190 tree->reference.qualifier = br;
191 tree->reference.fo_in_qual = br->reference.fo_in_qual;
192 tree->reference.defined_ref = "1"b;
193 tree->reference.shared,br->reference.shared = "0"b;
194 tree->reference.ref_count,br->reference.ref_count = 1;
195
196 if ^dims_processed
197 then do;
198 if nsubs > ndims
199 then do;
200 nsubs_minus_ndims=nsubs-ndims;
201 new_subs = create_list(nsubs_minus_ndims);
202 do i = 1 to nsubs_minus_ndims;
203 new_subs->element(i) =subs->element(i);
204 end;
205 subs=new_subs;
206 end;
207 else subs=null;
208 end;
209
210 br->reference.offset = null;
211 br->reference.units,br->reference.c_offset = 0;
212 br->reference.modword_in_offset = "0"b;
213
214
215
216 br->reference.inhibit = "1"b;
217
218 if ^pl1_stat_$eis_mode
219 then if tree->reference.offset ^= null
220 then if tree->reference.units < word_
221 then do;
222 p = tree->reference.offset;
223 if p->node.type=operator_node
224 then if p->operator.op_code=mod_bit
225 | p->operator.op_code=mod_byte
226 | p->operator.op_code=mod_half
227 then goto ret;
228
229 p = create_operator(op_table(tree->reference.units),3);
230 p->operand(3) = tree->reference.offset;
231 tree->reference.offset = p;
232 end;
233
234 ret:
235 return(tree);
236 ^L
237
238
239
240 match: proc(a,b) returns(bit(1) aligned);
241
242 dcl (a,b,p,q) ptr;
243
244
245
246
247 dcl (pp,qq) ptr;
248
249
250 if string(a->symbol.data_type)^=string(b->symbol.data_type)
251 then goto fail;
252
253 if a->symbol.aligned ^= b->symbol.aligned
254 then goto fail;
255
256 if a -> symbol.unsigned ^= b -> symbol.unsigned
257 then go to fail;
258
259 if a->symbol.c_dcl_size ^= b->symbol.c_dcl_size
260 then do;
261 if a->symbol.array=null
262 then goto fail;
263
264 if a->symbol.array->array.c_element_size^=b->symbol.c_dcl_size
265 then goto fail;
266 end;
267
268 if a->symbol.scale ^= b->symbol.scale
269 then goto fail;
270
271 if a->symbol.structure
272 then do;
273 p = a->symbol.son;
274 q = b->symbol.son;
275
276 do while(p^=null);
277 if q = null then go to fail;
278
279 pp=p->symbol.array;
280 qq=q->symbol.array;
281 if (pp^=null | qq^=null )
282 then do;
283 if qq=null
284 then goto fail;
285
286 if pp=null
287 then if ^p->symbol.structure
288 then if qq->array.own_number_of_dimensions^=0
289 then goto fail;
290 else ;
291 else ;
292 else if pp->array.own_number_of_dimensions
293 ^= qq->array.own_number_of_dimensions
294 then goto fail;
295 end;
296
297 if ^match(p,q) then go to fail;
298 p = p->symbol.brother;
299 q = q->symbol.brother;
300 end;
301
302 if q ^= null then go to fail;
303 end;
304
305 return("1"b);
306
307 fail:
308 return("0"b);
309 end match;
310
311
312 %include string_overlay;
313 ^L
314
315
316 isubs_or_stars: proc returns(bit(1) aligned);
317
318 dcl p ptr;
319 dcl i fixed bin(15);
320
321
322
323
324
325
326
327 n = 0;
328
329 do i=1 to father_dims;
330 listdims(i)=0;
331 end;
332
333
334 if br->node.type=reference_node
335 then do;
336 p = br->reference.offset;
337 if p^=null
338 then do i = 1 to p->list.number;
339 call find(p->list.element(i));
340 end;
341 end;
342
343 if n=0 then return("0"b);
344 if father_dims=0 then return("1"b);
345
346 if k>0 then if k^= father_dims then call print(181);
347 if k>0 then
348 do i=1 to father_dims;
349 if listdims(i)^=0 then call print(181);
350 end;
351 else do i=1 to father_dims;
352 if listdims(i)=0 then call print(181);
353 end;
354
355 return("1"b);
356
357 find: proc(p);
358
359 dcl p ptr unal,
360 (e,q) ptr;
361 dcl i fixed bin(15);
362 dcl recursif fixed bin(15);
363
364 recursif=1;
365 goto find_common;
366
367 find_r: entry(p);
368 recursif=2;
369
370 find_common:
371 e = p;
372
373 if e = null then return;
374
375 if e->node.type = operator_node
376 then do;
377 do i = 1 to e->operator.number;
378 call find_r(e->operand(i));
379 end;
380 return;
381 end;
382
383 if e->node.type = reference_node
384 then do;
385 call find_r(e->reference.qualifier);
386 call find_r(e->reference.offset);
387 call find_r(e->reference.length);
388 return;
389 end;
390
391 if e->node.type=list_node
392
393
394
395 then do;
396 do i=1 to e->list.number;
397 call find_r(e->list.element(i));
398 end;
399 return;
400 end;
401
402 if e->node.type = token_node
403 then do;
404 if e->token.type = asterisk
405 then do;
406 if recursif=2 then return;
407
408
409 k = k+1;
410 n = k;
411 end;
412 else do;
413 if e->token.type ^= isub then return;
414 n = decbin(substr(e->token.string,1,e->token.size-3));
415 listdims(n)=1;
416 s->symbol.isub = "1"b;
417 end;
418
419 if n > father_dims then call print(181);
420 if substr(stmnt->statement.prefix,7,1)
421 | subs=null
422 then do;
423 q = a->array.bounds;
424 do i = 1 to n-1;
425 q = q->bound.next;
426 end;
427 if q->bound.lower=null
428 then q->bound.lower = declare_constant$integer((q->bound.c_lower));
429 if subs=null
430 then e = q->bound.lower;
431 else do;
432 if q->bound.upper = null
433 then q->bound.upper = declare_constant$integer((q->bound.c_upper));
434 e = create_operator(bound_ck,4);
435 e->operand(1) = declare_temporary(integer_type,default_fix_bin_p,0,null);
436 e->operand(2) = subs->list.element(subs->list.number+1-n);
437 e->operand(3) = q->bound.lower;
438 e->operand(4) = q->bound.upper;
439 end;
440 end;
441 else e = subs->list.element(subs->list.number+1-n);
442
443
444
445
446
447
448
449
450 e = expression_semantics(blk,stmnt,e,this_context);
451 e = convert$to_integer(e,integer_type);
452 end;
453
454 p = e;
455
456 end find;
457
458 end isubs_or_stars;
459 ^L
460
461
462 print: proc(m);
463
464 dcl m fixed bin(15);
465
466 call semantic_translator$abort(m,s);
467 end print;
468 ^L
469 %include semant;
470 %include symbol;
471
472 %include symbol_bits;
473
474 %include block;
475
476 %include reference;
477 %include semantic_bits;
478
479 %include token;
480
481 %include statement;
482
483 %include array;
484
485 %include list;
486
487 %include operator;
488
489 %include op_codes;
490
491 %include token_types;
492
493 %include nodes;
494
495 %include system;
496
497 %include declare_type;
498
499 %include boundary;
500
501 end defined_reference;