1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  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 /* call validate to supply defaults and check for correctness of the declared attributes. */
 60 
 61           call validate(s);
 62 
 63 /* Set the aliasable bit */
 64 
 65           if s -> symbol.based | s -> symbol.parameter | s -> symbol.defined | s -> symbol.external
 66           then s -> symbol.aliasable = "1"b;
 67 
 68 /* set the padded bit for this level one scalar.  */
 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 /* if parameter, returns descriptor, or controlled variable, replace the asterisks with references to descriptors.      */
 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 /* determine the storage size and boundary requirement.     */
 85 
 86           call get_size(s);
 87 
 88 /* Make sure the value will fit in a segment */
 89 
 90           if s -> symbol.c_word_size > max_words_per_variable
 91           then call semantic_translator$error (357,s);
 92 
 93 /* If the variable requires a descriptor and has constant extents, declare_
 94    descriptor must be called after the extents have been calculated in order
 95    to actually declare the constant descriptor */
 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 /* A character string constant is genenerated for condition constants */
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 /* If this is an entry process its returns descriptor and parameter descriptors.
119 
120    Entry constants denoting entry points in this program have an initial pointer
121    which points to an entry or procedure statement and an equivalence pointer which
122    points to the block node containing the entry or procedure statement.  Entry variables
123    and external entry constants in other programs do not have these pointers but do have a descriptor
124    list attached to their general pointer.
125 
126    If a return_value is an aggregate or has star_extents, we delay declaring it
127    by copying it so that function can get a unique copy each time the function
128    is invoked, because of addressing and descriptor problems.  This fixes
129    bugs 1217 and 1311.                            */
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 /* this is an entry constant declared by a label prefix */
158 
159                     /* make sure it was not multiply declared */
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 /* Use the parameters of the entry as templates to create parameter descriptors.  The
199    parameter descriptors are processed as if they were in the same block as the
200    parameter from which they were derived so that they will recieve the same defaults.  */
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 /* Search the list of return values attached to the block node of the procedure and
210    find a return value whose attributes match the attributes of the value returned
211    by this entry.  If such a value is found, replace this return value with the  value
212    already recorded in the block node.  If no such value can be found, record this return
213    value in the block node.  When more than one return value is recorded in the block
214    node an automatic integer variable is declared and a pointer to it is also recorded
215    in the block node.  During semantic translation of an entry statement this automatic
216    variable is assigned a number which identifies which return type is to be used
217    on return from the procedure.  During semantic translation of the return statement
218    code is generated to test the value of that automatic variable and assign the return
219    value to the proper return parameter.          */
220 
221 /* If there is no return value, a null list element will be on the list
222    of return values to represent that entry statement's "null" return value.     */
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;      /* simply use this null list node */
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 /* copy the return parameter's declaration to create a return descriptor that will be
258    used as the return temporary when this entry is invoked.  */
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 /* create prologue to allocate automatic variables with variable sizes.         */
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 /* parameters which appear in more than one position are accessed via an
310    automatic pointer set by the entry.  All other parameters are accessed via a
311    pointer valued operator whose 2nd operand is the parameter's position.       */
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 /* File constants are initialized by the prologue the
340    first time it is executed in the process.      */
341 
342           if s->symbol.file
343           then      if s->symbol.constant
344           then      call expand_initial(s,null,null);
345 
346 /* packed based scalar variables are accessed via bit valued pointers and
347    the bit offset contained in the pointer must be included as a term in the offset.  */
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 /* if this is a return descriptor and no star extents where found then the storage class
367    should be changed to temporary instead of return_value.  It is not possible to
368    do this sooner as it will foul-up several programs that must be able to recognize
369    return descriptors.  */
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           /* propagates up star_extents in structure */
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           /* prepares a vector of statement pointers for a label array */
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;