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 encode a variable or expression for use in symbol table
 12 
 13    Initial Version:  7 May 1970 by BLW
 14           Modified:  4 September 1970 by BLW
 15           Modified: 16 February 1972 by BLW for Version II
 16           Modified:  2 July 1972 by BLW for new encoding scheme
 17           Modified: 26 September 1972 by BLW for std object segments
 18           Modified: 21 January 1973 by BLW for controlled storage
 19           Modified: 16 Nov 1979 by PCK to fix 1858 */
 20 
 21 e_v:      proc(symb,coded_value,var,const,code,reloc);
 22 
 23 dcl       symb      ptr,                /* points at symbol node */
 24           coded_value fixed bin,        /* where to store coded value */
 25           var       ptr,                /* variable part of value */
 26           const     fixed bin,          /* constant part of value */
 27           code      fixed bin,          /* type of value */
 28           reloc     bit(36) aligned;    /* relocation (output) */
 29 
 30 dcl       (cg_stat$cur_block,cg_stat$encoded_values,cg_stat$cur_statement,
 31            cg_stat$ev_qual,cg_stat$last_encoded,cg_stat$text_base,
 32            cg_stat$dummy_block,cg_stat$dummy_statement,cg_stat$first_ref,
 33            cg_stat$next_ref) ptr ext,
 34            cg_stat$in_thunk bit(1) ext,
 35           (cg_stat$text_pos,cg_stat$cur_level) fixed bin(18) ext;
 36 
 37 dcl       (vp,cvp,ap,bp,rp,sp,qp,xp,s1,s2,p,arg(2)) ptr,
 38           dl fixed bin(6),
 39           (lab,atomic) aligned bit(1),
 40           macro fixed bin(15),
 41           delta fixed bin(18),
 42           n fixed bin(18),
 43           fb_18 fixed bin(18) based;
 44 
 45 dcl       compare_expression entry(ptr,ptr) returns(bit(1) aligned) reducible;
 46 dcl       (compile_exp,compile_statement) entry(ptr),
 47           expmac entry(fixed bin(15),ptr),
 48           expmac$zero entry(fixed bin(15)),
 49           expmac$many entry(fixed bin(15),ptr,fixed bin),
 50           load entry(ptr,fixed bin),
 51           prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
 52           base_man$load_arg entry(fixed bin,ptr) returns(bit(3) aligned),
 53           state_man$flush entry,
 54           make_mod entry(fixed bin(17),fixed bin) returns(fixed bin(18)),
 55           token_to_binary entry(ptr) reducible returns(fixed bin),
 56           c_a entry(fixed bin,fixed bin) returns(ptr);
 57 
 58 dcl       fix_bin fixed bin based;
 59 
 60 dcl       (addr,addrel,bit,fixed,null,string) builtin;
 61 
 62 dcl       1 value             aligned based(cvp),
 63           2 code              unal bit(6),
 64           2 n1                unal bit(6),
 65           2 n2                unal bit(6),
 66           2 offset            unal bit(18);
 67 
 68 dcl       1 lxl_ins           aligned based,
 69           2 stack_size        unal bit(18),
 70           2 rhs               unal bit(18);
 71 
 72 dcl (     adfx1               init(19),
 73           load_pt_reg         init(172),
 74           end_ev_label        init(322),
 75           beg_ev_proc         init(318),
 76           end_ev_proc         init(319)) fixed bin(15) int static;
 77 
 78 %include pl1_tree_areas;
 79 %include reference;
 80 %include operator;
 81 %include symbol;
 82 %include block;
 83 %include statement;
 84 %include ev_node;
 85 %include nodes;
 86 %include op_codes;
 87 %include boundary;
 88 %include token;
 89 %include token_types;
 90 %include reloc_lower;
 91 
 92 /*^L                Execution begins ... */
 93 
 94           lab = "0"b;
 95 
 96 start:    cvp = addr(coded_value);
 97           delta, coded_value = 0;
 98           reloc = (36)"0"b;
 99 
