1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
 17      audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
 18      Modified to allow blocks to be joined to the definition section.
 19                                                    END HISTORY COMMENTS */
 20 
 21 
 22 pakbit_:  procedure ;
 23 
 24 /*        Modified for separate static on 06/15/75 by Eugene E Wiatrowski    */
 25 /*        Modified on 03/21/72 at 09:45:38 by R F Mabee.
 26           by RFM on 21 March 1972 for relocation bits structure version (part of new object format).
 27           by RHG on 8 August 1970 to suppress listing of relocation bits
 28 */
 29 
 30           /* This procedure collects and packs the words of relocation bits
 31              and then outputs them to the assembler's scratch segment */
 32 
 33 % include concom ;
 34 %         include   alm_options;
 35 % include objnfo ;
 36 %include segnfo;
 37 
 38 dcl (buff, j, nl, n, nr, i, ik, rpc, bits, itemp) fixed bin (26) ;
 39 dcl (lbits, rbits) fixed bin (26);
 40 
 41 dcl eb_data_$stat_len ext fixed bin(26);
 42 dcl eb_data_$separate_static ext bit(1) aligned;
 43 
 44 dcl pakrtn label local;
 45 
 46 dcl
 47           object_$objst ext entry (fixed bin (26), fixed bin (26)),
 48           object_$getbtx ext entry ( fixed bin (26), fixed bin (26), fixed bin (26) ),
 49           object_$gtblk ext entry ( fixed bin (26), fixed bin (26), fixed bin (26) ),
 50           object_$getbdf ext entry ( fixed bin (26), fixed bin (26), fixed bin (26) ),
 51           object_$getbst ext entry ( fixed bin (26), fixed bin (26), fixed bin (26) );
 52 
 53 dcl       iword fixed bin(26),
 54           01 word aligned based(addr(iword)),
 55                     02 (left, right) fixed bin(18) unsigned unaligned;
 56 
 57 dcl       tx_word(0:262143) fixed bin(26) aligned based(eb_data_$segnfo.text);
 58 
 59 dcl       01 lk_sym_def_overlay (0:32767) based(eb_data_$segnfo.scrtch),
 60             02 (lk_rel, lk_word, st_rel, st_word, df_rel, df_word, pad1, pad2) fixed bin(26) aligned;
 61 
 62 dcl (utils_$or, utils_$ls, utils_$rs) external entry ( fixed bin (26), fixed bin (26) ) returns ( fixed bin (26) );
 63 
 64  declare  reloc_vers internal static fixed bin (26) initial (1);
 65 
 66           /* output text count */
 67           rpc = istpc ;
 68           if tnewobject ^= 0 then do;
 69                     call object_$objst (rpc, reloc_vers);
 70                     rpc = rpc + 1;
 71                     end;
 72 
 73           call object_$objst( rpc, itxcnt ) ;
 74 
 75           rpc = rpc + 1 ;
 76 
 77           lbits = 0 ;
 78 
 79           rbits = 0 ;
 80 
 81           bits = 0 ;
 82 
 83           j = 0 ;
 84 
 85           buff = 0 ;
 86 
 87           pakrtn = label_975 ;
 88 
 89           itemp = itxpc - 1 ;
 90 
 91 text_loop:
 92           do i = 0 to  itemp ;
 93                     call object_$getbtx(i, lbits, rbits ) ;
 94                     iword = tx_word(i);
 95 
 96                     go to label_5000 ;
 97 label_975:
 98                     tx_word(i) = iword;
 99 
