1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 lstman_: procedure (dummy);
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47 % include varcom;
48 % include alm_options;
49 % include alm_lc;
50 % include erflgs;
51 % include concom;
52
53
54
55 dcl ( glpl_$clh ext entry ( fixed bin(26) ),
56 glpl_$crh ext entry ( fixed bin(26) ),
57 glpl_$cwrd ext entry ( fixed bin (26) ),
58 glpl_$glwrd ext entry ( fixed bin (26), fixed bin (26) ),
59 glpl_$setblk ext entry ( fixed bin(26), fixed bin(26) ),
60 table_ external entry (fixed binary (26), fixed binary, fixed binary, fixed binary, fixed binary),
61 utils_$nswrds ext entry ( fixed bin (26) )
62 ) returns ( fixed bin(26));
63
64 dcl ( words(5), xsym(8), type, nwrds, xnlnk, trptr, trpcal, trparg, blklnk,
65 inexp, admod, eploc, epnlnk, epllnk, sdloc, snlnk, xspc, rtnpt,
66 calpc, outlnk, explnk, tvrtn, tvno, tvlnk, epelnk, eptlc, sdlc,
67 rtnlc, etrap, eclass, sdtrap, sclass, k, j, iad, lc,
68 l, ii, lnkout, namlnk, link, sdnlnk, dummy ) fixed bin (26) ;
69
70 declare temp_ptr pointer;
71
72 dcl (eb_data_$l0r0, eb_data_$l1r0, eb_data_$l2r0, eb_data_$l3r0 ) ext fixed bin (17) ;
73 declare eb_data_$atext (2) fixed binary external static,
74 eb_data_$alink (2) fixed binary external static,
75 eb_data_$asym (2) fixed binary external static,
76 eb_data_$astat (2) fixed binary external static,
77 eb_data_$asys (2) fixed binary external static,
78 eb_data_$aheap (2) fixed binary external static;
79
80 declare eb_data_$new_nentls external fixed binary;
81
82 dcl eb_data_$lavptr ext pointer;
83
84 declare based_word fixed binary based aligned;
85 dcl 1 word based aligned,
86 2 left char(2) unaligned,
87 2 right char(2) unaligned;
88
89 declare twop18 fixed binary (26) internal static initial (1000000000000000000b);
90
91
92
93
94
95 dcl ( namrtn, blkretn, trapretn, lnkretn, eptretn, sdfretn, outretn, calretn ) fixed bin (17);
96
97
98
99
100 note
101
102
103 namasn: entry(xsym, namrtn);
104
105 label_1000:
106 nwrds = utils_$nswrds(xsym(1)) ;
107 if nwrds ^= 0 then go to label_1010 ;
108 prntf = 1 ;
109 namrtn = 0;
110 return;
111
112 label_1010:
113 j = namlst ;
114
115
116 label_1020:
117 if j = 0 then go to label_1050 ;
118 link = glpl_$clh(j) ;
119
120 label_1030:
121 do k = 1 to nwrds ;
122 if (xsym(k) ^= glpl_$cwrd(link+k-1)) then go to label_1040 ;
123 end label_1030 ;
124
125 namrtn = j;
126 return;
127
128 label_1040:
129 j = glpl_$crh(j) ;
130 go to label_1020 ;
131
132 label_1050:
133 namlnk = glpl_$setblk(xsym(1),nwrds) ;
134 words(1) = glpl_$glwrd(namlnk,namlst) ;
135 words(2) = 0 ;
136 namlst = glpl_$setblk(words(1),2) ;
137 namrtn = namlst;
138 return;
139
140
141
142 note
143
144
145
146 blkasn: entry( type, snlnk, xnlnk, trptr, blkretn );
147
148
149 if tnoxref ^= 0 then goto label_2000;
150
151 if type = 3 | type = 4 then ii = table_ (iassgn, glpl_$clh (snlnk), 0, 0, 0);
152 else if type = 1 | type = 5 then do;
153 if snlnk = 0 then temp_ptr = addr (eb_data_$atext (1));
154 else if snlnk = 1 then temp_ptr = addr (eb_data_$alink (1));
155 else if snlnk = 2 then temp_ptr = addr (eb_data_$asym (1));
156 else if snlnk = 4 then temp_ptr = addr (eb_data_$astat (1));
157 else if snlnk = 5 then temp_ptr = addr (eb_data_$asys (1));
158 else if snlnk = 6 then temp_ptr = addr (eb_data_$aheap (1));
159 ii = table_ (iassgn, temp_ptr -> based_word, 0, 0, 0);
160 end;
161
162 if type = 2 | type = 4 | type = 5 then ii = table_ (iassgn, glpl_$clh (xnlnk), 0, 0, 0);
163
164 label_2000:
165 words(2) = glpl_$glwrd(type,trptr) ;
166 words(3) = glpl_$glwrd(snlnk,xnlnk) ;
167
168 label_2010:
169 j = blklst;
170
171 label_2020:
172 if (j = 0) then go to label_2200 ;
173
174 if (type = glpl_$clh(j+1) & words(3) = glpl_$cwrd(j+2)) then go to label_2100 ;
175 j = glpl_$crh(j) ;
176 go to label_2020 ;
177
178 label_2100:
179 blkretn = j;
180 return;
181
182 label_2200:
183 words(1) = blklst ;
184 blklst = glpl_$setblk(words(1),3) ;
185 blkretn = blklst;
186 return;
187
188
189
190
191
192 trpasn: entry (trpcal, trparg, trapretn );
193
194 label_3000:
195 words(2) = glpl_$glwrd(trpcal,trparg) ;
196
197 label_3010:
198 j = trplst ;
199
200 label_3020:
201 if (j = 0) then go to label_3200 ;
202 if (words(2) = glpl_$cwrd(j+1)) then go to label_3100 ;
203 j = glpl_$crh(j) ;
204 go to label_3020 ;
205
206 label_3100:
207 trapretn = j;
208 return;
209
210 label_3200:
211 words(1) = trplst ;
212 trplst = glpl_$setblk(words(1),2) ;
213 trapretn = trplst;
214 return;
215
216
217
218
219
220
221
222
223
224
225
226
227
228 lnkasn: entry (blklnk,inexp,admod,lc, lnkretn ) ;
229
230 label_4000:
231 words(2) = glpl_$glwrd(blklnk,inexp) ;
232 iad = lc ;
233
234 label_4010:
235 j = explst ;
236
237 label_4020:
238 if (j = 0) then go to label_4200 ;
239 if (words(2) = glpl_$cwrd(j+1) & glpl_$crh(j+2) = iad) then go to label_4100 ;
240 j = glpl_$crh(j) ;
241 go to label_4020 ;
242
243 label_4100:
244 explnk = j ;
245 go to label_4300 ;
246
247 label_4200:
248 words(1) = explst ;
249 words(3) = iad ;
250 explst = glpl_$setblk(words(1),3) ;
251 explnk = explst ;
252 words(2) = glpl_$glwrd(explnk,admod) ;
253 go to label_4500 ;
254
255 label_4300:
256 words(2) = glpl_$glwrd(explnk,admod) ;
257
258 label_4310:
259 j = lnklst ;
260 l = 0 ;
261
262 label_4320:
263 if j = 0 then go to label_4500 ;
264
265 ii = glpl_$clh(j) ;
266 if ( ii < 3) then go to label_4330 ;
267 l = l+2 ;
268 go to label_4340 ;
269 label_4330:
270 if ( words(2) = glpl_$cwrd(j+1) & ii = 1 ) then go to label_4400 ;
271 if ii = 1 then l = l+2 ;
272 if(ii ^= 2 ) then go to label_4340 ;
273 if tnewobject = 0 then l = l + 6 ;
274 label_4340:
275 j = glpl_$crh(j) ;
276 go to label_4320 ;
277
278 label_4400:
279 lnkretn = l;
280 return;
281
282 label_4500:
283 words(1) = eb_data_$l1r0 ;
284 link = glpl_$setblk(words(1),2) ;
285 ndlkls -> word.right = addr(link) -> word.right;
286 ndlkls = ptr( eb_data_$lavptr,link );
287 lnkretn = lnkno;
288 lnkno = lnkno+2 ;
289 return;
290
291
292
293
294 eptasn: entry(eploc,epnlnk,epllnk,eptlc,etrap,eclass, eptretn );
295
296 label_5000:
297 tvno = tvcnt ;
298 tvcnt = tvcnt+1 ;
299
300 words(1) = eb_data_$l0r0 ;
301 words(2) = glpl_$glwrd(tvno,eploc) ;
302 words(3) = glpl_$glwrd(eptlc,tinhib) ;
303 tvlnk = glpl_$setblk(words(1),3) ;
304 ndtvls -> word.right = addr(tvlnk) -> word.right;
305 ndtvls = ptr( eb_data_$lavptr,tvlnk );
306
307 label_5100:
308 words(1) = eb_data_$l2r0 ;
309 words(2) = glpl_$glwrd(epllnk,tvno) ;
310 words(3) = glpl_$glwrd(tvlnk,tinhib) ;
311 epelnk = glpl_$setblk(words(1),3) ;
312 ndlkls->word.right = addr(epelnk)->word.right;
313 ndlkls = ptr( eb_data_$lavptr, epelnk);
314
315 label_5200:
316 if epnlnk = 0 then go to label_5300 ;
317 words(1) = glpl_$glwrd(epnlnk,xdflst) ;
318 if tnewobject = 0 then do;
319 words(2) = glpl_$glwrd(lnkno,eclass) ;
320 words(3) = glpl_$glwrd(etrap,(lpsect)) ;
321 end;
322 else do;
323 words (2) = glpl_$glwrd (entrieslc + 1, 0);
324 words (3) = glpl_$glwrd (etrap, (lpentries));
325 end;
326 words (4) = epelnk * twop18;
327 xdflst = glpl_$setblk (words (1), 4);
328
329 label_5300:
330
331
332
333
334 eptretn = lnkno;
335 if tnewobject = 0 then lnkno = lnkno + 6;
336 else entrieslc = entrieslc + eb_data_$new_nentls;
337 return;
338
339
340
341
342 sdfasn: entry( sdloc, sdnlnk, sdlc, sdtrap, sclass, sdfretn );
343
344 label_6000:
345 if tprot ^= 0 then prntx = 1 ;
346
347 label_6100:
348 words(1) = glpl_$glwrd(sdnlnk,xdflst) ;
349 words(2) = glpl_$glwrd(sdloc,sclass) ;
350 words(3) = glpl_$glwrd(sdtrap,sdlc) ;
351 words (4) = 0;
352 xdflst = glpl_$setblk (words (1), 4) ;
353 sdfretn = xdflst ;
354 return;
355
356
357
358
359
360
361 outasn: entry (xspc,rtnpt,rtnlc, outretn );
362
363 label_7000:
364 tvno = tvcnt ;
365 tvcnt = tvcnt+1 ;
366 words(1) = eb_data_$l0r0 ;
367 words(2) = glpl_$glwrd(tvno,rtnpt) ;
368 words(3) = glpl_$glwrd(rtnlc,tinhib) ;
369 tvlnk = glpl_$setblk(words(1),3) ;
370 ndtvls -> word.right = addr( tvlnk ) -> word.right;
371 ndtvls = ptr( eb_data_$lavptr, tvlnk);
372
373
374 label_7100:
375 words(1) = eb_data_$l3r0 ;
376 words(2) = eb_data_$l0r0 ;
377 words(3) = glpl_$glwrd(mylnk,tvno) ;
378 words(4) = glpl_$glwrd(xspc,0) ;
379 words(5) = tinhib ;
380 lnkout = glpl_$setblk(words(1),5) ;
381 ndlkls -> word.right = addr( lnkout ) -> word.right;
382 ndlkls = ptr( eb_data_$lavptr, lnkout);
383 lnkno = lnkno+2 ;
384 outretn = lnkout ;
385 return;
386
387
388
389
390 calser: entry (calpc,outlnk, calretn );
391
392 label_8000:
393 j = lnklst ;
394
395 l = 0 ;
396
397 label_8010:
398 if j = 0 then go to label_8200 ;
399 if (glpl_$clh(j) ^= 3) then go to label_8020 ;
400 if (glpl_$clh(j+3) = calpc) then go to label_8100 ;
401 l = l+2 ;
402 go to label_8030 ;
403
404 label_8020:
405 ii = glpl_$clh(j) ;
406 if ( ii = 1 ) then l = l + 2 ;
407 if ii ^= 2 then go to label_8030 ;
408 l = l + 6 ;
409
410 label_8030:
411 j = glpl_$crh(j) ;
412 go to label_8010 ;
413
414
415 label_8100:
416
417 outlnk = l ;
418 calretn = j;
419 return;
420
421
422 label_8200:
423 outlnk = 0 ;
424 calretn = 0;
425 return;
426
427
428 end lstman_;