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 /* Procedure to compile entry statements
 12 
 13    Initial Version: 31 March 1971 by BLW for Version II
 14           Modified:  29 December 1972 by BLW
 15           Modified:  23 June 1975 by EEW for new entry format
 16           Modified: 25 September 1975 by RAB to remove labels in prev implementation
 17           Modified: 17 May 1977 by RAB to check for reserved external name
 18           Modified: 15 Feb 1978 by PCK to implement options(main) */
 19 
 20 compile_entry: proc(pt,pos);
 21 
 22 dcl       pt ptr,             /* point at statement node */
 23           pos fixed bin(18);            /* set to position of symbol_link info */
 24 
 25 dcl       (cg_stat$text_base,cg_stat$def_base,cg_stat$validate_proc,cg_stat$cur_entry,cg_stat$desc_list_ptr,
 26            cg_stat$entry_arg,cg_stat$cur_block,cg_stat$text_reloc_base,
 27            cg_stat$cur_statement) ptr ext,
 28           cg_stat$last_def bit(18) aligned ext,
 29           cg_stat$support bit(1) aligned ext,
 30           cg_stat$separate_static bit(1) ext,
 31           cg_stat$text_pos fixed bin(18) ext;
 32 
 33 dcl       (p,ep,lp,cb,ent_pt,tree,q,pa,p1,q1,q2,q3,arg(2),desc_pt,desc_list_ptr,def_ptr) ptr,
 34           bi_size fixed bin,
 35           (gen_dummy, not_found) bit(1) aligned,
 36           bit_image bit(bi_size) aligned based,
 37           entry_type fixed bin(15),
 38           (i,n,m,om,text_pos,ed) fixed bin(18);
 39 
 40 dcl       expmac$fill_usage entry(fixed bin(18),fixed bin(17)),
 41           store entry(ptr),
 42           expmac$many entry(fixed bin(15),ptr,fixed bin),
 43           expmac$zero entry(fixed bin(15)),
 44           base_man$update_base entry(fixed bin,ptr,fixed bin);
 45 dcl       base_man$load_arg entry(fixed bin,ptr) returns(bit(3) aligned);
 46 dcl       create_list entry(fixed bin(18)) returns(ptr),
 47           get_variable entry(ptr) returns(ptr),
 48           c_a entry(fixed bin,fixed bin) returns(ptr),
 49           generate_definition entry(char(*) aligned,fixed bin(3),bit(18) aligned),
 50           expmac entry(fixed bin(15),ptr),
 51           error entry(fixed bin,ptr,ptr);
 52 
 53 dcl       (addr,addrel,bit,fixed,index,null,rel,size,substr) builtin;
 54 
 55 dcl       1 reloc(0:3)        aligned based,
 56           2 skip1             unal bit(12),
 57           2 left              unal bit(6),
 58           2 skip2             unal bit(12),
 59           2 right             unal bit(6);
 60 
 61 dcl       based_fixed fixed bin based;
 62 
 63 dcl       1 text_desc_reloc   aligned based,
 64           2 number            fixed bin (18) unsigned unaligned,
 65           2 array (num_descs refer (text_desc_reloc.number)) unaligned,
 66             3 skip            bit(12),
 67             3 reloc           bit(6);
 68 
 69 dcl       1 entry_info        aligned based,
 70           2 num_args          unal bit(17),
 71           2 skip              unal bit(1),
 72           2 filler            unal bit(18),
 73           2 symbol_link       unal bit(18),
 74           2 symbol_block      unal bit(18);
 75 
 76 dcl (     entry_macro         init(196),
 77           quick_entry_mac     init(364),
 78           ext_entry           init(594),
 79           ss_ext_entry        init(646),
 80           ss_op_offset        init(198),
 81 /*        ldfx2               init(8), */
 82 /*        pf_mac              init(113), */
 83 /*        quick_desc_mac      init(279), */
 84           get_desc_size       init(284),
 85           support_mac         init(305),
 86           set_main_mac        init(728),
 87           nop_mac             init(312)) fixed bin(15) int static options(constant);
 88 
 89 %include definition;
 90 %include block;
 91 %include statement;
 92 %include list;
 93 %include operator;
 94 %include symbol;
 95 %include token;
 96 %include reference;
 97 %include nodes;
 98 %include relocation_bits;
 99 %include op_codes;