100 end text_loop ;
101 
102 
103 
104           /* output the last word if there is more in the buffer */
105 
106           if j = 0 then go to label_1000 ;
107 
108           call object_$objst(rpc,buff ) ;
109 
110           rpc = rpc + 1 ;
111 
112 
113           /* output the linkage bits count */
114 
115 label_1000:
116 
117           if tnewobject ^= 0 then do;
118                     call object_$objst (rpc, reloc_vers);
119                     rpc = rpc + 1;
120                     end;
121 
122           /* output the linkage bits count */
123 
124           call object_$objst( rpc, ilkcnt ) ;
125 
126           rpc = rpc + 1 ;
127 
128           lbits = 0 ;
129 
130           rbits = 0 ;
131 
132           bits = 0 ;
133 
134           j = 0 ;
135 
136           buff = 0 ;
137 
138           pakrtn = label_1075 ;
139 
140 
141           /* no need to generate relocation bits for separate static section */
142 
143           if eb_data_$separate_static
144              then do;
145                   itemp = (eb_data_$stat_len + ilkpc) - 1;
146                   ik = eb_data_$stat_len;
147                   end;
148              else do;
149                   itemp = ilkpc - 1;
150                   ik = 0;
151                   end;
152 
153 link_loop:
154 
155           do i = ik to itemp ;
156 
157                     call object_$gtblk (i, lbits, rbits ) ;
158                     iword = lk_word(i);
159 
160                     go to label_5000 ;
161 
162 label_1075:
163                     lk_word(i) = iword;
164 
165 end link_loop ;
166 
167 
168           /* output the last word of the linkage buffer */
169 
170           if j = 0 then go to label_1200 ;
171 
172           call object_$objst(rpc, buff ) ;
173 
174           rpc = rpc + 1 ;
175 
176           /* process the definition relocation bits */
177 
178 label_1200:
179           j = 0 ;
180           buff = 0 ;
181           lbits = 0 ;
182           rbits = 0 ;
183           bits = 0 ;
184 
185           if tnewobject ^= 0 then do;
186                     call object_$objst (rpc, reloc_vers);
187                     rpc = rpc + 1;
188                     end;
189 
190           /* output the definition relocation bits count then the definition bits */
191 
192           call object_$objst(rpc, idfcnt ) ;
193           rpc = rpc + 1 ;
194 
195           pakrtn = label_1250;          /* process internal definitions */
196 
197           do i = itxpc to itxpc+new_definition_length-1;
198                     call object_$getbtx(i, lbits, rbits);
199                     iword = tx_word(i);
200                     goto label_5000;
201 label_1250:
202                     tx_word(i) = iword;
203             end;
204 
205           pakrtn = label_1275 ;         /* add explicit definition section */
206           itemp = idfpc - 1 ;
207 
208 definition_loop:
209           do i = 0 to itemp ;
210                     call object_$getbdf(i, lbits, rbits ) ;
211                     iword = df_word(i);
212                     go to label_5000 ;
213 label_1275:
214                     df_word(i) = iword;
215           end definition_loop ;
216 
217           if j = 0 then go to label_1100 ;
218 
219           call object_$objst(rpc, buff ) ;
220 
221           rpc = rpc + 1 ;
222 
223 
224 
225           /* process the symbol relocation bits */
226 
227 label_1100:
228 
229           j = 0 ;
230 
231           buff = 0 ;
232 
233           lbits = 0 ;
234 
235           rbits = 0 ;
236 
237           bits = 0 ;
238 
239 
240           if tnewobject ^= 0 then do;
241                     call object_$objst (rpc, reloc_vers);
242                     rpc = rpc + 1;
243                     end;
244 
245           /* output the symbol relocation bits count then the symbol bits */
246 
247 
248           call object_$objst(rpc, istcnt ) ;
249 
250           rpc = rpc + 1 ;
251 
252           pakrtn = label_1175 ;
253 
254           itemp = istpc - 1 ;
255 
256 symbol_loop:
257 
258           do i = 0 to itemp ;
259 
260                     call object_$getbst(i, lbits, rbits ) ;
261                     iword = st_word(i);
262 
263                     go to label_5000 ;
264 
265 label_1175:
266                     st_word(i) = iword;
267 
268 end symbol_loop ;
269 
270 
271 
272 
273 
274           istpc = rpc ;
275           if j = 0 then return ;
276           call object_$objst(istpc, buff ) ;
277           istpc = istpc + 1 ;
278 
279           return ;            /* as all bits have been processed */
280 
281 
282 
283 
284 
285           /* internal routine to process relocation bits patterns as retrieved by the GETxxx routines */
286           /* The patterns are contained in the right halves of full words ( in lbits and rbits ).
287                     This internal routine concatenates the relocation bits and outputs them when a full word is filled. */
288 
289 
290 
291 label_5000:
292           if lbits = 27 /* 33o */ then do; /* relocate definition offsets */
293                     lbits = 21 /* 25o */; /* true defn relocation */
294                     word.left = word.left + new_definition_length;
295             end;
296           if rbits = 27 /* 33o */ then do; /* relocate definition offsets */
297                     rbits = 21 /* 25o */; /* true defn relocation */
298                     word.right = word.right + new_definition_length;
299             end;
300 
301           nl = 1 ;
302 
303           nr = 1 ;
304 
305           if lbits ^= 0 then nl = 5 ;
306 
307           if rbits ^= 0 then nr = 5 ;
308 
309           n = nl + nr ;
310 
311           bits = utils_$or(utils_$ls(lbits,nr), rbits ) ;
312 
313           if ( j + n ) > 36 then go to label_5050 ;
314 
315           buff = utils_$or(buff,utils_$ls(bits,36-n-j)) ;
316 
317           j = j + n ;
318 
319           go to label_5080 ;
320 
321 label_5050:
322 
323           buff = utils_$or(buff,utils_$rs(bits,n-(36-j))) ;
324 
325           call object_$objst(rpc,buff) ;
326 
327           buff = 0 ;
328 
329           rpc = rpc + 1 ;
330 
331           j = j + n - 36 ;
332 
333           buff = utils_$ls(bits,36-j) ;
334 
335 label_5080:
336 
337           /* return to the proper main loop */
338 
339           go to pakrtn ;
340 
341 end pakbit_;