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 support *heap exernal variables.
 19                                                    END HISTORY COMMENTS */
 20 
 21 
 22 lstman_:  procedure (dummy);
 23 
 24 /*        Last modified on 08/28/72 at 18:24:08 by R F Mabee.
 25           Made blkasn call table_ to enter names in xref tree, 27 July 1972, R F Mabee.
 26           Modified to put new object format entry sequence in text, 21 March 1972, R F Mabee.
 27           by Paul Green on June 23, 1970 at 2255
 28           by Noel I. Morris on March 1, 1977 for *system links        */
 29 
 30 /*                  list manipulating routines for eplbsa.
 31           lstman has eight entries and handles reference lists for eplbsa.
 32 
 33 
 34           the eight entries are as follows:
 35              namasn(xsym)  for assigning eplbsa names to definition region,
 36              blkasn(type,snlnk,xnlnk,trptr)  for assigning type-pairs,
 37              trpasn(trpcal,trparg)  for assigning trap words,
 38              lnkasn(blklnk,inexp,admod)  for assigning link pairs,
 39              eptasn(eploc,epnlnk,epllnk)  for assigning entry points,
 40              sdfasn(sdloc,sdnlnk)  for assigning segment definitions,
 41              outasn(xspc,rtnpt)  for mm or xo calls,
 42              calser(calpc,outlnk)  to search call list.
 43           in addition, various counts are maintained by these routines
 44           for use by postp2 in outputting the definitions. */
 45 
 46 
 47 %         include   varcom;
 48 %         include   alm_options;
 49 %         include   alm_lc;
 50 %         include   erflgs;
 51 %         include   concom;
 52 /* END OF THE INCLUDE FILES FOR LSTMAN */
 53 /*^L*/
 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 /* The following variables are used to assign the return arguments for each routine, since PL/I
 92    has a difficult time determining which position gets the returns value, since it has to figure
 93    out which entry was entered, and how many args it had. We can do it much better this way */
 94 
 95 dcl (     namrtn,   blkretn,  trapretn, lnkretn,  eptretn,  sdfretn,  outretn,  calretn ) fixed bin (17);
 96 
 97 
 98 /*^L
 99           j = namasn, maintain list of external names with no duplications.
100           note possibility of   entry x $, x   lda .x.1.x. $, but resultant
101           x entry in table is unique.
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 /*^L
142           j = blkasn, maintain list of type-pair blocks, note that
143           type 3 or 4 block with zero segment pointer refers to the text
144           segment associated with this block. */
145 
146 blkasn:   entry( type, snlnk, xnlnk, trptr, blkretn );
147 
148 /* Put segname and entryname in cross reference tree. */
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);   /* Segname is valid. */
152           else if type = 1 | type = 5 then do;    /* Self-reference, fabricate name. */
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);  /* Valid entry name. */
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;                   /* blklst is index of lastest "block" created. */
170 
171 label_2020:
172             if (j  =  0) then go to label_2200 ;  /* search blklst, if found, return index, if not, add it on. */
173           /* ignore presence of trptr in search */
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           /*^L
190           j  =  trpasn, maintain list of trap pointer words. */
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           /*^L      xlnkno = lnkasn, enter normal link pair words into link list.
218 
219           explst entries are of the form--
220           0,next
221           ptr to type-pair block,value of internal expressison
222           0,ptr to location counter for inexp.
223           --the lh of first word is filled in during postp2 with the
224           absolute address of the internal expression word.  this
225           address is then used in the second word of the link
226           pair. */
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;                        /* this saves having to subtract the 2 again */
288           lnkno = lnkno+2 ;
289           return;
290 
291 
292            /*^L  xlnkno = eptasn, enter entry points into link structure list. */
293 
294 eptasn:   entry(eploc,epnlnk,epllnk,eptlc,etrap,eclass, eptretn );
295 
296 label_5000:
297           tvno = tvcnt ;      /* add to transfer vector */
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            /*   the length of the entry sequence is 6 words for both
333            mastermode and slave programs. */
334           eptretn = lnkno;
335           if tnewobject = 0 then lnkno  =  lnkno + 6;
336           else entrieslc = entrieslc + eb_data_$new_nentls;
337           return;
338 
339 
340                     /*^L j  =  sdfasn, enter segdef information into definition list. */
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                     /*^L j   =  outasn, enter information of mm or xo  call into link list. */
358                     /* final format of block in link list is,
359              (3,next),(traout),(mylnk,tvno),(spc,lpaswd) */
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           /* assign outlst block */
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                     /*^L j  =  calser, search call list for calpc, return lstlnk and outlnk. */
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                     /* found, set lstman and outlnk, then return. */
415 label_8100:
416 
417           outlnk = l ;
418           calretn = j;
419           return;
420 
421           /* not found, return with zeroes */
422 label_8200:
423           outlnk = 0 ;
424           calretn = 0;
425           return;
426 
427 
428 end lstman_;