100 %include statement_types;
101 %include entry_sequence_info;
102 
103           cg_stat$cur_entry, p = pt;
104           ent_pt = p -> statement.labels -> list.element(2) -> reference.symbol;
105           tree = p -> statement.root;
106           text_pos = cg_stat$text_pos;
107 
108           cb = cg_stat$cur_block;
109 
110           ed = 0;
111           num_descs = tree -> operator.number;
112           do i = 1 to num_descs;
113                if tree -> operand(i) -> reference.symbol -> symbol.star_extents
114                 | tree -> operand(i) -> reference.symbol -> symbol.exp_extents            /* fortran */
115                then do;
116                     ed = 1;
117                     goto l1;
118                     end;
119                end;
120 
121 l1:       if cb -> block.no_stack
122           then do;
123                call expmac(quick_entry_mac + fixed(num_descs > 0,1) + ed,
124                 c_a((cb -> block.entry_info),4));
125                if num_descs > 0
126                     then call base_man$update_base(6 + ed,cb,1);
127                goto define;
128                end;
129 
130           /* generate definition(s) for entry point */
131 
132           q = ent_pt -> symbol.token;
133           p = addrel(cg_stat$text_base,text_pos);
134 
135           /* In the following block of code, we have these pointers:
136 
137                     p ->      entry_sequence
138                     ep ->     relocation for entry_sequence
139                     q1 ->     parm_desc_ptrs
140                     q2 ->     relocation for parm_desc_ptrs */
141 
142           if ent_pt -> symbol.external
143           then do;
144                if cg_stat$validate_proc = null then n = 0; else n = 4;
145 
146                if num_descs = 0
147                then do;
148 
149                     /* no descriptors, we need not have prefix word or descriptor array */
150 
151                     p = addrel(p,-1);
152                     ep = addrel(cg_stat$text_reloc_base,text_pos - 1);
153                     text_pos = text_pos + 1;
154                     end;
155 
156                else do;
157 
158                     /* we have descriptors, we will need to build array of pointers or use old one */
159 
160                     q1 = p;
161                     q2 = addrel(cg_stat$text_reloc_base,text_pos);
162 
163                     q1 -> parm_desc_ptrs.n_args = fixed(num_descs,18);
164 
165                     /* construct array of entry-descriptor pointers */
166 
167                     do i = 1 to num_descs;
168                          desc_pt = tree -> operand(i) -> reference.symbol -> symbol.descriptor
169                           -> reference.symbol;
170                          if ^ desc_pt -> symbol.constant then desc_pt = desc_pt -> symbol.descriptor;
171                          q1 -> parm_desc_ptrs.descriptor_relp(i) = bit(fixed(desc_pt -> symbol.location,18),18);
172                          q2 -> text_desc_reloc.reloc(i) = rc_t;
173                          end;
174 
175                     bi_size = (num_descs + 1) * 18;
176 
177                     /* determine if the array  already exists in the text section */
178 
179                     not_found = "1"b;
180                     lp = cg_stat$desc_list_ptr;
181 
182                     do while(lp ^= null & not_found);
183                          if q1 -> bit_image = lp -> list.element(2) -> bit_image
184                               then not_found = "0"b;
185                               else lp = lp -> list.element(1);
186                          end;
187 
188                     if not_found
189                     then do;
190 
191                          /* No; put the array on the list of such arrays */
192 
193                          desc_list_ptr = create_list(2);
194                          desc_list_ptr -> list.element(1) = cg_stat$desc_list_ptr;
195                          cg_stat$desc_list_ptr = desc_list_ptr;
196                          desc_list_ptr -> list.element(2) = q1;
197 
198                          text_pos = text_pos + size(q1 -> parm_desc_ptrs);
199                          p = addrel(cg_stat$text_base,text_pos);
200                          p -> entry_sequence.descr_relp_offset = rel(q1);
201                          end;
202 
203                     else do;
204 
205                          /* Yes; use the old array */
206 
207                          q1 -> bit_image = "0"b;
208                          q2 -> bit_image = "0"b;
209                          q1 -> entry_sequence.descr_relp_offset = rel(lp -> list.element(2));
210                          end;
211 
212                     ep = addrel(cg_stat$text_reloc_base,text_pos);
213 
214                     ep -> reloc(0).left = rc_t;
215                     p -> entry_sequence.has_descriptors = "1"b;
216 
217                     text_pos = text_pos + 2;
218                     end;
219 
220                m = index(q -> token.string,"$");
221                call generate_definition(substr(q->token.string,m+1),0,bit(text_pos,18));
222                def_ptr = addrel(cg_stat$def_base,cg_stat$last_def);
223 
224                if substr(q -> token.string,m+1) = "symbol_table"
225                     then call error(364,cg_stat$cur_statement,null);
226 
227                gen_dummy = m ^= 0;
228 
229                end;
230 
231           else do;
232 
233                /* internal entry, we need no descriptor information */
234 
235                n = 2;
236                p = addrel(p,-1);
237                ep = addrel(cg_stat$text_reloc_base,text_pos-1);
238                text_pos = text_pos + 1;
239                gen_dummy = "1"b;
240                end;
241 
242           if gen_dummy
243           then do;
244 
245                /* entry name is of form a$b or we have internal entry,
246                   generate dummy def for use in labelling entry */
247 
248                call generate_definition(q -> token.string,0,bit(text_pos,18));
249 
250                def_ptr = addrel(cg_stat$def_base,cg_stat$last_def);
251                def_ptr -> definition.ignore = "1"b;
252                end;
253 
254           def_ptr -> definition.retain = "1"b;
255           p -> entry_sequence.revision_1 = "1"b;
256           p -> entry_sequence.variable = ent_pt -> symbol.variable_arg_list;
257           p -> entry_sequence.function = ent_pt -> symbol.returns;
258           p -> entry_sequence.def_relp = cg_stat$last_def;
259           ep -> reloc(1).left = rc_dp;
260 
261           /* generate entry macro */
262 
263           cg_stat$text_pos = text_pos;
264 
265           if cg_stat$separate_static
266              then entry_type = ss_ext_entry;
267              else entry_type = ext_entry;
268 
269           if cg_stat$entry_arg = null then call expmac$zero(entry_type + n + ed);
270           else do;
271                if cg_stat$separate_static
272                   then om = ss_op_offset;
273                   else om = 0;
274                arg(1) = c_a(om + n + ed,11);           /* bp|... */
275                arg(2) = cg_stat$entry_arg;
276                call expmac$many(entry_macro,addr(arg),2);
277                end;
278 
279           /* fill in entry trailer info */
280 
281           p = addrel(cg_stat$text_base,cg_stat$text_pos);
282           p -> entry_info.num_args = bit(fixed(num_descs,17),17);
283           pos = cg_stat$text_pos + 1;
284           cg_stat$text_pos = cg_stat$text_pos + 2;
285 
286           /* generate validate trailer if needed */
287 
288           if n = 4
289           then do;
290                p = c_a((cg_stat$validate_proc -> symbol.location),2); /* k),dl */
291                p -> reference.relocation = rc_lp18;
292                call expmac(nop_mac,p);
293                end;
294 
295           /* entry operator loads the lp */
296 
297           call base_man$update_base(5,null,2);
298 
299           /* generate code to set support bit, if specified */
300 
301           if cg_stat$support
302                then call expmac$zero((support_mac));
303 
304           /* set main_proc bit if procedure is options(main) */
305 
306           if cb->block.options_main & pt->statement.statement_type = procedure_statement
307                then call expmac$zero((set_main_mac));
308 
309           /* assign entry to current position */
310 
311 define:   call expmac$fill_usage(text_pos,(ent_pt -> symbol.location));
312           ent_pt -> symbol.location = text_pos;
313           ent_pt -> symbol.allocated = "1"b;
314 
315           /* The following code attempts to optimize reference to incoming arguments
316              by extracting and saving the offsets and sizes of the arguments.  When
317              a later reference is made to the expression
318                               bit_pointer(param_ptr(k,block))
319              the value stored in the 2*k-1 ptr in the list attached to the block
320              will be accessed.  Similarly for the expression
321                               desc_size(param_desc_ptr(k,block))
322              and the value in element 2*k.        */
323 
324           n = 2 * tree -> operator.number;
325           p = cb -> block.o_and_s;
326 
327           if p = null then cb -> block.o_and_s, p = create_list(n);
328           else if n > p -> list.number
329                then do;
330                     q = create_list(n);
331                     do i = 1 to p -> list.number;
332                          q -> element(i) = p -> element(i);
333                          end;
334                     cb -> block.o_and_s, p = q;
335                     end;
336 
337           /* If this is an entry which returns something with * extent,
338              don't look at return parameter */
339 
340           m = tree -> operator.number;
341           pa = ent_pt -> symbol.dcl_size;
342           if pa ^= null
343           then if pa -> symbol.star_extents
344                then m = m - 1;
345 
346           pa = c_a(0,4);
347 
348           /* Now do all of the sizes */
349 
350           do i = 1 to m;
351                q = tree -> operand(i);
352                q1 = q -> reference.length;
353                if q1 = null
354                then do;
355                     q2 = q -> reference.symbol;
356                     if ^ q2 -> symbol.area then goto step;
357                     if ^ q2 -> symbol.star_extents then goto step;
358 
359                     /* have area(*) parameter, have to extract size even though
360                        no explicit desc_size operator appears */
361 
362                     q2 = q -> reference.qualifier;
363                     if q2 = null then goto step;
364 
365                     if q2 -> node.type ^= operator_node then goto step;
366                     if q2 -> op_code ^= param_ptr then goto step;
367 
368                     if q2 -> operand(3) ^= cb then goto step;
369 
370                     if q2 -> operand(2) -> reference.symbol -> symbol.initial -> based_fixed ^= i then goto step;
371 
372                     q3 = c_a(2*(i-1),4);
373                     q3 -> address.base = base_man$load_arg(1,cb);
374                     q3 -> address.tag = "010000"b;          /* * */
375 
376                     goto gds;
377                     end;
378 
379                if q1 -> node.type ^= operator_node then goto step;
380                if q1 -> op_code ^= desc_size then goto step;
381 
382                q2 = q1 -> operand(2);
383                if q2 -> node.type ^= reference_node then goto step;
384 
385                q2 = q2 -> reference.qualifier;
386                if q2 = null then goto step;
387 
388                if q2 -> node.type ^= operator_node then goto step;
389                if q2 -> op_code ^= param_desc_ptr then goto step;
390 
391                if q2 -> operand(3) ^= cb then goto step;
392                if q2 -> operand(2) -> reference.symbol -> symbol.initial -> based_fixed ^= i then goto step;
393 
394                q3 = q1 -> operand(2);
395 
396                /* we found a length expression to evaluate, make sure we have
397                   an automatic integer variable in which to save it */
398 
399 gds:           p1 = p -> element(2*i);
400                if p1 = null then p -> element(2*i), p1 = get_variable(cb);
401 
402                call expmac((get_desc_size),q3);
403                call store(p1);
404 
405 step:          end;
406 
407           end;