100           s1 = var;
101           if s1 -> node.type = statement_node
102           then do;
103 
104                /* have a difficult expression which required additional statements to
105                   be generated.  The original expression we encoded is the root of the
106                   last statement node in the chain */
107 
108                s2 = s1;
109                do while(s2 -> statement.next ^= null);
110                     s2 = s2 -> statement.next;
111                     end;
112 
113                vp = s2 -> statement.root;
114                s2 -> statement.root = null;
115                goto diff;
116                end;
117 
118           /* have a (relatively) easy expression */
119 
120           s1 = null;
121           vp = var;
122 
123           if vp -> node.type ^= operator_node then goto chk;
124 
125           if vp -> op_code = bit_pointer
126           then do;
127 pf:            value.code = "100011"b;
128                value.offset = bit(fixed(const + delta,18),18);
129                return;
130                end;
131 
132           if vp -> op_code = add
133           then do;
134 
135                /* check for constant plus bit pointer operator */
136 
137                xp = vp -> operand(3);
138                if xp -> node.type ^= reference_node then goto chk;
139 
140                sp = xp -> reference.symbol;
141                if ^ sp -> symbol.constant then goto chk;
142 
143                ap = vp -> operand(2);
144                if ap -> node.type ^= operator_node then goto chk;
145                if ap -> op_code ^= bit_pointer then goto chk;
146 
147                delta = sp -> symbol.initial -> fb_18;
148                goto pf;
149                end;
150 
151           if vp -> op_code = desc_size
152           then do;
153 
154                /* check for size = reference to incoming descriptor */
155 
156                xp = vp -> operand(2);
157                if xp -> node.type ^= reference_node then goto chk;
158 
159                qp = xp -> reference.qualifier;
160                if qp = null
161                then do;
162 
163                     /* check for controlled descriptor */
164 
165                     ap = xp -> reference.symbol;
166                     if ^ ap -> symbol.arg_descriptor then goto chk;
167                     if ^ ap -> symbol.controlled then goto chk;
168 
169                     value.code = "101101"b;
170 
171                     if ap -> symbol.internal then reloc = rc_a_is18;
172                     else do;
173                          value.n1 = "000001"b;
174                          reloc = rc_a_lp18;
175                          end;
176 
177                     vp = xp;
178                     ap = ap -> symbol.descriptor;
179                     goto l5;
180                     end;
181 
182                if qp -> node.type ^= operator_node then goto chk;
183                if qp -> op_code ^= param_desc_ptr then goto chk;
184 
185                value.code = "101011"b;
186                value.n1 = bit(fixed(cg_stat$cur_level - qp -> operand(3) -> block.level,6),6);
187                value.n2 = bit(fixed(qp -> operand(2) -> reference.symbol -> symbol.initial -> fix_bin,6),6);
188                value.offset = bit(fixed(xp -> reference.c_offset,18),18);
189                return;
190                end;
191 
192           goto hard;
193 
194 chk:      if const ^= 0 then goto hard;
195 
196           if vp -> node.type = token_node
197           then if vp -> token.type = dec_integer
198                then do;
199                     coded_value = token_to_binary(vp);
200                     reloc = "0"b;
201                     return;
202                     end;
203 
204           /* have a reference node, we can encode its value if its
205              word offset is constant */
206 
207 easy:     if vp -> reference.units ^= 0
208           then if vp -> reference.units ^= word_
209                then goto hard;
210 
211           if vp -> reference.offset ^= null then goto hard;
212 
213           rp = vp -> reference.qualifier;
214           if rp ^= null then goto based;
215 
216           ap = vp -> reference.symbol;
217 
218           if vp -> reference.defined_ref then ap = ap -> symbol.initial;
219 
220           if ap -> symbol.constant & ap -> symbol.internal
221           then do;
222                if ^ ap -> symbol.fixed then goto hard;
223                if ^ ap -> symbol.binary then goto hard;
224                if ^ ap -> symbol.real then goto hard;
225                if ap -> symbol.c_word_size ^= 1 then goto hard;
226 
227                coded_value = ap -> symbol.initial -> fix_bin;
228                reloc = "0"b;
229                return;
230                end;
231 
232           bp = ap -> symbol.block_node;
233           dl = cg_stat$cur_level - bp -> block.level;
234 
235           if ap -> symbol.auto
236           then do;
237                if dl > 63 then goto hard;
238                value.n1 = bit(dl,6);
239                value.code = "100000"b;
240 l1:            value.offset = bit(fixed(ap -> symbol.location + vp -> reference.c_offset,18),18);
241                value.n2 = "000000"b;
242                return;
243                end;
244 
245           if ap -> symbol.parameter
246           then do;
247                if dl > 63 then goto hard;
248                if ap -> symbol.location > 63 then goto hard;
249 
250                value.n1 = bit(dl,6);
251                value.n2 = bit(fixed(ap -> symbol.location,6),6);
252                value.offset = bit(fixed(vp -> reference.c_offset,18),18);
253                value.code = "101001"b;
254                return;
255                end;
256 
257           if ap -> symbol.controlled
258           then do;
259                if ap -> symbol.arg_descriptor then value.code = "101110"b;
260                else value.code = "101111"b;
261 
262                if ap -> symbol.internal then reloc = rc_a_is18;
263                else do;
264                     value.n1 = "000001"b;
265                     reloc = rc_a_lp18;
266                     end;
267 
268                goto l5;
269                end;
270 
271           if ^ ap -> symbol.static then goto hard;
272 
273           if ap -> symbol.internal
274           then do;
275                value.code = "100001"b;
276                reloc = rc_a_is18;
277                goto l1;
278                end;
279 
280           value.code = "100010"b;
281           reloc = rc_a_lp18;
282 
283           /* cannot encode if word offset is not positive and less than 64 */
284 
285 l5:       if vp -> reference.c_offset < 0 then goto hard;
286           if vp -> reference.c_offset > 63 then goto hard;
287 
288           value.n2 = bit(fixed(vp -> reference.c_offset,6),6);
289           value.offset = bit(fixed(ap -> symbol.location,18),18);
290 
291           return;
292 
293           /* have a based variable, we can encode it if offset is positive
294              and less than 64 */
295 
296 based:    if vp -> reference.c_offset < 0 then goto hard;
297           if vp -> reference.c_offset > 63 then goto hard;
298 
299           /* use special code if qualifier is the param ptr node created by
300              prepare_symbol_table (a pointer to it was stored in block.context).
301              In this case, we had a refer option */
302 
303           if rp -> reference.qualifier = cg_stat$dummy_block -> block.context
304           then do;
305                value.code = "100111"b;
306                goto l3;
307                end;
308 
309           /* check for param_ptr operator as qualifier */
310 
311           if rp -> node.type = operator_node
312           then do;
313                if rp -> op_code = param_ptr then value.code = "101001"b;
314                else if rp -> op_code = param_desc_ptr then value.code = "101100"b;
315                     else goto hard;
316 
317                dl = cg_stat$cur_level - rp -> operand(3) -> block.level;
318                if dl > 63 then goto hard;
319 
320 l4:            value.n1 = bit(dl,6);
321                value.n2 = bit(fixed(rp -> operand(2) -> reference.symbol -> symbol.initial -> fix_bin,6),6);
322                value.offset = bit(fixed(vp -> reference.c_offset,18),18);
323                return;
324                end;
325 
326           /* the ptr must have a constant offset and must not be itself based */
327 
328           if rp -> reference.offset ^= null then goto hard;
329 
330           ap = rp -> reference.qualifier;
331           if ap ^= null
332           then do;
333                if ap -> node.type ^= operator_node then goto hard;
334                if ap -> op_code ^= param_ptr then goto hard;
335                if rp -> reference.c_offset ^= 0 then goto hard;
336 
337                dl = cg_stat$cur_level - ap -> operand(3) -> block.level;
338                if dl > 63 then goto hard;
339 
340                /* we can handle the case of a variable based on a ptr parameter */
341 
342                value.code = "101010"b;
343                rp = ap;
344                goto l4;
345                end;
346 
347           ap = rp -> reference.symbol;
348           bp = ap -> symbol.block_node;
349           dl = cg_stat$cur_level - bp -> block.level;
350 
351           if ap -> symbol.auto
352           then do;
353                if dl > 63 then goto hard;
354                value.code = "100100"b;
355                value.n1 = bit(dl,6);
356 
357 l2:            value.offset = bit(fixed(ap -> symbol.location + rp -> reference.c_offset,18),18);
358 l3:            value.n2 = bit(fixed(vp -> reference.c_offset,6),6);
359                return;
360                end;
361 
362           if ^ ap -> symbol.static then goto hard;
363 
364           if ap -> symbol.internal
365           then do;
366                value.code = "100101"b;
367                reloc = rc_a_is18;
368                goto l2;
369                end;
370 
371           /* the word offset must be positve and less than 64 for ext static ptr */
372 
373           if rp -> reference.c_offset < 0 then goto hard;
374           if rp -> reference.c_offset > 63 then goto hard;
375 
376           value.code = "100110"b;
377           reloc = rc_a_lp18;
378           value.n1 = bit(fixed(rp -> reference.c_offset,6),6);
379           value.offset = bit(fixed(ap -> symbol.location,18),18);
380           goto l3;
381 
382           /* have an expression or a variable that cannot be encoded, we
383              must generate an internal procedure to evaluate the expression,
384              so first search to see if we have already generated a procedure
385              to evaluate an equivalent expression */
386 
387 hard:     p = cg_stat$encoded_values;
388           do while(p ^= null);
389 
390                if p -> ev_node.block ^= cg_stat$cur_block then goto next;
391 
392                if p -> ev_node.const ^= const then goto next;
393 
394                if ^ compare_expression(p -> ev_node.exp,vp) then goto next;
395 
396                /* we found an equivalent expression evalutated earlier */
397 
398                allocate ev_equiv in(tree_area) set(xp);
399                xp -> ev_equiv.next = p -> ev_node.equiv;
400                p -> ev_node.equiv = xp;
401 
402                if symb = null then xp -> ev_equiv.name = null;
403                else xp -> ev_equiv.name = symb -> symbol.token;
404                xp -> ev_equiv.code = code;
405 
406                value.offset = bit(p -> ev_node.first,18);
407                goto hd;
408 
409 next:          p = p -> ev_node.next;
410                end;
411 
412           /* have no equivalent expression, we must evaluate this one */
413 
414 diff:     cg_stat$dummy_block -> block.father = cg_stat$cur_block;
415           bp, cg_stat$cur_block = cg_stat$dummy_block;
416           bp -> block.level, cg_stat$cur_level = cg_stat$cur_level + 1;
417           bp -> block.no_stack = "0"b;
418 
419           call state_man$flush;
420 
421           bp -> block.last_auto_loc = 64;
422 
423           bp -> block.free_temps(1),
424           bp -> block.free_temps(2),
425           bp -> block.free_temps(3) = null;
426 
427           value.offset = bit(cg_stat$text_pos,18);
428           ap = addrel(cg_stat$text_base,cg_stat$text_pos);
429 
430           call expmac$zero((beg_ev_proc));
431 
432           cg_stat$in_thunk = "1"b;
433           do while(s1 ^= null);
434                call compile_statement(s1);
435                s1 = s1 -> statement.next;
436                end;
437           cg_stat$in_thunk = "0"b;
438 
439           cg_stat$cur_statement = cg_stat$dummy_statement;
440           if symb ^= null
441                then string(cg_stat$cur_statement -> statement.source_id) = string(symb -> symbol.source_id);
442 
443           xp = prepare_operand(vp,1,atomic);
444 
445           if lab
446           then do;
447                macro = end_ev_label;
448                call expmac((load_pt_reg),xp);
449                end;
450           else do;
451                macro = end_ev_proc;
452                if atomic then call load(xp,0);
453                else do;
454                     cg_stat$cur_statement -> statement.root = vp;
455                     call compile_exp(vp);
456                     end;
457                end;
458 
459           if const ^= 0 then call expmac((adfx1),c_a(const,2));
460 
461           xp = c_a(4,4);                          /* sp|4 */
462           xp -> address.base = base_man$load_arg(0,bp);
463           xp -> address.tag = "010000"b;          /* lp|4,* */
464           call expmac(macro,xp);
465 
466           ap -> lxl_ins.stack_size = bit(make_mod(bp -> block.last_auto_loc,16),18);
467 
468           allocate ev_node in(tree_area) set(xp);
469           if cg_stat$encoded_values = null
470           then cg_stat$encoded_values = xp;
471           else cg_stat$last_encoded -> ev_node.next = xp;
472           cg_stat$last_encoded = xp;
473           xp -> ev_node.next = null;
474 
475           if symb = null then xp -> ev_node.name = null;
476           else xp -> ev_node.name = symb -> symbol.token;
477 
478           xp -> ev_node.exp = vp;
479           xp -> ev_node.equiv = null;
480           xp -> ev_node.const = const;
481           xp -> ev_node.code = code;
482           xp -> ev_node.first = fixed(value.offset,18);
483           xp -> ev_node.last = cg_stat$text_pos;
484 
485           cg_stat$next_ref = cg_stat$first_ref;
486 
487           cg_stat$cur_level = cg_stat$cur_level - 1;
488           xp -> ev_node.block, cg_stat$cur_block = bp -> block.father;
489 
490 hd:       value.code = "101000"b;
491           reloc = rc_a_t;
492 
493           return;
494 
495 e_v$l_v:  entry(symb,coded_value,var,const,code,reloc);
496 
497           /* this entry is called to encode a label or format value */
498 
499           lab = "1"b;
500           goto start;
501 
502           end;