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 /* format: style3 */
 10 
 11 /* procedure to compile pointer valued operators
 12 
 13    Initial Version: 19 August 1971 by BLW
 14           Modified: 11 February 1973 by RAB
 15           Modified: 16 October 1975 by RAB to use all regs
 16           Modified: 26 March 1975 by RAB to fix bug 1479 introduced
 17                     16 October 1975
 18           Modified: 27 April 1976 by RAB to fix 1493
 19           Modified: 7 Dec 1976 by RAB to fix 1559
 20           Modified: 9 May 1977 by RAB to fix 1617
 21           Modified: 10 September 1977 by RAB to fix 1613 by adding 3rd arg to store_bit_address
 22           Modified: 29 March 1978 by PCK to add stackframeptr, stackbaseptr, environmentptr, and codeptr
 23           Modified: 19 August 1978 by PCK to fix bug 1742   */
 24 
 25 /* Modified BIM 12/82 to add the Palter builtins (addcharno, setcharno, etc. */
 26 /* Modified BIM 1/83 to un-share the first operand always, since it will  */
 27 /*         be in the machine state in a PR. This, together with */
 28 /*         conversion of many compile_exp$save calls to compile_exp, */
 29 /*         removes a bunch of spurious stores. */
 30 /* Modified BIM 6/83 to stop calling get_base in addr. get_base assumes */
 31 /*         that ref (2) is a pointer VAR to be dicked with, not an object */
 32 /*         whose addr is to be returned. */
 33 /* Modified BIM 9/83 to fix some malingering problems in the new bifs, */
 34 /*         including an uninitialized variable in NO_FUNS. */
 35 
 36 pointer_builtins:
 37      proc (pt, store_it);
 38 
 39 dcl       pt                  ptr,                          /* points at operator node */
 40           store_it            bit (1) aligned;              /* "1"b if value should be stored */
 41 
 42 dcl       (
 43           p,
 44           q,
 45           p2,
 46           s3,
 47           ref                 (3),
 48           b2
 49           )                   ptr,
 50           (i, ibase, macro, mac_1, n, old_changed)
 51                               fixed bin (15),
 52           last_freed          fixed bin (18),
 53           base                bit (3) aligned,
 54           op_code             bit (9) aligned,
 55           (
 56           atom                (3),
 57           adjust,
 58           in_base
 59           )                   bit (1) aligned;
 60 
 61 dcl       (
 62           cg_stat$temp_ref,
 63           cg_stat$text_base
 64           )                   ptr ext,
 65           cg_stat$text_pos    fixed bin ext,
 66           cg_stat$null_value  bit (72) aligned ext,
 67           cg_stat$cur_level   fixed bin ext;
 68 
 69 dcl       adjust_ref_count    entry (pointer, fixed bin);
 70 dcl       base_man$load_any_var
 71                               entry (fixed bin, ptr) returns (bit (3) aligned);
 72 dcl       prepare_operand     entry (ptr, fixed bin (15), bit (1) aligned) returns (ptr),
 73           compile_exp$save    entry (ptr) returns (ptr),
 74           compile_exp         entry (ptr),
 75           c_a                 entry (fixed bin (15), fixed bin) returns (ptr),
 76           load                entry (ptr, fixed bin),
 77           (
 78           base_man$load_var,
 79           base_man$update_base
 80           )                   entry (fixed bin, ptr, fixed bin (15));
 81 dcl       base_man$load_arg_ptr
 82                               entry (fixed bin (15), ptr, fixed bin) returns (bit (3) aligned);
 83 dcl       base_man$load_display
 84                               entry (fixed bin, bit (3) aligned),
 85           generate_constant$bit_string
 86                               entry (bit (*) aligned, fixed bin) returns (ptr);
 87 dcl       base_to_core        entry (fixed bin (15), ptr),
 88           state_man$flush_address
 89                               entry (ptr),
 90           state_man$flush_ref entry (ptr),
 91           store_bit_address   entry (ptr, ptr, fixed bin (18)),
 92           store               entry (ptr),
 93           expmac$zero         entry (fixed bin (15));
 94 dcl       type2               fixed bin (17),
 95           m_a                 entry (ptr, bit (2) aligned),
 96           cg_error            entry (fixed bin, fixed bin (9));
 97 declare   cg_stat$cur_statement
 98                               pointer external;
 99 
