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 generate a link
 12 
 13    Modified: 16 October 1972 by BLW for standard object segment
 14           Modified: 1 June 1976 by RAB for *system links    */
 15 
 16 compile_link: proc(string,grow,type) returns(fixed bin(18));
 17 
 18 dcl       string char(*) aligned,
 19           grow bit(18) aligned,
 20           type fixed bin(15);
 21 
 22 dcl       (def_pos,link_pos,n) fixed bin(18),
 23           (p,def_ptr,def_reloc_ptr,link_ptr,link_reloc_ptr) ptr,
 24           (block_type,seg_name,ent_name) bit(18) aligned;
 25 
 26 dcl       (cg_static_$def_base,cg_static_$link_base,
 27            cg_static_$def_reloc_base,cg_static_$link_reloc_base) ptr ext,
 28           cg_static_$zero_def bit(18) ext,
 29           cg_static_$use_type_6 bit(1) ext,
 30           (cg_static_$def_pos,cg_static_$link_pos) fixed bin(18) ext;
 31 
 32 dcl       name_assign entry(char(*) aligned) returns(bit(18) aligned),
 33           reserve$read_lib entry(fixed bin(15)) returns(ptr);
 34 
 35 dcl       (addrel,fixed,index,length,substr) builtin;
 36 
 37 dcl       word(0:2) bit(36) aligned based;
 38 
 39 dcl       reloc(0:2) bit(36) aligned based;
 40 
 41 dcl       address   fixed bin(35) based;
 42 
 43 dcl       1 fault_pair        aligned based,
 44           2 unused            unal bit(30),
 45           2 tag               unal bit(6);
 46 
 47 %include token;
 48 %include relbts;
 49 
 50           n = index(string,"$");
 51 
 52           if n = length(string)
 53           then do;
 54 
 55                /* have seg_name$ */
 56 
 57                ent_name = cg_static_$zero_def;
 58                seg_name = name_assign(substr(string,1,length(string)-1));
 59 
 60                if grow then block_type = "000000000000000110"b;
 61                else block_type = "000000000000000011"b;
 62 
 63                end;
 64           else do;
 65 
 66                if grow
 67                then if cg_static_$use_type_6
 68                     then block_type = "000000000000000110"b;
 69                     else block_type = "000000000000000101"b;
 70                else block_type = "000000000000000100"b;
 71 
 72                if n = 0
 73                then do;
 74 
 75                     /* no $ in external name */
 76 
 77                     if type = 0 then seg_name, ent_name = name_assign(string);
 78                     else do;
 79 
 80                          if block_type = "000000000000000110"b
 81                          then do;
 82 
 83                               /* name is stat_$alpha format */
 84 
 85                               p = reserve$read_lib(2);
 86                               seg_name = name_assign(p -> token.string);
 87                               end;
 88 
 89                          else do;
 90 
 91                               /* have *system link */
 92 
 93                               seg_name = "000000000000000101"b;
 94                               end;
 95 
 96                          ent_name = name_assign(string);
 97 
 98                          end;
 99                     end;
100                else do;
101 
102                     /* have a$b form of name */
103 
104                     seg_name = name_assign(substr(string,1,n-1));
105                     ent_name = name_assign(substr(string,n+1));
106 
107                     end;
108                end;
109 
110           def_pos = cg_static_$def_pos;
111           def_ptr = addrel(cg_static_$def_base,def_pos);
112           def_reloc_ptr = addrel(cg_static_$def_reloc_base,def_pos);
113 
114           link_pos = cg_static_$link_pos;
115           link_ptr = addrel(cg_static_$link_base,link_pos);
116           link_reloc_ptr = addrel(cg_static_$link_reloc_base,link_pos);
117 
118           def_ptr -> word(0) = block_type || grow;
119           if grow then def_reloc_ptr -> reloc(0) = rc_a_dp;
120 
121           def_ptr -> word(1) = seg_name || ent_name;
122           def_reloc_ptr -> reloc(1) = rc_dp_dp;
123 
124           def_ptr -> word(2) = bit(def_pos,18);
125           def_reloc_ptr -> reloc(2) = rc_dp;
126 
127           link_ptr -> address = -link_pos * 262144;         /* put in left half of word */
128           link_ptr -> fault_pair.tag = "100110"b;           /* fi mod = 46 octal */
129           link_reloc_ptr -> reloc(0) = rc_nlb;
130 
131           link_ptr -> word(1) = bit(fixed(def_pos+2,18),18);
132           link_reloc_ptr -> reloc(1) = rc_dp;
133 
134           cg_static_$def_pos = def_pos + 3;
135           cg_static_$link_pos = link_pos + 2;
136 
137           return(link_pos);
138           end;