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 alloc_semantics:    proc(cur_block,stmnt,tree);
 12 
 13 /*        Modified: 14 August 1978 by PCK to fix 1735
 14           Modified: 15 August 1978 by RAB to fix 1733
 15           Modified: 16 August 1978 by RAB to fix 1772, 1773, & 1774   */
 16 /*        Modified: 15 Jan 1979 by DS to fix 1783 */
 17 
 18 dcl       (cur_block,stmnt,tree) ptr,
 19           (a,adam,area,b,d,dst,l,locator,next,o,p,r,s,source,size,st) ptr,
 20 
 21           (n,i,processed_bounds,own_num_bounds,number) fixed bin(15);
 22 
 23 dcl       (null,hbound,string) builtin;
 24 
 25 dcl       ref_targ_cnt fixed bin(15) init(0);
 26 
 27 dcl       ref_targ(16) pointer;
 28 
 29 dcl       pl1_stat_$use_old_area external static bit(1) aligned;
 30 
 31 dcl       opcode bit(9) aligned;
 32 
 33 %include semant;
 34 
 35 %include array;
 36 %include boundary;
 37 %include list;
 38 %include nodes;
 39 %include operator;
 40 %include op_codes;
 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 ^L
 49           source = tree->operand(1);
 50 
 51           if source->node.type = label_node
 52           then      call semantic_translator$abort(373,source);       /* alloc or free a label constant */
 53 
 54           s = source->reference.symbol;
 55 
 56           if s->node.type = label_node
 57           then      call semantic_translator$abort(373,s);  /* alloc or free a label constant array */
 58 
 59           if s->symbol.father^=null
 60           then      call semantic_translator$abort(273,s);
 61 
 62           area = tree->operand(2);
 63           locator = source->reference.qualifier;
 64 
 65           st = stmnt;
 66           context = "0"b;
 67 
 68           if tree->operator.op_code=allot_var
 69           then      number = 5;         /* allot_var */
 70           else      number = 151;       /* free_var */
 71 
 72           if s->symbol.controlled
 73           then do;
 74                     if area ^= null then call semantic_translator$abort(114,s);
 75                     r = s->symbol.descriptor;
 76                     d = r->reference.symbol;
 77                     if d->symbol.controlled
 78                     then if number = 5
 79                               then do;  /* We must allocate a controlled descriptor before we allocate the symbol */
 80                                         dst = create_statement(allocate_statement,(st->statement.back),null,(st->statement.prefix));
 81                                         dst->statement.root,
 82                                         o = create_operator(allot_ctl,2);
 83                                         o->operand(1) = r;
 84                                         o->operand(2) = declare_constant$integer((d->symbol.c_word_size));
 85                                         r = declare_descriptor$ctl(cur_block,st,s,null,"1"b);
 86                                         o->operator.processed = "1"b;
 87                                    end;
 88                               else do;  /* We must free a controlled descriptor after we free the data */
 89                                         st = create_statement(free_statement,st,null,(st->statement.prefix));
 90                                         st->statement.root,
 91                                         o = create_operator(free_ctl,1);
 92                                         o->operand(1) = r;
 93                                         o->operator.processed = "1"b;
 94                                    end;
 95                     else;
 96                     if number = 5
 97                     then do;
 98                               o = create_operator(allot_ctl,2);
 99                               call getsize;