100 dcl       (
101           SETCHARNO           init (1),
102           ADDCHARNO           init (2),
103           SETBITNO            init (3),
104           ADDBITNO            init (4)
105           )                   fixed bin int static options (constant);
106 
107 dcl       (abs, addrel, bit, fixed, index, null, string)
108                               builtin;
109 
110 dcl       fix_bin             fixed bin based;
111 
112 dcl       ldfx2               init (8) fixed bin (15) static;
113 
114 dcl       1 half              aligned based,
115             2 left            bit (18) unal,
116             2 right           bit (18) unal;
117 
118 dcl       1 instruction       aligned based,
119             2 base            bit (3) unal,
120             2 offset          bit (15) unal,
121             2 op_code         bit (10) unal,
122             2 skip            bit (2) unal,
123             2 tag             bit (6) unal;
124 
125 dcl       (
126           pointer_mac_const   (6) init (326, 0, 652, 653, 654, 655),
127           addrel_mac_const    (6) init (327, 0, 656, 657, 658, 659),
128           zero_bo             (6) init (642, 0, 684, 685, 686, 687),
129           longbs_to_bs18      init (131),
130           pl1_pointer_easy    init (602),
131           pl1_pointer_hard    init (604),                   /*        pointer_mac_bs(6)   init(212,0,660,662,664,666), */
132           pointer_mac_fx      (6) init (213, 0, 661, 663, 665, 667),
133                                                             /*        addrel_mac_bs(6)    init(214,0,668,670,672,674), */
134           addrel_mac_fx       (6) init (215, 0, 669, 671, 673, 675),
135                                                             /*        baseptr_mac_bs(6)   init(216,0,676,678,680,682), */
136           baseptr_mac_fx      (6) init (217, 0, 677, 679, 681, 683)
137           )                   fixed bin (15) int static;
138 
139 dcl       epbx                (0:7)
140                               init ("0111010001"b, "0111010101"b, "0111110001"b, "0111010010"b, "0111010110"b,
141                               "0111110010"b, "0111110110"b, "0111110101"b) bit (10) aligned int static;
142 
143 %include cgsystem;
144 %include operator;
145 %include reference;
146 %include symbol;
147 %include block;
148 %include op_codes;
149 %include data_types;
150 %include nodes;
151 %include machine_state;
152 %include bases;
153 %include temporary;
154 
155           p = pt;
156           p2 = p -> operand (2);
157 
158 
159           op_code = p -> operator.op_code;
160 
161           if op_code = param_ptr
162           then do;
163                     i = 0;
164 
165                     goto l4;
166                end;
167 
168           if op_code = param_desc_ptr
169           then do;
170                     i = 1;
171 
172 l4:
173                     ref (1) = prepare_operand ((p -> operand (1)), 1, atom (1));
174 
175                     base =
176                          base_man$load_arg_ptr (i, (p -> operand (3)),
177                          p2 -> reference.symbol -> symbol.initial -> fix_bin);
178 
179                     ibase = which_base (fixed (base, 3));
180                     goto to_core;
181                end;
182 
183           if op_code >= ptr_fun
184           then n = 1;
185           else n = -1;
186 
187           do i = 1 to p -> operator.number;
188                ref (i) = prepare_operand ((p -> operand (i)), n, atom (i));
189           end;
190 
191           if op_code = setcharno_fun
192           then call NO_FUNS (SETCHARNO);
193           else if op_code = addcharno_fun
194           then call NO_FUNS (ADDCHARNO);
195           else if op_code = setbitno_fun
196           then call NO_FUNS (SETBITNO);
197           else if op_code = addbitno_fun
198           then call NO_FUNS (ADDBITNO);                     /* these dont return here */
199 
200           if op_code = addr_fun
201           then do;
202 
203                     if ^atom (2)
204                     then if p2 -> node.type = operator_node
205                          then ref (2) = compile_exp$save (p2);
206                                                             /* make addr (expression) work, invalid though it is */
207 
208                     adjust, in_base = "0"b;                 /* of interest only in the varying case */
209 
210                     if ref (2) -> reference.varying_ref
211                     then do;
212                               adjust = "1"b;
213                               call adjust_c_offset (-1);
214                          end;
215 
216                     ibase = which_base (bin (base_man$load_any_var (2, ref (2)), 3));
217 
218                     if adjust
219                     then call reset_c_offset (-1);
220 
221                     ref (2) -> reference.address_in.b (ibase) = "0"b;
222                                                             /* we cannot remember both addr (ref (2)) and ref (1). */
223                     base_regs (ibase).variable = null;
224                     base_regs (ibase).type = 0;
225 to_core:
226                     if ref (1) -> reference.allocate
227                     then if store_it
228                          then call base_to_core (ibase, ref (1));
229                          else ;
230                     else call state_man$flush_ref (ref (1));
231 
232                     if ibase ^= 7                           /* protect pr6 from optimization for stackframeptr */
233                     then call base_man$update_base (1, ref (1), ibase);
234                     else call state_man$flush_ref (ref (1));
235 
236                     ref (1) -> reference.evaluated = "1"b;  /* Cannot be shared at this point */
237 done:
238                     cg_stat$temp_ref = ref (1);
239                     return;
240                end;
241 
242           if op_code = addr_fun_bits
243           then do;
244 
245                     if ^atom (2)
246                     then if p2 -> node.type = operator_node
247                          then ref (2) = compile_exp$save (p2);
248                                                             /* see above */
249 
250                     ref (1) -> reference.ref_count = ref (1) -> reference.ref_count + 1;
251                     last_freed = 0;
252                     if ref (1) -> reference.temp_ref
253                     then if ref (1) -> reference.qualifier ^= null
254                          then last_freed = ref (1) -> reference.qualifier -> temporary.last_freed;
255 
256                     if store_it
257                     then call store_bit_address (ref (1), ref (2), last_freed);
258                     else begin;
259 declare   base_bits           bit (3) aligned;
260                               base_bits = base_man$load_any_var (2 /* addr */, ref (2));
261                               call base_man$update_base (1, ref (1), (which_base (fixed (base_bits, 3))));
262                          end;
263                     goto done;
264                end;
265 
266           if op_code = ptr_fun
267           then do;
268 
269                     if ref (2) -> reference.symbol -> symbol.ptr
270                     then do;
271 
272 /* this is Multics version of ptr builtin */
273 /* The ref count must be bumped here because the optimiser */
274 /* does not know that we hit the output temp twice -- once */
275 /* when we compile it, once when we load it. */
276 
277                               if ^atom (2)
278                               then if p2 -> node.type = operator_node
279                                    then do;
280                                              call adjust_ref_count ((p2 -> operator.operand (1)), +1);
281                                              call compile_exp (p2);
282                                              ref (2) = p2 -> operator.operand (1);
283                                         end;
284 
285                               if ref (3) -> reference.offset ^= null
286                               then goto l1;
287                               if ref (3) -> reference.c_offset ^= 0
288                               then goto l1;
289 
290                               s3 = ref (3) -> reference.symbol;
291                               if s3 -> symbol.constant
292                               then
293 Multics_POINTER_CONSTANT:
294                                    do;
295                                         ibase = get_base ();
296                                         mac_1 = pointer_mac_const (ibase);
297                                         goto c0;
298                                    end;
299 
300                               goto l1;
301                          end;
302 
303 /* this is PL/1 version of ptr builtin */
304 
305 
306                     if ^atom (2)
307                     then ref (2) = compile_exp$save (p2);
308 
309                     call load (ref (2), 0);
310 
311                     q = ref (3) -> reference.symbol;
312                     if q -> symbol.internal & (q -> symbol.auto | q -> symbol.static)
313                     then macro = pl1_pointer_easy;
314                     else macro = pl1_pointer_hard;
315 
316                     call base_man$load_var (2, ref (3), 1);
317 
318                     call expmac$zero (macro + ref (1) -> reference.data_type - unpacked_ptr);
319 
320                     ref (2) -> reference.address_in.b (1) = "0"b;
321                     base_regs (1).variable = null;
322                     base_regs (1).type = 0;
323 
324 /* next 3 lines necessary because store won't always update state */
325 
326                     q_reg.variable (1) = ref (1);
327                     q_reg.number = 1;
328                     ref (1) -> reference.value_in.q = "1"b;
329 
330                     if ref (1) -> reference.allocate & store_it
331                     then call store (ref (1));
332 
333                     else do;
334                               if ^ref (1) -> reference.allocate
335                               then call state_man$flush_ref (ref (1));
336 
337                               q_reg.variable (1) = ref (1);
338                               q_reg.number = 1;
339                               ref (1) -> reference.value_in.q = "1"b;
340                          end;
341 
342                     call base_man$update_base (1, ref (1), 1);
343 
344                     goto done;
345                end;
346 
347           if op_code = addrel_fun
348           then do;
349 
350                     if ^atom (2)
351                     then if p2 -> node.type = operator_node
352                          then do;
353                                    call adjust_ref_count ((p2 -> operator.operand (1)), 1);
354                                                             /* we will call base_man, which costs an extra ref_count hit */
355                                    call compile_exp (p2);
356                                    ref (2) = p2 -> operator.operand (1);
357                               end;
358 
359                     if ref (3) -> reference.offset ^= null
360                     then goto l1;
361                     if ref (3) -> reference.c_offset ^= 0
362                     then goto l1;
363 
364                     s3 = ref (3) -> reference.symbol;
365                     if ^s3 -> symbol.constant
366                     then goto l1;
367 
368                     ibase = get_base ();
369                     mac_1 = addrel_mac_const (ibase);
370 
371 c0:
372                     q = s3 -> symbol.initial;
373 
374                     if ref (3) -> reference.data_type = bit_string
375                     then do;
376                               if ref (3) -> reference.long_ref
377                               then goto l1;
378                               if ref (3) -> reference.c_length > 18
379                               then goto l1;
380                          end;
381                     else if abs (q -> fix_bin) >= 131072
382                     then goto l1;
383 
384                     old_changed = base_regs (ibase).changed;
385 
386                     call base_man$load_var (1, ref (2), ibase);
387                     ref (2) -> reference.value_in.b (ibase) = "0"b;
388                     base_regs (ibase).variable = null;
389                     base_regs (ibase).type = 0;
390                     n = base_regs (ibase).changed;
391 
392                     if op_code = ptr_fun
393                     then if q -> fix_bin = 0 & n ^= old_changed
394                          then do;
395                                    q = addrel (cg_stat$text_base, n);
396                                    q -> instruction.op_code = epbx (ibase);
397                                    base_regs (ibase).instruction = string (q -> instruction);
398                                    goto to_core;
399                               end;
400 
401 
402                     call expmac$zero (mac_1);
403 
404                     p = addrel (cg_stat$text_base, cg_stat$text_pos - 1);
405 
406                     if ref (3) -> reference.data_type = bit_string
407                     then p -> left = q -> left;
408                     else do;
409                               if q -> fix_bin >= 0
410                               then p -> left = bit (fixed (q -> fix_bin, 18), 18);
411                               else p -> left = bit (fixed (262144 + q -> fix_bin, 18), 18);
412                          end;
413 
414                     goto to_core;
415 
416 l1:
417                     if atom (3)
418                     then call load (ref (3), 0);
419                     else call compile_exp ((p -> operand (3)));
420 
421                     if ref (3) -> reference.long_ref
422                     then call expmac$zero ((longbs_to_bs18));
423 
424                     ibase = get_base ();
425                     if op_code = ptr_fun
426                     then macro = pointer_mac_fx (ibase);
427                     else macro = addrel_mac_fx (ibase);
428 
429                     old_changed = base_regs (ibase).changed;
430 
431                     call base_man$load_var (1, ref (2), ibase);
432                     ref (2) -> reference.value_in.b (ibase) = "0"b;
433                     base_regs (ibase).variable = null;
434                     base_regs (ibase).type = 0;
435 
436                     if op_code ^= addrel_fun
437                     then do;
438 l2a:
439                               call expmac$zero (macro - fixed (ref (3) -> reference.data_type = bit_string, 1));
440                               goto to_core;
441                          end;
442 
443                     n = base_regs (ibase).changed;
444                     if n = old_changed
445                     then go to l2a;
446                     q = addrel (cg_stat$text_base, n);
447 
448                     if q -> instruction.tag = "000000"b
449                     then do;
450                               if ref (3) -> reference.data_type = bit_string
451                               then do;
452                                         if a_reg.changed > n
453                                         then go to l2a;
454                                         q -> instruction.tag = "000001"b;
455                                                             /* au */
456                                    end;
457                               else do;
458                                         if q_reg.changed > n
459                                         then go to l2a;
460                                         q -> instruction.tag = "000110"b;
461                                                             /* ql */
462                                    end;
463                               go to set_inst;
464                          end;
465 
466                     if q -> instruction.tag ^= "010000"b
467                     then goto l2a;
468 
469                     if ref (3) -> reference.data_type = bit_string
470                     then do;
471                               if a_reg.changed > n
472                               then goto l2a;
473                               q -> instruction.tag = "110001"b;
474                                                             /* *au */
475                          end;
476                     else do;
477                               if q_reg.changed > n
478                               then goto l2a;
479                               q -> instruction.tag = "110110"b;
480                                                             /* *ql */
481                          end;
482 set_inst:
483                     base_regs (ibase).instruction = string (q -> instruction);
484                     call expmac$zero ((zero_bo (ibase)));
485                     goto to_core;
486                end;
487 
488           if op_code = baseptr_fun
489           then do;
490 
491                     if atom (2)
492                     then call load (ref (2), 0);
493                     else call compile_exp ((p -> operand (2)));
494                     if p -> operator.operand (2) -> node.type = operator_node
495                     then ref (2) = p -> operator.operand (2) -> operator.operand (1);
496 
497                     ibase = get_base ();
498                     macro = baseptr_mac_fx (ibase);
499                     ref (3) = ref (2);
500 
501                     goto l2a;
502                end;
503 
504           if op_code = stackframeptr_fun
505           then do;
506                     if ref (1) -> reference.allocate & store_it
507                     then do;
508                               ibase = which_base (6);
509                               goto to_core;
510                          end;
511 
512                     ref (2) = c_a (0, 4);
513 
514                     ibase = get_base ();
515 
516                     call base_man$load_var (2, ref (2), ibase);
517 
518                     ref (2) -> reference.address_in.b (ibase) = "0"b;
519                     base_regs (ibase).variable = null;
520                     base_regs (ibase).type = 0;
521                     goto to_core;
522                end;
523 
524           if op_code = stackbaseptr_fun
525           then do;
526                     ref (2) = c_a (0, 4);
527 
528                     ibase = get_base ();
529 
530                     old_changed = base_regs (ibase).changed;
531 
532                     call base_man$load_var (2, ref (2), ibase);
533                     ref (2) -> reference.address_in.b (ibase) = "0"b;
534                     base_regs (ibase).variable = null;
535                     base_regs (ibase).type = 0;
536                     n = base_regs (ibase).changed;
537 
538                     if n ^= old_changed
539                     then do;
540                               q = addrel (cg_stat$text_base, n);
541                               q -> instruction.op_code = epbx (ibase);
542                               base_regs (ibase).instruction = string (q -> instruction);
543                               goto to_core;
544                          end;
545 
546                     call expmac$zero ((pointer_mac_const (ibase)));
547                     goto to_core;
548                end;
549 
550           if op_code = codeptr_fun
551           then do;
552 
553                     if ^atom (2)
554                     then ref (2) = compile_exp$save (p2);
555                     ibase = get_base ();
556                     type2 = ref (2) -> reference.data_type;
557 
558                     if type2 = label_constant | (ext_entry_in <= type2 & type2 <= int_entry_other)
559                     then do;                                /* process label, format, and entry constants */
560                               call base_man$load_var (2, ref (2), ibase);
561                               ref (2) -> reference.address_in.b (ibase) = "0"b;
562                          end;
563                     else do;                                /* process label, format, and entry variables */
564                               call base_man$load_var (1, ref (2), ibase);
565                               ref (2) -> reference.value_in.b (ibase) = "0"b;
566                          end;
567 
568                     base_regs (ibase).variable = null;
569                     base_regs (ibase).type = 0;
570                     goto to_core;
571 
572                end;
573 
574           if op_code = environmentptr_fun
575           then do;
576                     if ^atom (2)
577                     then ref (2) = compile_exp$save (p2);
578                     type2 = ref (2) -> reference.data_type;
579 
580                     if type2 = ext_entry_in | type2 = ext_entry_out
581                     then do;                                /* process external entry constants */
582                               ref (2) = generate_constant$bit_string (cg_stat$null_value, (bits_per_two_words));
583                               ref (2) -> reference.data_type = unpacked_ptr;
584                               ibase = get_base ();
585                               call base_man$load_var (1, ref (2), ibase);
586                               ref (2) -> reference.value_in.b (ibase) = "0"b;
587                               base_regs (ibase).variable = null;
588                               base_regs (ibase).type = 0;
589                          end;
590 
591                     else if type2 = label_constant | type2 = int_entry | type2 = int_entry_other
592                     then do;                                /* process label, format, and internal entry constants */
593                               b2 = ref (2) -> reference.symbol -> symbol.block_node;
594                               if cg_stat$cur_level = b2 -> block.level
595                               then do;
596                                         if ref (1) -> reference.allocate & store_it
597                                         then do;
598                                                   ibase = which_base (6);
599                                                   goto to_core;
600                                              end;
601 
602                                         ref (2) = c_a (0, 4);
603                                         ibase = get_base ();
604                                         call base_man$load_var (2, ref (2), ibase);
605                                         ref (2) -> reference.address_in.b (ibase) = "0"b;
606                                    end;
607                               else do;
608                                         call base_man$load_display (cg_stat$cur_level - b2 -> block.level, base);
609                                         ibase = which_base (fixed (base, 3));
610                                    end;
611                          end;
612 
613                     else do;                                /* process label, format, and entry variables */
614                               ibase = get_base ();
615                               call adjust_c_offset (2);
616                               call base_man$load_var (1, ref (2), ibase);
617                               call reset_c_offset (2);
618                               base_regs (ibase).variable = null;
619                               base_regs (ibase).type = 0;
620 
621                          end;
622 
623                     goto to_core;
624 
625                end;
626 
627 err:
628           call cg_error (301, fixed (op_code, 9));
629 
630 
631 get_base:
632      proc returns (fixed bin (15));
633 
634 dcl       i                   fixed bin (15);
635 dcl       (
636           first_base          init (3),
637           last_base           init (6)
638           )                   fixed bin (15) int static;
639 
640 /* all these functions destroy the PR containing op (2). If this */
641 /* is of the form a = OP (a, ...) then this is fine, or if we */
642 /* have no other use for a. Otherwise, copy a into another PR */
643 /* to keep the original value around */
644 
645           if string (ref (2) -> reference.value_in.b)
646           then if ref (2) -> reference.ref_count = 1 | ref (1) = ref (2)
647                then return (index (string (ref (2) -> reference.value_in.b), "1"b) - 1);
648                else ;
649           else if ref (2) -> reference.data_type >= unpacked_ptr
650           then do;
651 
652 /* m_a can load pointer regs */
653 
654                     call m_a (ref (2), "00"b);
655                     ref (2) -> reference.perm_address = "1"b;
656                                                             /* base_man will turn off  */
657                end;
658 
659           do i = 1, first_base to last_base;
660                if base_regs (i).type = 0
661                then return (i);
662                else if base_regs (i).type <= 2
663                then if base_regs (i).variable -> reference.hit_zero | ^base_regs (i).variable -> reference.allocate
664                     then return (i);
665           end;
666 
667           return (1);
668      end;
669 
670 adjust_c_offset:
671      proc (adjust_offset);
672 
673 dcl       adjust_offset       fixed bin;
674 
675           ref (2) -> reference.c_offset = ref (2) -> reference.c_offset + adjust_offset;
676 
677           if string (ref (2) -> reference.address_in.b)
678           then do;
679                     if ref (2) -> reference.address.offset ^= (15)"0"b
680                     then call m_a (ref (2), "00"b);
681                     call state_man$flush_address (ref (2));
682                     in_base = "1"b;
683                     if adjust_offset >= 0
684                     then ref (2) -> address.offset = bit (fixed (adjust_offset, 15), 15);
685                     else ref (2) -> address.offset = bit (fixed (adjust_offset + 32768, 15), 15);
686                     ref (2) -> reference.perm_address = "1"b;
687                     ref (2) -> reference.no_address = "0"b;
688                end;
689           else in_base = "0"b;
690 
691      end;
692 
693 reset_c_offset:
694      proc (adjust_offset);
695 
696 dcl       adjust_offset       fixed bin;
697 
698           ref (2) -> reference.c_offset = ref (2) -> reference.c_offset - adjust_offset;
699 
700           if in_base
701           then do;
702                     ref (2) -> address.offset = (15)"0"b;
703                     ref (2) -> reference.perm_address = "0"b;
704                end;
705 
706      end;
707 
708 
709 /* The following uses a different approach from the rest of this program */
710 /* to avoid the piles and piles of macros used by the pointer and addrel */
711 /* cases, or the patching of instructions, this just uses a locked base register */
712 /* to avoid the problem of a pointer qualified second argument */
713 
714 NO_FUNS:
715      procedure (Funx);
716 declare   Funx                fixed bin;
717 declare   base_man$load_var_and_lock
718                               entry (fixed bin, ptr, fixed bin (15));
719 declare   base_man$unlock     entry (fixed bin (15));
720 
721 declare   q                   pointer;
722 
723 declare   expmac              entry (fixed bin (15), pointer);
724 declare   base_bits           bit (3) aligned;
725 declare   s3_constant         bit (1) aligned;
726 declare   constant_zero       bit (1) aligned;
727 declare   constant_value      fixed bin (24);
728 declare   based_fb_24         fixed bin (24) based;
729 
730 declare   MACRO               (4) fixed bin (15) init (373, 373, 374, 374) int static options (constant);
731 declare   binary              builtin;
732 
733 
734           s3_constant = "0"b; /* until proven guilty */
735 
736           s3 = ref (3) -> reference.symbol; /* prepare_operand made ref (3) the output operand if its non-atomic */
737           if s3 -> symbol.constant
738           then do;
739                     s3_constant = "1"b;
740                     constant_value = s3 -> symbol.initial -> based_fb_24;
741                end;
742 
743           constant_zero = s3_constant & constant_value = 0;
744 
745           if constant_zero
746           then if Funx = ADDCHARNO | Funx = ADDBITNO
747                then do;
748                          ibase = get_base ();               /* find the var in a base */
749                          call base_man$load_var (1, ref (2), ibase);
750                                                             /* in case it was in no register yet */
751                          go to to_core;                     /* and return it there */
752                     end;
753 
754           if ^atom (2)
755           then call compile_exp (p2);
756 
757           if s3_constant
758           then do;                                          /* if even number of words, optimize */
759                     if constant_zero
760                     then call CONVERT_TO_POINTER_CONSTANT (0);
761                     if Funx = SETCHARNO & mod (constant_value, 4) = 0
762                     then call CONVERT_TO_POINTER_CONSTANT (divide (constant_value, 4, 24, 0));
763                     else if Funx = SETBITNO & mod (constant_value, 36) = 0
764                     then call CONVERT_TO_POINTER_CONSTANT (divide (constant_value, 36, 24, 0));
765                end;
766 
767           q = c_a (0, 1);                                   /* get a constant ref node */
768 
769           ibase = get_base ();
770           base_bits = bases (ibase);
771           call base_man$load_var_and_lock (1, ref (2), ibase);
772                                                             /* will just find and lock if get_base loaded */
773 
774 /* This code could call aq_man$load_any_var, and then set the modifier */
775 /* on the instruction appropriately. */
776 
777           if ^atom (3)                                      /* atomize 3 */
778           then call compile_exp ((p -> operator.operand (3)));
779           else call load (ref (3), 0);                      /* dont negate */
780 
781           q -> reference.address.base = base_bits;
782           q -> reference.address.tag = "06"b3;              /* QL */
783           q -> reference.relocation = ""b;
784 
785           if Funx = ADDCHARNO | Funx = ADDBITNO             /* add... */
786           then q -> reference.address.ext_base = "1"b;      /* turn on bit 29 */
787           call expmac (MACRO (Funx), q);
788           call base_man$unlock (ibase);
789           machine_state.base_regs (ibase).variable = null ();
790           machine_state.base_regs (ibase).type = 0;
791           ref (2) -> reference.value_in.b (ibase) = "0"b;
792           go to to_core;                                    /* store if that is the right thing, then return. */
793 
794 CONVERT_TO_POINTER_CONSTANT:
795      procedure (Word_offset);
796 declare   Word_offset         fixed bin (24);
797 declare   declare_constant    ext entry (bit (*) aligned, bit (36) aligned, fixed bin (31), fixed bin (31))
798                               returns (pointer);
799 declare   size                fixed bin (31);
800 declare   value               bit (36) aligned;
801 declare   substr              builtin;
802 
803 %include mask;
804 
805 /***** This procedure does not patch the tree. Perhaps a better way */
806 /* would be for something in the semantics to detect these cases, and */
807 /* have it make the tree start out as pointer (foo, bar), but I */
808 /* don't know how to do that, and I do know how to do this. --BIM */
809 
810           op_code = ptr_fun;
811 
812           size = 18;
813           value = unspec (Word_offset);
814 
815           ref (3) = declare_constant (value, fixed_binary_real_mask | unsigned_mask, size, 0);
816           s3 = ref (3) -> reference.symbol;                 /* global depended on */
817           go to Multics_POINTER_CONSTANT;
818      end CONVERT_TO_POINTER_CONSTANT;
819 
820 
821      end NO_FUNS;
822 
823      end pointer_builtins;