1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 pakbit_: procedure ;
23
24
25
26
27
28
29
30
31
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
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
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
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
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
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
169
170 if j = 0 then go to label_1200 ;
171
172 call object_$objst(rpc, buff ) ;
173
174 rpc = rpc + 1 ;
175
176
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
191
192 call object_$objst(rpc, idfcnt ) ;
193 rpc = rpc + 1 ;
194
195 pakrtn = label_1250;
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 ;
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
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
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 ;
280
281
282
283
284
285
286
287
288
289
290
291 label_5000:
292 if lbits = 27 then do;
293 lbits = 21 ;
294 word.left = word.left + new_definition_length;
295 end;
296 if rbits = 27 then do;
297 rbits = 21 ;
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
338
339 go to pakrtn ;
340
341 end pakbit_;