100                               o->operand(2) = size;
101                          end;
102                     else o = create_operator(free_ctl,1);
103                     o->operand(1) = source;
104                     tree = o;
105                     if number = 151
106                          then return;
107                          else go to set_next;
108           end;
109 
110           if ^s->symbol.based
111           then      call semantic_translator$abort(115,s);
112 
113           if number=151
114           then      goto process_area;
115 
116           if locator->node.type=operator_node
117           then      if locator->operator.op_code=assign | locator->operator.op_code = ptr_fun
118                     then do;
119                               locator = locator->operand(2);
120                               l = locator->reference.symbol;
121                     end;
122                     else call semantic_translator$abort(68,s);
123           else      l = locator->reference.symbol;
124 
125           call propagate_bit(l,set_bit);
126 
127           if l->symbol.offset
128           then      if area=null
129                     then do;
130                               area = copy_expression(l->symbol.general);
131 
132                               if area=null
133                               then      call semantic_translator$abort(116,l);
134 
135                               area = expression_semantics((l->symbol.block_node),stmnt,area,"0"b);
136 
137                               goto assign_ptr;
138                     end;
139                     else do;
140                               st = create_statement(assignment_statement,st,null,(st->statement.prefix));
141                               st->statement.root  ,
142                               o = create_operator(off_fun,3);
143                               o->operand(3) = share_expression(area);
144 
145                               o->operand(1) = locator;
146 
147                               locator  ,
148                               o->operand(2) = declare_pointer(cur_block);
149 
150                               st->statement.processed = "1"b;
151 
152                               goto create_addr;
153                     end;
154 
155           if ^l->symbol.ptr
156           then      call semantic_translator$abort(117,l);
157 
158           if l->symbol.unaligned & pl1_stat_$use_old_area   /* the new area package needs no  ass. stat at all */
159           then do;
160 assign_ptr:
161                                         /* allot_var */
162                     st = create_statement(assignment_statement,st,null,(st->statement.prefix));
163                     st->statement.root  ,
164                     o = create_operator(assign,2);
165                     o->operand(1) = locator;
166                     locator  ,
167                     o->operand(2) = declare_pointer(cur_block);
168           end;
169 
170 process_area:
171           if area^=null
172           then do;
173                     if area->node.type^=reference_node
174                     then      call semantic_translator$abort(491,null);
175 
176                     if ^area->reference.symbol->symbol.area
177                     then      call semantic_translator$abort(118,area);
178           end;
179           else if pl1_stat_$use_old_area
180                then do;
181                     area = reserve$declare_lib(1);
182                     area->reference.symbol->symbol.allocate = "1"b;
183 
184                     if number=5
185                     then      number = 192;                 /* alloc_$storage_ */
186                     end;
187 
188 create_addr:
189           call getsize;       /* this subroutine sets the "size" ptr  */
190 
191           if pl1_stat_$use_old_area
192           then do;
193 
194                     p = create_operator(addr_fun,2);
195                     p->operand(1) = declare_temporary(pointer_type,0,0,null);
196                     p->operand(2) = area;
197                     area = p;
198 
199                     p = create_list(3);
200 
201                     p->list.element(2) = area;
202 
203                     if number=5         /* allot_var */
204                     |  number=192                           /* alloc_$storage_ */
205                     then do;
206                               p->list.element(1) = size;
207                               p->list.element(3) = locator;
208                     end;
209                     else do;
210                               p->list.element(1) = locator;
211                               p->list.element(3) = size;
212                     end;
213 
214                     o = create_operator(std_call,3);
215                     o->operand(2) = reserve$declare_lib(number);
216                     o->operand(3) = create_operator(std_arg_list,3);
217                     o->operand(3)->operand(1) = declare_temporary(storage_block_type,8,0,null);
218                     o->operand(3)->operand(2) = p;
219 
220                end;
221 
222           else do;
223                     if number = 151
224                     then do;
225                               opcode = free_based;
226                               p = source;         /* op1 of free_based operator is source ptr, i.e. based var */
227                          end;
228                     else do;
229                               opcode = allot_based;
230                               p = locator;        /* op1 of allot_based is locator ptr */
231                          end;
232 
233                     o = create_operator(opcode,3);
234                     o->operand(2) = size;
235                     o->operand(3) = area;
236                     o->operand(1) = p;
237 
238                end;
239 
240 
241           tree = o;
242 
243           if number=151 then return;
244 
245           goto set_next;
246 
247 init_only:entry(locexp,stmnt,tree);
248           dcl locexp ptr;
249 
250           st=stmnt;
251           locator=locexp;
252           s=tree;
253 
254 set_next:
255           next = st->statement.next;
256 
257           adam = s;
258 
259           do while(s ^= null);
260                     if s ^= adam
261                     then do;
262                               if s->symbol.refer_extents
263                               then do;
264                                         call build_assignment(s->symbol.dcl_size);
265 
266                                         if s->symbol.array^=null
267                                         then do;
268                                                   own_num_bounds=s->symbol.array->own_number_of_dimensions;
269                                                   processed_bounds=0;
270 
271                                                   do b = s->symbol.array->array.bounds repeat b->bound.next
272                                                        while(processed_bounds < own_num_bounds);
273                                                             call build_assignment(b->bound.lower);
274                                                             call build_assignment(b->bound.upper);
275                                                             processed_bounds=processed_bounds+1;
276                                                   end;
277                                         end;
278                               end;
279                     end;
280 
281                     if s->symbol.initial^=null
282                     |  s->symbol.area
283                     then      call expand_initial(s,(next->statement.back),locator);
284 
285                     if s -> symbol.son ^= null
286                     then      s = s -> symbol.son;
287                     else do;
288                               do while(s->symbol.brother=null & s ^= adam);
289                                         s = s->symbol.father;
290                               end;
291 
292                               s = s->symbol.brother;
293                     end;
294 
295           end;
296 ^L
297 getsize:  proc;
298 
299 dcl       constant fixed bin;
300 dcl       modified bit(1) aligned;
301 
302           size = copy_expression(s->symbol.word_size);
303           if size=null
304           then      size = declare_constant$integer((s->symbol.c_word_size));
305           else do;
306                     if number=151 & s->symbol.refer_extents
307                     then      call refer_extent(size,locator);
308                     size = expression_semantics((s->symbol.block_node),stmnt,size,context);
309                     size = convert$to_integer(size,integer_type);
310                     call simplify_expression(size,constant,modified);
311                     if modified
312                     then      size=declare_constant$integer((constant));
313           end;
314 
315           p = size;
316           if p->node.type=operator_node
317           then      p = p->operand(1);
318 
319           if p->reference.symbol->symbol.c_dcl_size>max_p_fix_bin_1
320           then do;
321                     r = create_operator(assign,2);
322                     r->operand(1) = declare_temporary(integer_type,max_p_fix_bin_1,0,null);
323                     r->operand(2) = size;
324                     size = r;
325           end;
326 end;
327 ^L
328 build_assignment:   proc(p);
329 
330 dcl       p ptr unal,
331           (o,q,st) ptr;
332 
333           q = p;
334 
335           if q = null then goto exit;
336           if q->node.type^=operator_node then goto exit;
337           if q->operator.op_code^=refer then goto exit;
338           do i=1 to ref_targ_cnt;
339                     if q->operator.operand(2)=ref_targ(i)
340                     then goto exit;
341                     else      if compare_expression((q->operator.operand(2)),ref_targ(i))
342                               then goto exit;
343           end;
344 
345           st = create_statement(assignment_statement,(next->statement.back),null,(stmnt->statement.prefix));
346 
347           st->statement.generated = "1"b;
348           st->statement.root  ,
349           o = create_operator(assign,2);
350           o->operand(2) = copy_expression(q->operand(1));
351 
352           if q->operand(2)->node.type=reference_node
353           then      o->operand(1) = copy_expression(q->operand(2));
354           else      o->operand(1) = create_reference((q->operand(2)));
355 
356           o->operand(1)->reference.qualifier = share_expression(locator);
357 
358           if ref_targ_cnt<hbound(ref_targ,1)
359           then do;
360                     ref_targ_cnt=ref_targ_cnt+1;
361                     ref_targ(ref_targ_cnt)=q->operator.operand(2);
362           end;
363 
364 exit:
365           end build_assignment;
366 
367           end alloc_semantics;