1
2
3
4
5
6
7
8
9
10
11
12
13
14
15 function: proc(blk,stmnt,input_tree,s,context) returns(ptr);
16
17 dcl (blk,stmnt,tree,input_tree,s,p,old,arg_list,arg_list_op,p_desc_list,save_arg_list_op) ptr,
18 (a,op,q,r,sa,t) ptr,
19 (subs,sym,array_ptr,bound_ptr,based_ref,based_sym,descr_ptr) ptr,
20 (newarray,newbound) ptr,
21 (i,j,k,n,called,caller) fixed bin(15),
22 desc_list ptr,
23
24 descriptors_required bit(1);
25
26
27 dcl pl1_stat_$locator(128) ptr ext static;
28 dcl pl1_stat_$index fixed bin(15) ext static;
29
30 dcl (addr,divide,hbound,length,null,substr) builtin;
31
32 %include semant;
33 %include array;
34 %include block;
35 %include declare_type;
36 %include list;
37 %include nodes;
38 %include op_codes;
39 %include operator;
40 %include quick_info;
41 %include reference;
42 %include semantic_bits;
43 %include statement;
44 %include statement_types;
45 %include symbol;
46 %include symbol_bits;
47 %include system;
48 %include token;
49 %include token_types;
50 ^L
51 if input_tree->operator.processed then return(input_tree);
52
53 if s -> symbol.constant & s -> symbol.equivalence ^= null
54 then do;
55 called = s -> symbol.equivalence -> block.number;
56 caller = blk -> block.number;
57 substr(quick_info(called),caller,1) = "1"b;
58 if stmnt->statement.force_nonquick
59 then do;
60 s -> symbol.equivalence -> block.no_stack = "0"b;
61 s -> symbol.equivalence -> block.why_nonquick.stack_extended_by_args = "1"b;
62 end;
63 end;
64
65 tree = input_tree;
66
67 n = 0;
68 descriptors_required = "0"b;
69 arg_list_op = tree->operand(3);
70 arg_list = null;
71 p_desc_list = s->symbol.general;
72
73 if arg_list_op^=null
74 then if arg_list_op->operand(2)->list.number=0
75 then do;
76 save_arg_list_op = arg_list_op;
77
78 arg_list_op ,
79 tree->operand(3) = null;
80 end;
81
82 if arg_list_op=null
83 then if p_desc_list=null
84 then do;
85 if s->symbol.returns
86 then desc_list = create_list(1);
87 goto process_returns;
88 end;
89 else call print(85);
90
91 if p_desc_list = null
92 then do;
93 if ^s->symbol.variable_arg_list
94 then do;
95 call semantic_translator$error(86,s);
96 s->symbol.variable_arg_list = "1"b;
97 end;
98
99 descriptors_required = "1"b;
100 n = arg_list_op->operand(2)->list.number;
101 end;
102 else do;
103 do q = p_desc_list repeat q->element(2) while(q^=null);
104 n = n+1;
105 descriptors_required = descriptors_required | q->element(1)->symbol.star_extents;
106 end;
107
108 if s->symbol.dcl_size ^= null
109 then descriptors_required = descriptors_required | s->symbol.dcl_size->symbol.star_extents;
110
111 if arg_list_op->operand(2)->list.number ^= n then call print(87);
112 end;
113 ^L
114
115 arg_list = arg_list_op->operand(2);
116
117 if arg_list->list.number > max_list_elements - 1
118 then call semantic_translator$abort(340,create_token(bindec$vs(max_list_elements-1),dec_integer));
119
120 do k = 1 to divide(n,2,15,0);
121 q = arg_list->element(k);
122 arg_list->element(k) = arg_list->element(n-k+1);
123 arg_list->element(n-k+1) = q;
124 end;
125
126 k = arg_list->list.number;
127 if s->symbol.returns
128 then k = k+ 1;
129 desc_list = create_list(k);
130
131 do k = 1 to arg_list->list.number;
132 old=stmnt->statement.back;
133
134 this_context = "01"b;
135 a = arg_list->element(k);
136 if p_desc_list ^= null
137 then p = p_desc_list->element(1);
138 else p = null;
139
140 desc_list->list.element(k) = null;
141
142 if a->node.type=operator_node
143 then do;
144 if a->operator.op_code=assign
145 then arg_list->element(k) ,
146 a = a->operand(2);
147
148 goto by_value;
149 end;
150
151 if a->node.type = token_node
152 then if a->token.type & is_constant
153 then goto by_value;
154
155 q = copy_expression((a));
156 q = expression_semantics(blk,stmnt,q,this_context);
157
158 if q->node.type^=reference_node
159 then do;
160
161
162
163
164
165
166 if q->node.type^=operator_node
167 then goto undo;
168 if q->op_code^=std_call
169 then goto undo;
170 if ^q->operand(1)->reference.symbol->symbol.return_value
171 then if ^q->operand(1)->reference.symbol->symbol.varying
172 then goto undo;
173 a = q;
174
175 if p^=null
176 then if ^match_arguments((q->operand(1)),p)
177 then goto by_value;
178
179 if descriptors_required
180 then desc_list->list.element(k) = share_expression((q->operand(1)->reference.symbol->symbol.descriptor));
181
182 goto next;
183 end;
184
185 if q -> reference.symbol -> node.type ^= symbol_node
186 then goto undo;
187
188 if q->reference.symbol->symbol.constant
189 then goto undo;
190
191
192
193 sym = q->reference.symbol;
194 array_ptr = sym->symbol.array;
195 descr_ptr = sym->symbol.descriptor;
196
197 if def_this_context.cross_section
198 then do;
199 bound_ptr = array_ptr->array.bounds;
200 subs = q->reference.offset;
201
202 if sym->symbol.defined & ^ sym->symbol.overlayed
203 then do;
204 if sym->symbol.isub
205 then do;
206 call semantic_translator$error(296,sym);
207 goto undo;
208 end;
209
210 based_ref = copy_expression(sym->symbol.equivalence);
211
212 if ^lookup((sym->symbol.block_node),stmnt,based_ref,based_sym,"0"b)
213 then call semantic_translator$abort(175,sym);
214
215 if based_ref->node.type^=reference_node
216 then call semantic_translator$abort(343,sym);
217
218 based_ref->reference.symbol = based_sym->symbol.token;
219 if subs=null
220 then do;
221 subs = copy_expression(based_ref->reference.offset);
222 sym = based_sym;
223 end;
224 else do;
225 t = copy_expression(based_ref->reference.offset);
226 j = 0;
227
228 do i = 1 to subs->list.number;
229 test:
230 j = j+1;
231 if j>t->list.number
232 then call semantic_translator$abort(175,sym);
233
234 if t->element(j)->node.type^=token_node
235 then goto test;
236
237 if t->element(j)->token.type^=asterisk
238 then goto test;
239
240 if subs->element(i)->node.type=token_node
241 then if subs->element(i)->token.type=asterisk
242 then ;
243 else t->element(j) = subs->element(i);
244 else t->element(j) = subs->element(i);
245 end;
246
247 subs = t;
248 sym = based_sym;
249 end;
250
251 array_ptr = sym->symbol.array;
252 descr_ptr = sym->symbol.descriptor;
253 bound_ptr = array_ptr->array.bounds;
254
255 based_ref->reference.offset = null;
256 q = expression_semantics(blk,stmnt,based_ref,this_context);
257
258 if q=sym->symbol.reference
259 then q = copy_expression((q));
260
261 q->reference.offset = subs;
262 end;
263 else based_ref = null;
264
265 newarray = create_array();
266 newarray->array = array_ptr->array;
267 newarray->array.number_of_dimensions ,
268 newarray->array.own_number_of_dimensions = 0;
269 newbound = null;
270
271 do i = 1 to subs->list.number;
272 if subs->element(i)->node.type=token_node
273 then if subs->element(i)->token.type=asterisk
274 then do;
275 newarray->array.number_of_dimensions ,
276 newarray->array.own_number_of_dimensions = newarray->array.number_of_dimensions + 1;
277
278 if newbound=null
279 then do;
280 newbound = create_bound();
281 newarray->array.bounds = newbound;
282 end;
283 else do;
284 newbound->bound.next = create_bound();
285 newbound = newbound->bound.next;
286 end;
287
288 newbound->bound = bound_ptr->bound;
289 newbound->bound.next = null;
290
291 if bound_ptr->bound.lower = null
292 then subs->element(i) = declare_constant$integer((bound_ptr->bound.c_lower));
293
294 else subs->element(i) = copy_expression(bound_ptr->bound.lower);
295 end;
296
297 bound_ptr = bound_ptr->bound.next;
298 end;
299
300 sym->symbol.array = newarray;
301 sym->symbol.descriptor = null;
302
303 if p^=null
304 then if ^match_arguments(q,p)
305 then do;
306 call semantic_translator$error(47,q);
307 sym->symbol.array = array_ptr;
308 sym->symbol.descriptor = descr_ptr;
309 goto undo;
310 end;
311
312 sym->symbol.array = array_ptr;
313 q->reference.offset = copy_expression(sym->symbol.reference->reference.offset);
314
315 if q -> reference.qualifier ^= null
316 then do;
317 pl1_stat_$index = pl1_stat_$index + 1;
318 if pl1_stat_$index > hbound(pl1_stat_$locator,1)
319 then call print(70);
320 pl1_stat_$locator(pl1_stat_$index) = q;
321 end;
322
323 q = subscripter(blk,stmnt,q,subs,sym);
324 q->reference.offset = expression_semantics(blk,stmnt,(q->reference.offset),"0"b);
325 call simplify_offset(q,"0"b);
326
327 if q -> reference.qualifier ^= null
328 then pl1_stat_$index = pl1_stat_$index - 1;
329
330 q->reference.array_ref = "1"b;
331 sym->symbol.array = newarray;
332 end;
333 else do;
334 if p^=null
335 then if ^match_arguments(q,p)
336 then do;
337 call print(47);
338 go to undo;
339 end;
340
341 if sym->symbol.defined
342 then if sym->symbol.structure | q->reference.array_ref
343 then do;
344 q = defined_reference(blk,stmnt,q,null,sym,this_context);
345 if q->reference.offset ^= null
346 then do;
347 q->reference.offset = expression_semantics(blk,stmnt,(q->reference.offset),"0"b);
348 call simplify_offset(q,"0"b);
349 end;
350 end;
351 end;
352
353 a = q;
354 sa = a->reference.symbol;
355 call propagate_bit(sa,set_bit);
356 call propagate_bit(sa,passed_as_arg_bit);
357
358 if sa->symbol.static
359 | sa->symbol.controlled
360 then call propagate_bit(sa,aliasable_bit);
361
362 if sa->symbol.entry
363 then if sa->symbol.internal
364 then if sa->symbol.constant
365 then do q = sa->symbol.block_node repeat q->block.father while(q^=null);
366 q->block.flush_at_call = "1"b;
367 end;
368
369 if desc_list->list.element(k)^=null
370 then if ^descriptors_required
371 then call print(89);
372 else ;
373 else if descriptors_required
374 then desc_list->list.element(k) = declare_descriptor(blk,stmnt,sa,
375 (a->reference.qualifier),
376 a->reference.array_ref || def_this_context.cross_section);
377
378 sym->symbol.array = array_ptr;
379 sym->symbol.descriptor = descr_ptr;
380
381 go to next;
382
383 undo:
384 if old = null
385 then q = blk->block.prologue;
386 else q = old->statement.next;
387 do q = q repeat q->statement.next while(q^=stmnt);
388 q->statement.root = null;
389 q->statement.statement_type = null_statement;
390 end;
391 ^L
392 by_value:
393 op = create_operator(assign,2);
394
395 if p=null
396 then do;
397 q = create_symbol(null,null,by_compiler);
398 q->symbol.temporary = "1"b;
399 op->operand(1) = q->symbol.reference;
400 end;
401 else op->operand(1) = p->symbol.reference;
402
403 op->operand(2) = a;
404 a ,
405 op = expression_semantics(blk,stmnt,op,this_context);
406
407 if op->node.type=operator_node
408 then op = op->operand(1);
409
410 if descriptors_required
411 then desc_list->list.element(k) = declare_descriptor(blk,stmnt,(op->reference.symbol),
412 (op->reference.qualifier),(op->reference.array_ref));
413
414 next:
415 arg_list->element(k) = a;
416
417 if p_desc_list^=null
418 then p_desc_list = p_desc_list->element(2);
419 end;
420 ^L
421 process_returns:
422 if stmnt->statement.statement_type=call_statement
423 & def_context.top
424 then if ^s->symbol.returns
425 then ;
426 else do;
427 do p = s->symbol.dcl_size repeat p->symbol.dcl_size while(p->symbol.entry);
428 q = create_operator(std_call,3);
429 q->operand(2) = tree->operand(2);
430 q->operand(3) = create_operator(std_arg_list,3);
431 q->operand(3) = tree->operand(3);
432
433 tree->operand(2) = expression_semantics(blk,stmnt,q,"0"b);
434 tree->operand(3) = null;
435
436 if ^p->symbol.returns
437 then goto ret;
438 end;
439
440 call print(88);
441 end;
442
443 else if ^s->symbol.returns
444 then call print(263);
445
446 if s->symbol.returns
447 then do;
448 if arg_list_op=null
449 then tree->operand(3) ,
450 arg_list_op = save_arg_list_op;
451
452 n = n+1;
453 a = arg_list;
454 arg_list_op->operand(2),arg_list = create_list(n);
455
456 do k = 1 to n-1;
457 arg_list->element(k) = a->element(k);
458 end;
459
460 q = s->symbol.dcl_size;
461
462 if q->symbol.star_extents then descriptors_required = "1"b;
463
464 if q->symbol.structure | q->symbol.dimensioned | q->symbol.star_extents
465 then do;
466
467
468
469 q = copy_expression(s->symbol.dcl_size);
470 call declare(q);
471 end;
472
473 if descriptors_required
474 then do;
475 desc_list->list.element(n) = copy_expression(q->symbol.descriptor);
476
477 if q->symbol.star_extents
478 then do;
479 desc_list->list.element(n)->reference.shared = "0"b;
480 desc_list->list.element(n)->reference.ref_count = 1;
481 end;
482 end;
483
484 tree->operand(1) ,
485 arg_list->element(n) ,
486 r = copy_expression(q->symbol.reference);
487 r->reference.shared = "0"b;
488 r->reference.ref_count = 2;
489
490 if q->symbol.star_extents & (q->symbol.bit|q->symbol.char) & ^ q->symbol.varying
491 then do;
492 op = create_operator(desc_size,2);
493 op->operand(1) = declare_temporary(integer_type,max_length_precision,0,null);
494 op->operand(2) = desc_list->list.element(n);
495 op->operator.processed = "1"b;
496 desc_list->list.element(n)->reference.ref_count = 2;
497 r->reference.length = op;
498 end;
499 else r->reference.length = null;
500
501 if q->symbol.dimensioned | q->symbol.structure | q->symbol.star_extents
502 then do;
503 def_context.aggregate = q->symbol.dimensioned | q->symbol.structure;
504
505 if def_context.aggregate & def_context.by_name_assignment
506 then call print(382);
507
508 if q->symbol.star_extents
509 then do;
510
511
512
513
514
515 stmnt->statement.force_nonquick = "1"b;
516 call make_non_quick((stmnt->statement.root),"001"b);
517 end;
518
519 q = create_statement(assignment_statement,
520 (stmnt->statement.back),null,(stmnt->statement.prefix));
521 q->statement.root = tree;
522
523 arg_list->element(n)->reference.ref_count = 3;
524 end;
525 end;
526
527 if descriptors_required
528 then do;
529 arg_list_op->operand(3) = desc_list;
530 call check_star_extents(s,arg_list);
531 end;
532
533
534
535
536
537 if arg_list_op^=null
538 then do;
539 if descriptors_required
540 then n = n+n;
541
542 if s->symbol.internal | s->symbol.variable
543 then n = n+1;
544
545 arg_list_op->operand(1) = declare_temporary(storage_block_type,(n+1)*2,0,null);
546 end;
547
548 ret:
549 return(tree);
550 ^L
551
552
553 print: proc(m);
554
555 dcl m fixed bin(15);
556
557 dcl pp ptr;
558
559 if m^=47
560 then call semantic_translator$abort(m,s);
561
562 pp = q;
563
564 if pp->node.type=operator_node then pp = pp->operand(1);
565 if pp->node.type=reference_node then pp = pp->reference.symbol;
566
567 if pp->symbol.dcl_type^=by_compiler
568 then call semantic_translator$error(m,q);
569
570 end print;
571
572
573 end function;