1
2
3
4
5
6
7
8
9
10
11 declare: proc(ps);
12
13 dcl (ps,s,b,d,p,q,p1,rv) ptr;
14 dcl (i,n) fixed bin(15);
15 dcl cdesc bit(1);
16
17 dcl pl1_stat_$eis_mode bit(1) aligned ext static;
18
19 dcl condition_abreviations(9) char(8) int static
20 initial("conv","fofl","ofl","strg","strz","subrg","undf","ofl","zdiv");
21 dcl condition_constants(9) char(16) int static varying
22 initial("conversion","fixedoverflow","overflow","stringrange","stringsize",
23 "subscriptrange","undefinedfile","underflow","zerodivide");
24 dcl (string,fixed,null,substr) builtin;
25 ^L
26 s = ps;
27 if s=null then return;
28 if s->node.type ^= symbol_node
29 then do;
30 if s -> label.array
31 then call declare_label_array;
32 return;
33 end;
34
35 if s->symbol.boundary ^= 0 then return;
36 if s->symbol.father ^= null then return;
37
38 if s->symbol.son ^= null
39 then do;
40 if s->symbol.level ^= 1
41 then do;
42 call semantic_translator$error(149,s);
43 s->symbol.level = 1;
44 end;
45
46 call declare_structure(s);
47
48 go to exit;
49 end;
50
51 if s-> symbol.structure
52 then do;
53 call semantic_translator$error(98,s);
54 s->symbol.structure = "0"b;
55 s->symbol.level = 0;
56 end;
57
58
59
60
61 call validate(s);
62
63
64
65 if s -> symbol.based | s -> symbol.parameter | s -> symbol.defined | s -> symbol.external
66 then s -> symbol.aliasable = "1"b;
67
68
69
70 if s->symbol.packed
71 then s->symbol.reference->reference.padded_ref =
72 ^(s->symbol.based|s->symbol.parameter|s->symbol.defined);
73
74 b=s->symbol.block_node;
75
76
77
78 cdesc = s->symbol.parameter | s->symbol.return_value | s->symbol.controlled;
79
80 if cdesc
81 then if s->symbol.star_extents | s->symbol.exp_extents
82 then s->symbol.descriptor = declare_descriptor$param((s->symbol.block_node),null,s,null,"1"b);
83
84
85
86 call get_size(s);
87
88
89
90 if s -> symbol.c_word_size > max_words_per_variable
91 then call semantic_translator$error (357,s);
92
93
94
95
96
97 if cdesc
98 then if s->symbol.descriptor = null
99 then s->symbol.descriptor = declare_descriptor((s->symbol.block_node),null,s,null,"1"b);
100
101
102
103 if s->symbol.condition
104 then do;
105 if s->symbol.dcl_type ^= by_compiler then s->symbol.equivalence = s;
106 do i = 1 to 9;
107 if s->symbol.token->token.string = condition_abreviations(i)
108 then do;
109 s->symbol.general = declare_constant$char((condition_constants(i)));
110 go to loop_exit;
111 end;
112 end;
113
114 s->symbol.general = declare_constant$char((s->symbol.token->token.string));
115 end;
116 loop_exit:
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131 if s->symbol.entry
132 then do;
133 if s->symbol.returns
134 & (s->symbol.constant & s->symbol.initial=null
135 | s->symbol.variable)
136 then do;
137 rv = s->symbol.dcl_size;
138 rv->symbol.return_value = "1"b;
139 if rv->symbol.structure | rv->symbol.dimensioned | rv->symbol.star_extents
140 then do;
141 s->symbol.dcl_size = copy_expression(s->symbol.dcl_size);
142 call declare(rv);
143 s->symbol.dcl_size->symbol.star_extents = rv->symbol.star_extents;
144 end;
145 else call declare(rv);
146 end;
147
148 do p=s->symbol.general repeat p->element(2) while(p^=null);
149 p->element(1)->symbol.param_desc = "1"b;
150 call declare((p->element(1)));
151 end;
152
153 if s->symbol.variable then go to allocate;
154 p=s->symbol.initial;
155 if p = null then go to allocate;
156
157
158
159
160
161 d = s->symbol.token->token.declaration;
162 p1 = null;
163 do while(d^=null);
164 if d->symbol.block_node = b & d^=s
165 then if d->node.type = symbol_node
166 then if d->symbol.entry & d->symbol.constant
167 then do;
168 call semantic_translator$abort(213,s);
169 if p1 = null
170 then s->symbol.token->token.declaration = d->symbol.multi_use;
171 else p1->symbol.multi_use = d->symbol.multi_use;
172 end;
173
174 p1 = d;
175 d = d->symbol.multi_use;
176 end;
177
178 p=p->statement.root;
179 n=p->operator.number;
180 if s->symbol.returns then n = n-1;
181 p1=null;
182
183 do i=1 to n;
184 q=create_list(2);
185 if ^lookup((s->symbol.equivalence),null,(p->operator.operand(i)),d,"0"b)
186 then call semantic_translator$abort(194,(p->operand(i)));
187 if d->node.type ^= symbol_node then call semantic_translator$abort(196,d);
188 d->symbol.parameter = "1"b;
189 if d->symbol.location = 0 then d->symbol.location = i;
190 else if d->symbol.location ^= i
191 then d->symbol.allocated ="1"b;
192 q->element(1)=d;
193 if s->symbol.general = null then s->symbol.general = q;
194 if p1 ^= null then p1->element(2)=q;
195 p1=q;
196 end;
197
198
199
200
201
202 do q = s->symbol.general repeat q->element(2) while(q^=null);
203 q->element(1),d = copy_expression(q->element(1));
204 d->symbol.param_desc = "1"b;
205 d->symbol.parameter = "1"b;
206 call declare(d);
207 end;
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224 n = n+1;
225
226 p = s->symbol.equivalence;
227
228 do q = p->block.return_values repeat q->element(1) while(q^=null);
229 if s->symbol.dcl_size = null
230 then if q->element(2) = null
231 then goto allocate;
232 else;
233
234 else if compare_declaration((q->element(2)),(s->symbol.dcl_size),"0"b)
235 then do;
236 p1 = q->element(2);
237 if p1->symbol.location ^= n
238 then p1->symbol.allocated ="1"b;
239 s->symbol.initial->statement.root->operator.operand(n) = p1->symbol.token;
240 go to make_descr;
241 end;
242 end;
243
244 if p->block.return_values ^= null & p->block.return_count = null
245 then p->block.return_count = declare_integer(p);
246
247 q = create_list(2);
248 q->element(1) = p->block.return_values;
249 p->block.return_values = q;
250 q->element(2) = s->symbol.dcl_size;
251
252 if s->symbol.dcl_size = null
253 then goto allocate;
254
255 s->symbol.dcl_size->symbol.location = n;
256
257
258
259
260 make_descr:
261 rv, s->symbol.dcl_size = copy_expression(s->symbol.dcl_size);
262 rv->symbol.return_value = "1"b;
263 rv->symbol.parameter = "0"b;
264 if rv->symbol.structure | rv->symbol.dimensioned | rv->symbol.star_extents
265 then if rv->symbol.structure & ^ rv->symbol.star_extents
266 then call set_star(rv);
267 else;
268 else call declare(rv);
269
270 if rv->symbol.star_extents
271 then do;
272 p -> block.why_nonquick.returns_star_extents = "1"b;
273 p -> block.no_stack = "0"b;
274 end;
275 end;
276
277
278
279 allocate:
280 if s->symbol.auto
281 then do;
282 if s->symbol.word_size ^= null
283 then do;
284 p1 = s->symbol.word_size;
285
286 if p1->node.type = operator_node
287 then do;
288 q=create_operator(assign,2);
289 q->operator.operand(2)=s->symbol.word_size;
290 q->operator.operand(1),s->symbol.word_size,p1 = declare_integer(b);
291 p1->reference.symbol->symbol.c_dcl_size = max_offset_precision;
292 p=create_statement$prologue(assignment_statement,b,null,(b->block.prefix));
293 p->statement.root=q;
294 end;
295
296 q=create_operator(allot_auto,2);
297 q->operator.operand(2)=p1;
298 q->operator.operand(1),
299 s->symbol.reference->reference.qualifier=declare_pointer(b);
300 p=create_statement$prologue(assignment_statement,b,null,(b->block.prefix));
301 p->statement.root=q;
302 end;
303
304 if(s->symbol.area|s->symbol.initialed)
305 then call expand_initial(s,null,null);
306 go to exit;
307 end;
308
309
310
311
312
313 if s->symbol.parameter
314 then do;
315 if s->symbol.allocated
316 then q=declare_pointer(b);
317 else do;
318 q=create_operator(param_ptr,3);
319 q->operator.operand(2) = declare_constant$integer(fixed(s->symbol.location));
320 q->operator.operand(3) = b;
321 end;
322
323 s->symbol.reference->reference.qualifier=q;
324
325 if s->symbol.packed
326 then if pl1_stat_$eis_mode
327 then s->symbol.reference->reference.fo_in_qual = "1"b;
328 else do;
329 p = create_operator(bit_pointer,2);
330 p->operator.operand(2) = q;
331 s->symbol.reference->reference.offset = p;
332 s->symbol.reference->reference.units = bit_;
333 end;
334
335 return;
336 end;
337
338
339
340
341
342 if s->symbol.file
343 then if s->symbol.constant
344 then call expand_initial(s,null,null);
345
346
347
348
349 if s->symbol.based
350 then if s->symbol.packed
351 then if pl1_stat_$eis_mode
352 then s->symbol.reference->reference.fo_in_qual = "1"b;
353 else do;
354 q = create_operator(bit_pointer,2);
355 s->symbol.reference->reference.offset = q;
356 s->symbol.reference->reference.units = bit_;
357 end;
358
359 exit:
360 if s->symbol.auto & s->symbol.exp_extents
361 then do;
362 s -> symbol.block_node -> block.why_nonquick.auto_adjustable_storage = "1"b;
363 s -> symbol.block_node -> block.no_stack = "0"b;
364 end;
365
366
367
368
369
370
371 if s->symbol.return_value & ^s->symbol.star_extents
372 then if s->symbol.structure
373 then call reset_ret_val(s);
374 else do;
375 s->symbol.return_value = "0"b;
376 s->symbol.temporary = "1"b;
377 end;
378
379
380 reset_ret_val: proc(s);
381
382 dcl (s,d) pointer;
383
384 s->symbol.temporary="1"b;
385 s->symbol.return_value="0"b;
386 do d = s->symbol.son repeat d->symbol.brother while (d ^= null);
387 call reset_ret_val(d);
388 end;
389
390 end reset_ret_val;
391
392
393 set_star: proc(ps);
394
395
396
397 dcl (ps,d,s) ptr;
398
399 s = ps;
400 do d = s->symbol.son repeat d->symbol.brother while(d ^= null);
401 call set_star(d);
402 s->symbol.star_extents = s->symbol.star_extents | d->symbol.star_extents;
403 end;
404
405 end set_star;
406
407
408 declare_label_array: proc;
409
410
411
412 dcl (lae,next,vector) ptr;
413 dcl inc fixed bin;
414
415 inc = 1 - s -> label.low_bound;
416 vector = create_list(s -> label.high_bound - s -> label.low_bound + 1);
417
418 do lae = s -> label.statement repeat next while(lae ^= null);
419 vector -> element(lae -> label_array_element.value + inc) = lae -> label_array_element.statement;
420 next= lae -> label_array_element.next;
421 call free_node(lae);
422 end;
423
424 s -> label.statement = vector;
425
426 end;
427
428
429 %include semant;
430 %include symbol;
431 %include block;
432 %include reference;
433 %include list;
434 %include operator;
435 %include statement;
436 %include op_codes;
437 %include statement_types;
438 %include nodes;
439 %include token;
440 %include token_types;
441 %include declare_type;
442 %include boundary;
443 %include label;
444 %include label_array_element;
445 %include system;
446 end declare;