$CONTROL USLINIT,MAP,CODE                                               00010000
<< load - module 05 >>                                                  00015000
<<hp32002c mpe source c.00.00>>                                         00020000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1982.          ",&    00025000
$  "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A       ",&    00030000
$  "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR     ",&    00035000
$  "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",&    00040000
$  "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED   ",&    00045000
$  "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."      00050000
$title "     MPE LOAD PROCESS"                                          00055000
$control segment=load,main=load                                         00060000
$control privileged,uncallable                                          00065000
$thirty                                                                 00070000
begin                                                                   00075000
$page                                                                   00080000
<<*************************************************>>          <<06094>>00085000
<<                                                 >>          <<06094>>00090000
<< the load process had been rewritten for the cst >>          <<06094>>00095000
<< expansion project and integrated into the mpev. >>          <<06094>>00100000
<<                                                 >>          <<06094>>00105000
<<              january, 1983                      >>          <<06094>>00110000
<<                                                 >>          <<06094>>00115000
<<*************************************************>>          <<06094>>00120000
$page                                                                   00125000
<<----------------------------------------------------------->>         00130000
<<                                                           >>         00135000
<<                            load process                   >>         00140000
<<                                                           >>         00145000
<<----------------------------------------------------------->>         00150000
                                                                        00155000
<<error numbers>>                                                       00160000
                                                                        00165000
equate err20 = 20,  <<illegal library search>>                          00170000
       err21 = 21,  <<unknown entry point>>                             00175000
       err22 = 22,  <<trace sybsystem not present>>                     00180000
       err23 = 23,  <<stack size too small>>                            00185000
       err24 = 24,  <<max. data > 32k>>                                 00190000
       err25 = 25,  <<data segment > max data segment>>                 00195000
       err26 = 26,  <<program loaded in opposite mode>>                 00200000
       err27 = 27,  <<sl binding error>>                                00205000
       err28 = 28,  <<invalid system sl file>>                          00210000
       err29 = 29,  <<invalid public sl file>>                          00215000
       err30 = 30,  <<invalid group sl file>>                           00220000
       err31 = 31,  <<invalid program file>>                            00225000
       err32 = 32,  <<invalid list file>>                               00230000
       err33 = 33,  <<code segment > system max.>>                      00235000
       err34 = 34,  <<program uses more than one extent>>               00240000
       err35 = 35,  <<data segment > 32k>>                              00245000
       err36 = 36,  <<data segment > system max.>>                      00250000
       err37 = 37,  <<nr. code segments > 63>>                          00255000
       err38 = 38,  <<nr. code segments > system max.>>                 00260000
       err39 = 39,  <<illegal capability>>                              00265000
       err40 = 40,  <<too many procedures loaded>>                      00270000
       err41 = 41,  <<unknown procedure name>>                          00275000
       err42 = 42,  <<invalid procedure number>>                        00280000
       err43 = 43,  <<illegal procedure unload>>                        00285000
       err44 = 44,  <<illegal sl capability>>                           00290000
       err45 = 45,  <<invalid entry point>>                             00295000
       err50 = 50,  <<unable to open system sl file>>                   00300000
       err51 = 51,  <<unable to open public sl file>>                   00305000
       err52 = 52,  <<unable to open group sl file>>                    00310000
       err53 = 53,  <<unable to open program file>>                     00315000
       err54 = 54,  <<unable to open list file>>                        00320000
       err55 = 55,  <<unable to close system sl file>>                  00325000
       err56 = 56,  <<unable to close public sl file>>                  00330000
       err57 = 57,  <<unable to close group sl file>>                   00335000
       err58 = 58,  <<unable to close program file>>                    00340000
       err59 = 59,  <<unable to close list file>>                       00345000
       err60 = 60,  <<eof or i/o error on system sl file>>              00350000
       err61 = 61,  <<eof or i/o error on public sl file>>              00355000
       err62 = 62,  <<eof or i/o error on group sl file>>               00360000
       err63 = 63,  <<eof or i/o error on program file>>                00365000
       err64 = 64,  <<eof or i/o error on list file>>                   00370000
       err65 = 65,  <<unable to obtain cst entries>>                    00375000
       err66 = 66,  <<unable to obtain process dst entry>>              00380000
       err67 = 67,  <<unable to obtain mail data segment>>              00385000
       err68 = 68,  <<unable to obtain working set>>                    00390000
       err70 = 70,  <<segment table overflow>>                          00395000
       err71 = 71,  <<unable to obtain sufficient dl storage>>          00400000
       err72 = 72,  <<attio error>>                                     00405000
       err73 = 73,  <<unable to obtain virtual memory>>                 00410000
       err74 = 74,  <<directory i/o error>>                             00415000
       err75 = 75,  <<print i/o error>>                                 00420000
       err76 = 76,  <<illegal dlsize>>                                  00425000
       err80 = 80,  <<program already allocated>>                       00430000
       err81 = 81,  <<illegal program allocation>>                      00435000
       err82 = 82,  <<program not allocated>>                           00440000
       err83 = 83,  <<illegal program deallocation>>                    00445000
       err84 = 84,  <<procedure already allocated>>                     00450000
       err85 = 85,  <<illegal procedure allocation>>                    00455000
       err86 = 86,  <<procedure not allocated>>                         00460000
       err87 = 87,  <<illegal procedure deallocation>>                  00465000
       warn88= 88,  <<lmap not available>>                              00470000
       warn89= 89,  <<load with lib=s>>                                 00475000
       warn90= 90,  <<load with lib=p>>                                 00480000
       warn91= 91,  <<load with lib=g>>                                 00485000
       err92 = 92,  <<allocate/deallocate from non-system disc <<e9062>>00490000
       err93 = 93,  <<unable to mount prog's home vol. set>>   <<06094>>00495000
       err94 = 94,  <<unable to mount sys sl's h.v.s.>>        <<06094>>00500000
       err95 = 95,  <<unable to mount private sl's h.v.s.>>    <<06094>>00505000
       err96 = 96,  <<unable to mount group sl's h.v.s.>>      <<06094>>00510000
       err97 = 97,  <<unable to load remote program>>                   00515000
       err98 = 98,  <<unable to convert old format>>                    00520000
       err99 = 99,  <<unable to obtain dst for logical map>>            00525000
       err100=100,  <<too many mapped segments>>                        00530000
       err101=101,  <<segmap too big>>                                  00535000
       err102=102,  <<unable to expand segmap>>                         00540000
       err103=103;  <<too many dynamic loads on procedure>>             00545000
$page                                                                   00550000
<<--------------------------------------------------------->>           00555000
<<                                                         >>           00560000
<< miscellaneous definitions                               >>           00565000
<<                                                         >>           00570000
<<--------------------------------------------------------->>           00575000
                                                                        00580000
define asmb           = assemble#,                                      00585000
       abs            = absolute#,                                      00590000
       setbit0        = assemble(tsbc 0)#,                              00595000
       condcode       = status.(6:2)#,                                  00600000
       turnofftraps   = push(status);                                   00605000
                        tos.(2:1):=0;                                   00610000
                        set(status)#;                                   00615000
equate ccg            = 0,                                              00620000
       ccl            = 1,                                              00625000
       cce            = 2;                                              00630000
integer xreg          = x;                                              00635000
integer status        = q-1;                                            00640000
byte bs1              = s-1,                                            00645000
     bs2              = s-2;                                            00650000
integer s0            = s-0,                                            00655000
        s1            = s-1,                                            00660000
        s2            = s-2,                                            00665000
        s3            = s-3;                                            00670000
logical ls0           = s-0;                                            00675000
double ds1            = s-1,                                            00680000
       ds2            = s-2,                                            00685000
       ds3            = s-3,                                            00690000
       ds6            = s-6;                                            00695000
byte pointer bps0     = s-0;                                            00700000
integer pointer ps0   = s-0,                                            00705000
                ps1   = s-1;                                            00710000
double pointer dps2   = s-2;                                            00715000
equate p256           = 256,                                            00720000
       p384           = 384;                                            00725000
integer temp1,                                                          00730000
        temp2;                                                          00735000
integer pointer ptemp3;                                                 00740000
double dtemp4;                                                          00745000
integer array buf1(0:255),                                              00750000
              buf2(*)=buf1(128);                                        00755000
integer savesir;                                                        00760000
logical usercap;                                                        00765000
integer cstbx,                  <<cst block index          >>           00770000
        globalflags;            <<flags used during load   >>           00775000
define cstsallocated  = globalflags.(15:1)#,                            00780000
       cstblockallocated=globalflags.(14:1)#,                           00785000
       progloadbit    = globalflags.(13:1)#,                            00790000
       loaddomain     = globalflags.(12:1)#,                            00795000
       rtmodified     = globalflags.(11:1)#,                            00800000
       newsegmapflag  = globalflags.(10:1)#;                            00805000
equate phydomain = 1;                                          <<06281>>00810000
equate load'done'message = %777,                               <<*7545>>00815000
       load'message = %111;                                    <<*7545>>00820000
$page                                                                   00825000
<<--------------------------------------------------------->>           00830000
<<                                                         >>           00835000
<< system definitions                                      >>           00840000
<<                                                         >>           00845000
<<--------------------------------------------------------->>           00850000
                                                                        00855000
equate sslkeya        = %1126,  <<system sl file key       >>           00860000
       maxcodeseg     = %1106,  <<max # prog file code segs>>           00865000
       maxcode        = %1105;  <<max code seg size        >>           00870000
pointer pcb           = 3;      <<sysglob ptr to pcb       >>           00875000
integer pointer dsti  = 2;      <<sysglob ptr to dst       >>           00880000
define dslen          = (3:13)#;<<dst entry length field   >>           00885000
equate syswaittodispmsg=%1053;                                 <<06094>>00890000
define phasetransflag=(3:1)#;                                  <<06094>>00895000
$page                                                                   00900000
<<----------------------------------------------------------->>         00905000
<<                                                           >>         00910000
<< dl area parameters                                        >>         00915000
<<                                                           >>         00920000
<<----------------------------------------------------------->>         00925000
                                                                        00930000
equate sysdl = 10,  <<nr. words dl area reserved for system>>           00935000
       dlincrement = 128; <<nr. words by which dl is expanded>>         00940000
integer pointer dlarea1; <<dl used area1 pointer>>                      00945000
integer pointer dlarea2;  <<dl used area 2 pointer>>                    00950000
integer pointer dlavail;  <<dl available area pointer>>                 00955000
integer dlsze;             <<initial dl size>>                          00960000
$page                                                                   00965000
<<----------------------------------------------------------->>         00970000
<<                                                           >>         00975000
<< list file buffers and parameters                          >>         00980000
<<                                                           >>         00985000
<<----------------------------------------------------------->>         00990000
                                                                        00995000
integer listfnum := 0;  <<list device file nr.>>                        01000000
byte array listdesig (0:8) := "LOADLIST ";                              01005000
integer array line (0:35);  <<list buffer>>                             01010000
byte array bline (*) = line;                                            01015000
logical listflag;  <<true if listing generated>>                        01020000
double listaddr;  << loadlist file disk address >>                      01025000
integer listaddr1 = listaddr;                                           01030000
integer listaddr2 = listaddr+1;                                         01035000
$page                                                                   01040000
<<--------------------------------------------------------->>           01045000
<<                                                         >>           01050000
<< loader segment table definitions                        >>           01055000
<<                                                         >>           01060000
<<--------------------------------------------------------->>           01065000
                                                                        01070000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01075000
<< global area                                             >>           01080000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01085000
                                                                        01090000
equate segtabdst = 18,          <<lst dst #                >>           01095000
       segtabsir = 17;          <<lst sir #                >>           01100000
equate numentrytype = 9;        <<# directory entry types  >>           01105000
integer array lst(*) = db+0;    <<lst                      >>           01110000
integer array dir(@) = db+0;    <<ptr to entry directory   >>           01115000
integer dirlen       = db+1;    <<directory length         >>           01120000
integer array lct(@) = db+2;    <<ptr to loader comm. tab. >>           01125000
integer pointer entp = db+3,    <<primary entry ptr        >>           01130000
                entp1= db+4,    <<secondary entry ptr      >>           01135000
                ENTP2= DB+5,    <<    "       "    "       >>           01140000
                ENTP3= DB+6;    <<    "       "    "       >>           01145000
DOUBLE POINTER ENTDP = ENTP,    <<    "       "    "       >>           01150000
               ENTDP1= ENTP1,   <<    "       "    "       >>           01155000
               ENTDP2= ENTP2,   <<    "       "    "       >>           01160000
               ENTDP3= ENTP3;   <<    "       "    "       >>           01165000
integer array sbuf0(@)=db+7;    <<disc buffer (128 words)  >>           01170000
integer si           = db+8,    <<utility integer          >>           01175000
        sj           = db+9,    <<   "       "             >>           01180000
        sk           = db+10,   <<   "       "             >>           01185000
        sl           = db+11,   <<   "       "             >>           01190000
        sm           = db+12,   <<   "       "             >>           01195000
        sn           = db+13,   <<   "       "             >>           01200000
        so           = db+14,   <<   "       "             >>           01205000
        sp           = db+15,   <<   "       "             >>           01210000
        sq           = db+16,   <<   "       "             >>           01215000
        sr           = db+17,   <<   "       "             >>           01220000
        ss           = db+18,   <<   "       "             >>           01225000
        st           = db+19;   <<   "       "             >>           01230000
integer pointer psi  = si,      <<utility ptr              >>           01235000
                pss  = ss,      <<   "     "               >>           01240000
                pst  = st;      <<   "     "               >>           01245000
double pointer dpst  = st;      <<   "     "               >>           01250000
integer array hdfwdlink(*)=db+20,<<head link for entry type>>           01255000
              hdbkwdlink(*)=hdfwdlink+numentrytype;                     01260000
                                <<tail link for entry type >>           01265000
$page                                                                   01270000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01275000
<<  loader communication table (lct)                       >>           01280000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01285000
                                                                        01290000
equate lctptr        = 2,       <<offset to lct ptr in lst >>           01295000
       lctlength     = 22;      <<length of lct            >>           01300000
                                                                        01305000
<<incoming message>>                                                    01310000
                                                                        01315000
define mallocate     = logical(lctbuf.(0:1))#,<<allocate cmd>>          01320000
       mcommand      = lctbuf.(0:2)#, <<loader command     >>           01325000
       mlibsearch    = lctbuf.(2:2)#, <<library search     >>           01330000
       mpmode        = logical(lctbuf.(4:1))#,<<load mode  >>           01335000
       mlmap         = logical(lctbuf.(6:1))#,<<load map   >>           01340000
       mpin          = lctbuf(1)#,    <<process pin        >>           01345000
       mloaddomain   = lctbuf.(5:1)#, <<load domain        >>           01350000
       mprogkey      = lctbuf(2)#,    <<program file key   >>           01355000
       mprocname     = lctbuf(3)#,    <<procedure name     >>           01360000
       wproc         = lctbuf(11)#,   <<waiting process pin>>           01365000
       usercap2      = lctbuf(12)#,   <<capability         >>           01370000
       mpvinfo       = lctbuf(21)#,   <<private vol info   >>           01375000
       mextension    = lctbuf(2)#,    <<extension #        >>           01380000
       mgroup        = lctbbuf(26)#,  <<user group         >>           01385000
       macct         = lctbbuf(34)#;  <<user account       >>           01390000
define procload      = logical(mcommand)#,<<load/allocate  >>           01395000
                                          <<procedure      >>           01400000
       allocproc     = mcommand=3#,   <<allocate procedure >>           01405000
       progload      = not procload#; <<load/allocate prog >>           01410000
                                                                        01415000
<<outgoing message>>                                                    01420000
                                                                        01425000
define lctanswer     = lctbuf(0)#,<<answer from load       >>           01430000
       lcterror      = lctbuf(1)#,<<load error             >>           01435000
       lctlistflag   = lctbuf(2)#,<<load map flag          >>           01440000
       lctlmapldev   = lctbuf(3)#,<<load map ldev          >>           01445000
       lctlmaphida   = lctbuf(4)#,<<load map hi disc addr  >>           01450000
       lctlmaploda   = lctbuf(5)#;<<load map lo disc addr  >>           01455000
$page                                                                   01460000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01465000
<< directory entry definitions                             >>           01470000
<<  (common to all entries)                                >>           01475000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01480000
                                                                        01485000
equate garbage       = 0,       <<garbage entry type #     >>           01490000
       slfile        = 1,       <<sl file entry type #     >>           01495000
       progfile      = 2,       <<program file entry type #>>           01500000
       loading       = 3,       <<program loading entry typ>>           01505000
       waiting       = 4,       <<process waiting entry typ>>           01510000
       loaded        = 5,       <<process wait completed   >>           01515000
       sharer        = 6,       <<process info entry type  >>           01520000
       extension     = 7,       <<dynamic load entry type  >>           01525000
       loadprocmaster= 8;       <<master dynamic load entry>>           01530000
equate anymode       = -1,      <<wild card for entry mode >>           01535000
       normal        = 0;       <<normal (priv.) mode      >>           01540000
define fwdlink  = entp(-3)#,    <<entry forward link       >>           01545000
       bkwdlink = entp(-2)#,    <<entry backward link      >>           01550000
       rlength  = entp(-1)#,    <<region length--header +  >>           01555000
                                <<  entry + trailing excess>>           01560000
       etype    = entp.(8:8)#;  <<entry type               >>           01565000
$page                                                                   01570000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01575000
<<  (garbage entry - type 0)                               >>           01580000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01585000
                                                                        01590000
define enwg = entp(-1)#;        <<garbage entry length     >>           01595000
                                                                        01600000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01605000
<<  (sl file entry - type 1)                               >>           01610000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01615000
                                                                        01620000
define efid        = entdp1#,   <<file id                  >>           01625000
       efid1       = entp(1)#,  <<file id - word 1         >>           01630000
       efid2       = entp(2)#,  <<file id - word 2         >>           01635000
       epvinfo'sl  = entp(3)#,  <<private vol info         >>           01640000
       eallocseg'sl= entp(4).(0:8)#,<<# allocated seg in sl>>           01645000
       eslseg'sl   = entp(4).(8:8)#,<<# seg list entries   >>           01650000
       <<  seg list entry definitions                      >>           01655000
       sllogsegnr  = ptemp2.(0:8)#, <<sl logical seg number>>           01660000
       systemseg   = logical(ptemp2.(14:1))#, <<flags x-bit>>           01665000
       refcount    = ptemp2(1)#,    <<log seg reference cnt>>           01670000
       phycst      = ptemp2(2)#;    <<log seg's cst #      >>           01675000
                                                                        01680000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01685000
<<  (program file entry - type 2)                          >>           01690000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01695000
                                                                        01700000
define epmode      = entp.(0:1)#, <<program mode           >>           01705000
       epa         = entp.(1:1)#, <<allocated flag         >>           01710000
       elib        = entp.(4:4)#, <<lib search             >>           01715000
       ecstblk     = entp(3)#,    <<cst block index        >>           01720000
       emapdst     = entp(4)#,    <<segmap dst number      >>           01725000
       eshr        = entp(5)#,    <<prog file reference cnt>>           01730000
       eseg        = entp(6).(0:8)#,<<# segs in prog file  >>           01735000
       eslinfo'prog= entp(6).(8:8)#,<<# slinfo areas       >>           01740000
       epvinfo'prog= entp(7)#,    <<private vol info       >>           01745000
       etrace'plabel=entp1(7)#,   <<trace0' external label >>           01750000
       emapsize    = entp3#;      <<# entries in map array >>           01755000
                                                                        01760000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01765000
<<  (prog file loading entry - type 3)                     >>           01770000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01775000
                                                                        01780000
<< no definitions unique to this entry type                >>           01785000
                                                                        01790000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01795000
<<  (process waiting entry - type 4)                       >>           01800000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01805000
                                                                        01810000
define ewaitingpin = entp2#;    <<pin of waiting process   >>           01815000
                                                                        01820000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01825000
<<  (loaded entry - type 5)                                >>           01830000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01835000
                                                                        01840000
<< no definitions unique to this entry type                >>           01845000
                                                                        01850000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01855000
<<  (process info entry - type 6)                          >>           01860000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01865000
                                                                        01870000
define epid  = entp(1)#;        <<process id               >>           01875000
                                                                        01880000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01885000
<<  (dynamic load entry - type 7)                          >>           01890000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01895000
                                                                        01900000
define eext        = entp(2)#,     <<extension #           >>           01905000
       epin        = entp(1)#,     <<pin #                 >>           01910000
       loadproccount=entp(3)#,     <<# loadproc's this ext#>>           01915000
       eslinfo'ext = entp(6+entp(5).(4:3)).(8:8)#;                      01920000
                                   <<# slinfo areas        >>           01925000
                                                                        01930000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01935000
<<  (master dynamic load entry - type 8)                   >>           01940000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01945000
                                                                        01950000
define eslid'lproc = entp(2).(0:8)#, <<# slid entries      >>           01955000
       active'lprocs=entp(2).(8:8)#, <<# active loadproc's >>           01960000
       emcstls'lproc=entp3.(8:8)#;   <<# mcstlogseg entries>>           01965000
$page                                                                   01970000
<<#########################################################>>           01975000
<<  local definitions for lst                              >>           01980000
<<#########################################################>>           01985000
                                                                        01990000
integer array lctbuf(0:lctlength-1);   <<lct buffer        >>           01995000
byte array lctbbuf(*) = lctbuf;        <<lct buffer        >>           02000000
double array mprogkey'(*) = mprogkey; <<program file key   >>           02005000
integer array mprocname'(*)=mprocname;<<procedure name     >>           02010000
double lctdback := 0d;          <<load info return area    >>           02015000
integer mstartingcst = lctdback,<<starting cst #           >>           02020000
        mplabel      = lctdback,<<starting plabel          >>           02025000
        mferror      = lctdback,<<file sys error #         >>           02030000
        merror       = lctdback+1; <<load error #          >>           02035000
integer lctoffset;              <<address of lct in lst    >>           02040000
integer pointer lprocmastertab; <<ptr to local copy of     >>           02045000
                                <<loadprocmaster entry     >>           02050000
$page                                                                   02055000
<<--------------------------------------------------------->>           02060000
<<                                                         >>           02065000
<< program file definitions                                >>           02070000
<<                                                         >>           02075000
<<--------------------------------------------------------->>           02080000
                                                                        02085000
equate progfilecode  = 1029;    <<code for program file    >>           02090000
define pzerodb       = (logical(progrec0.(2:1)))#,                      02095000
                                   <<zero db area flag     >>           02100000
       pcapability   = progrec0.(6:10)#,<<capability list  >>           02105000
       pprivmode     = progrec0.(9:1)#,<<priv mode cap.    >>           02110000
       pnrsegs       = progrec0(1)#,   <<# code segments   >>           02115000
       pglobalsize   = progrec0(2)#,   <<global area size  >>           02120000
       pglobalrecd   = progrec0(3)#,   <<global area recd# >>           02125000
       psegmentrecd  = progrec0(4)#,   <<segment list recd >>           02130000
       pstacksize    = progrec0(5)#,   <<stack size        >>           02135000
       pdlsize       = progrec0(6)#,   <<dl size           >>           02140000
       pmaxdata      = progrec0(7)#,   <<max data size     >>           02145000
       pentryrecd    = progrec0(8)#,   <<entry pt list recd>>           02150000
       pstartingseg  = progrec0(9)#,   <<starting seg #    >>           02155000
       pstartingadr  = progrec0(10)#,  <<starting pb addr  >>           02160000
       psastlt       = progrec0(11)#,  <<stlt address      >>           02165000
       psaflut       = progrec0(12)#,  <<flut address      >>           02170000
       pexternalrecd = progrec0(13)#,  <<external list recd>>           02175000
       pstartingstt  = progrec0(14)#,  <<starting stt #    >>           02180000
       psatrapcom    = progrec0(15)#;  <<trapcom address   >>           02185000
define progextstt    = (1:1)#;  <<flag in seg desc array   >>           02190000
                                <<=1 if stt in mapped form >>           02195000
                                                                        02200000
<<#########################################################>>           02205000
<<  local definitions for program file                     >>           02210000
<<#########################################################>>           02215000
                                                                        02220000
integer progfnum;               <<program file number      >>           02225000
double progkey;                 <<program file key         >>           02230000
integer pointer progrec0;       <<ptr to prog file rec 0   >>           02235000
byte pointer progmap;           <<ptr to progmap array     >>           02240000
logical lastprogloadlogical;    <<true if last load of prog>>           02245000
                                <<was with mapped firmware >>           02250000
integer npa;                    <<# program segments       >>           02255000
$page                                                                   02260000
<<--------------------------------------------------------->>           02265000
<<                                                         >>           02270000
<< sl file definitions                                     >>           02275000
<<                                                         >>           02280000
<<--------------------------------------------------------->>           02285000
                                                                        02290000
equate slfilecode    = 1031,    <<code for sl file         >>           02295000
       slfileid      = 3,       <<sl file version #        >>           02300000
       slfhi         = 33;      <<first hash bucket index  >>           02305000
                                                                        02310000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           02315000
<<  (record 0 - control information)                       >>           02320000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           02325000
                                                                        02330000
define slid          = slrec0#; <<sl file version #        >>           02335000
                                                                        02340000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           02345000
<<  directory entries                                      >>           02350000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           02355000
                                                                        02360000
integer pointer slp,            <<entry ptr                >>           02365000
                slp1;           <<secondary entry ptr      >>           02370000
define slname        = slp#,    <<entry point name         >>           02375000
       slplabel      = slp1#,   <<entry point plabel       >>           02380000
       slsttnr       = slp1.(0:8)#,<<entry point stt #     >>           02385000
       slsegnr       = slp1.(8:8)#,<<entry point seg #     >>           02390000
       slparms       = slp1(1)#;<<entry point parm info    >>           02395000
                                                                        02400000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           02405000
<<  reference table definitions                            >>           02410000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           02415000
                                                                        02420000
integer pointer rtp;            <<ref table entry ptr      >>           02425000
logical pointer rtlp = rtp;     <<ref table entry ptr      >>           02430000
double pointer rtdp = rtp;      <<ref table entry ptr      >>           02435000
define slsld        = rtp#,     <<segment descriptor       >>           02440000
       reftab'extstt = rtp.(1:1)#,  << =1 if stt in mapped >>           02445000
                                    << form                >>           02450000
       slsl          = rtp.(2:14)#,<<segment length        >>           02455000
       slsa          = rtp(1)#, <<segment address          >>           02460000
       slnrrecs      = rtp(2)#, <<# records for segment    >>           02465000
                                << and external list       >>           02470000
       slflags       = rtlp(3)#,<<segment flags            >>           02475000
       slsatisfiedseg= rtlp(3).(1:1)#,<<flag all externals >>           02480000
                                      <<of seg satisfied   >>           02485000
       slallocatedseg= rtlp(3).(4:1)#,<<flag seg allocated >>           02490000
                                      <<permanently        >>           02495000
       slcoreseg     = rtlp(3).(5:1)#,<<flag seg core res  >>           02500000
       slsystemseg   = rtlp(3).(6:1)#,<<flag seg system seg>>           02505000
       slsegname     = rtp(8)#, <<segment name             >>           02510000
       slrefedsegs   = rtp(16)#;<<bit map of ref'ed segs   >>           02515000
$page                                                                   02520000
<<#########################################################>>           02525000
<<  local sl file definitions                              >>           02530000
<<#########################################################>>           02535000
                                                                        02540000
integer slnr;                   <<current sl #             >>           02545000
integer array slfname(*) = db;  <<sl file names buffer     >>           02550000
byte array sslfname(0:10),      <<system sl name           >>           02555000
           pslfname(0:15),      <<account sl name          >>           02560000
           gslfname(0:20);      <<group sl name            >>           02565000
integer array slfnum(0:15);     <<sl file numbers          >>           02570000
double array slkey(0:15);       <<sl file keys             >>           02575000
array slcap(0:15);              <<sl capabilities          >>           02580000
integer array slrec0(*) = buf1; <<sl record 0 buffer       >>           02585000
integer array slrec1(0:15);     <<ptr to each sl's record 1>>           02590000
integer array sldir(*) = buf2;  <<sl directory buffer      >>           02595000
integer array rtbuf(*) = buf2;  <<sl reference table buffer>>           02600000
double drtrecd;                 <<current ref tab record # >>           02605000
integer rtrecd=drtrecd+1;                                               02610000
logical array slsegs(0:15);     <<ptr to sl's ref'd seg map>>           02615000
integer array slpvinfo(0:15);   <<sl private vol info      >>           02620000
integer array nsla(0:15);       <<# segs allocated in sl   >>           02625000
$page                                                                   02630000
<<--------------------------------------------------------->>           02635000
<<                                                         >>           02640000
<< sl entry point cache definitions                        >>           02645000
<<                                                         >>           02650000
<<--------------------------------------------------------->>           02655000
                                                                        02660000
define loadcacheseg  = abs(abs(%1377)+%1072)#; <<dst #     >>           02665000
equate bucketsize    = 42,      <<size of each cache bucket>>           02670000
       cachehits     = 0,       <<hit counter pointer      >>           02675000
       cachemisses   = 2,       <<miss counter pointer     >>           02680000
       bucket0       = 4,       <<first bucket pointer     >>           02685000
       nbuckets      = 95;      <<number of buckets        >>           02690000
                                                                        02695000
<<#########################################################>>           02700000
<<  local sl entry point cache definitions                 >>           02705000
<<#########################################################>>           02710000
                                                                        02715000
logical array wbucket(0:bucketsize-1);<<single bucket buffer>>          02720000
double hits,                    <<cache hit count          >>           02725000
       misses;                  <<cache miss count         >>           02730000
$page                                                                   02735000
<<--------------------------------------------------------->>           02740000
<<                                                         >>           02745000
<< logical mapping segmap definitions                      >>           02750000
<<                                                         >>           02755000
<<--------------------------------------------------------->>           02760000
                                                                        02765000
define logicalmapping = abs(%1220)#; <<true if mapping     >>           02770000
                                     <<firmware is present >>           02775000
define segtabdst'ex = abs(%1226)#;                             <<06541>>02780000
integer array segmap(*) = db+0; <<segmap array             >>           02785000
                                                                        02790000
$include inclpcb5                                              <<06641>>02795000
                                                                        02800000
<<#########################################################>>           02805000
<<  local logical mapping definitions                      >>           02810000
<<#########################################################>>           02815000
                                                                        02820000
equate initsegmapsize = 2040,   <<initial segmap size      >>           02825000
       maxsegmapsize  = 4090;   <<initial segmap vds size  >>           02830000
integer segmapdst,              <<segmap dst #             >>           02835000
        oldsegmapdst,           <<initial segmap dst #     >>           02840000
        segmapsegcount,         <<next entry position in map>>          02845000
        segmapsttposition,      <<next stt position in map >>           02850000
        segmaplength;           <<length of segmap dst     >>           02855000
integer pcbpt;  << index of pcb entry >>                                02860000
logical needsegmap;                                                     02865000
integer pointer mcsttab;        <<ptr to table of available>>           02870000
                                <<mapped cst indices       >>           02875000
integer maxmcstidx;             <<max mapped cst index used>>           02880000
$page                                                                   02885000
$page                                                                   02890000
<<----------------------------------------------------------->>         02895000
<<                                                           >>         02900000
<< unsatisfied external table and parameters                 >>         02905000
<<                                                           >>         02910000
<<----------------------------------------------------------->>         02915000
                                                                        02920000
integer pointer saveuxp;  <<save entry pointer>>                        02925000
integer pointer uxp;  <<points to name>>                                02930000
integer pointer uxp1;  <<secondary pointer>>                            02935000
integer pointer uxp2;  <<secondary pointer>>                            02940000
integer uxnw;  <<nr. words in entry>>                                   02945000
integer uxnc;  <<nr. char's in name>>                                   02950000
define uxname = uxp#,  <<external name>>                                02955000
       uxutype = uxp1.(0:4)#,  <<origin of external>>                   02960000
       uxstype = uxp1.(4:4)#,  <<satisfier of external>>                02965000
       uxnr = uxp1.(8:8)#,  <<nr. references>>                          02970000
       uxparms = uxp2#;  <<parm. info>>                                 02975000
$page                                                                   02980000
<<----------------------------------------------------------->>         02985000
<<                                                           >>         02990000
<< satisfied external table and parameters                   >>         02995000
<<                                                           >>         03000000
<<----------------------------------------------------------->>         03005000
                                                                        03010000
integer array sldb'seg'dir(0:255); <<directory for sldb seg>>           03015000
                                   <<entries--1 slot per 16>>           03020000
                                   <<logical seg numbers   >>           03025000
integer array sldatabase(0:15)=db; <<ref'ed segs data base>>            03030000
    <<local sldatabase seg entry definitions>>                          03035000
    define segnext  = 0#,         <<link to next entry>>                03040000
           dbmcst   = 1).(0:8#,   <<mcst>>                              03045000
           dblogseg = 1).(8:8#,   <<logseg>>                            03050000
           sttnext  = 2#,         <<link to stt entry>>                 03055000
           dbphycst = 3#,         <<phycst>>                            03060000
           dbmapflag= 4).(15:1#,  <<mapflag>>                           03065000
           dbflags  = 4).(12:4#,  <<a,c,x,m bits>>                      03070000
           dbxbit   = 4).(14:1#,  <<x bit>>                             03075000
           dbnewflag= 4).(11:1#,  <<newly allocated>>                   03080000
           dbrefflag= 4).(10:1#,  <<ref'ed previously>>                 03085000
           dblbit   = 4).(9:1#;   <<being allocated>>                   03090000
                                                                        03095000
    <<sldatabase stt entry definitions>>                                03100000
    define dbstt    = 0).(8:8#,   <<stt #>>                             03105000
           dbplabel = 1#,         <<plabel>>                            03110000
           dbsat    = 0).(0:4#;   <<satisfier source>>                  03115000
$page                                                                   03120000
<<----------------------------------------------------------->>         03125000
<<                                                           >>         03130000
<< procedure declarations                                    >>         03135000
<<                                                           >>         03140000
<<----------------------------------------------------------->>         03145000
                                                                        03150000
procedure suddendeath(e);                                               03155000
  value e; integer e;                                                   03160000
  option external;                                                      03165000
integer procedure entrylength;                                          03170000
  option external;                                                      03175000
integer procedure altdsegsize(dst,delta);                               03180000
  value dst,delta; integer dst,delta;                                   03185000
  option external;                                                      03190000
procedure adjrefcounts (amount);                                        03195000
   value amount;                                                        03200000
   integer amount;                                                      03205000
   option external;                                                     03210000
integer procedure alcstblock(num);                                      03215000
   value num;                                                           03220000
    integer num;                                                        03225000
   option external;                                                     03230000
procedure awake (pcbindex,oldwait,newwait);                             03235000
   value pcbindex,oldwait,newwait;                                      03240000
   integer pcbindex,oldwait,newwait;                                    03245000
   option external;                                                     03250000
procedure blankline;                                                    03255000
   option forward;                                                      03260000
procedure clearbitmap (bitmap);                                         03265000
   array bitmap;                                                        03270000
   option forward;                                                      03275000
procedure clearbuffer (buffer);                                         03280000
   array buffer;                                                        03285000
   option forward;                                                      03290000
procedure clearline;                                                    03295000
   option forward;                                                      03300000
procedure reldataseg(dst);                                              03305000
  value dst; integer dst;                                               03310000
  option external;                                                      03315000
procedure dealcstblock(ix);                                             03320000
   value ix;                                                            03325000
   integer ix;                                                          03330000
   option external;                                                     03335000
double procedure direcfind (t,linkage'indexp,acct,                      03340000
                            group,dum,buf);                             03345000
   value t,linkage'indexp;                                              03350000
   integer t;                                                           03355000
   double  linkage'indexp;                                              03360000
   array acct,group,dum,buf;                                            03365000
   option external;                                                     03370000
integer procedure dlsize (size);                                        03375000
   value size;                                                          03380000
   integer size;                                                        03385000
   option external;                                                     03390000
integer procedure exchangedb (dstnr);                                   03395000
   value dstnr; integer dstnr;                                          03400000
   option external;                                                     03405000
procedure extnparms;                                                    03410000
   option forward;                                                      03415000
procedure fcheck (filenum,errorcode,tlog,blknum,numrecs);               03420000
   value filenum;                                                       03425000
   integer filenum,errorcode,tlog,numrecs;                              03430000
   double blknum;                                                       03435000
   option variable,external;                                            03440000
procedure fclose (filenum,disposition,seccode);                         03445000
   value filenum,disposition,seccode;                                   03450000
   integer filenum,disposition,seccode;                                 03455000
   option external;                                                     03460000
intrinsic fcontrol;                                                     03465000
procedure ferror (fnum);                                                03470000
   value fnum;                                                          03475000
   integer fnum;                                                        03480000
   option forward;                                                      03485000
double procedure fgetdiskadr (fnum,recnum);                             03490000
   value fnum,recnum;                                                   03495000
   integer fnum;                                                        03500000
   double recnum;                                                       03505000
   option external;                                                     03510000
procedure fgetinfo (filenum,filename,foptions,aoptions,recsize,         03515000
      devtype,ldnum,hdaddr,filecode,recptr,eof,flimit,logcount,         03520000
      physcount,blksize,extsize,numextents,userlabel,creatorid,         03525000
      diskadr);                                                         03530000
   value filenum;                                                       03535000
   integer filenum,recsize,devtype,filecode,blksize,numextents,         03540000
      userlabel;                                                        03545000
   byte array filename,creatorid;                                       03550000
   logical foptions,aoptions,ldnum,hdaddr,extsize;                      03555000
   double recptr,eof,flimit,logcount,physcount,diskadr;                 03560000
   option variable,external;                                            03565000
procedure addtolocality(sllinx,segid,flags);                   <<06641>>03570000
   value sllinx,segid,flags;                                   <<06641>>03575000
   integer sllinx,flags;                                       <<06641>>03580000
   double segid;                                               <<06641>>03585000
   option external;                                            <<06641>>03590000
logical procedure setsysdb;                                             03595000
   option external;                                                     03600000
procedure resetdb(where);                                               03605000
   value where;                                                         03610000
   integer where;                                                       03615000
   option external;                                                     03620000
procedure flock (filenum,flag);                                         03625000
   value filenum,flag;                                                  03630000
   integer filenum;                                                     03635000
   logical flag;                                                        03640000
   option external;                                                     03645000
integer procedure fopen (filedesignator,foptions,aoptions,              03650000
      recsize,device,formmsg,recmode,blockfactor,numbuffers,            03655000
      filesize,numextents,initalloc,filecode);                          03660000
   value foptions,aoptions,recsize,recmode,blockfactor,                 03665000
      numbuffers,filesize,numextents,initalloc,filecode;                03670000
   byte array filedesignator,device,formmsg;                            03675000
   logical foptions,aoptions;                                           03680000
   integer recsize,recmode,blockfactor,numbuffers,numextents,           03685000
      initalloc,filecode;                                               03690000
   double filesize;                                                     03695000
   option variable,external;                                            03700000
integer procedure fopenda (ldnum,diskadr,aoptions,numbuf,      <<06094>>03705000
   filecode,dntype,disp,foptions,pvinfo,cominfo);              <<06094>>03710000
   value ldnum,diskadr,aoptions,numbuf,filecode,               <<06094>>03715000
         dntype,disp,foptions,pvinfo;                          <<06094>>03720000
   integer ldnum,aoptions,numbuf,filecode,dntype,disp,pvinfo,  <<06094>>03725000
           foptions;                                           <<06094>>03730000
   array cominfo;                                              <<06094>>03735000
   double diskadr;                                             <<06094>>03740000
   option variable,external;                                   <<06094>>03745000
procedure fcloseda (filenum,disp,seccode);                              03750000
    value   filenum,disp,seccode;                                       03755000
    integer filenum,disp,seccode;                                       03760000
    option external;                                                    03765000
procedure freaddir (filenum,target,tcount,recnum);                      03770000
   value filenum,tcount,recnum;                                         03775000
   integer filenum,tcount;                                              03780000
   array target;                                                        03785000
   double recnum;                                                       03790000
   option external;                                                     03795000
procedure funlock (filenum);                                            03800000
   value filenum;                                                       03805000
   integer filenum;                                                     03810000
   option external;                                                     03815000
procedure fwrite (filenum,target,tcount,control);                       03820000
   value filenum,tcount,control;                                        03825000
   integer filenum,tcount,control;                                      03830000
   array target;                                                        03835000
   option external;                                                     03840000
procedure fwritedir (filenum,target,tcount,recnum);                     03845000
   value filenum,tcount,recnum;                                         03850000
   integer filenum,tcount;                                              03855000
   array target;                                                        03860000
   double recnum;                                                       03865000
   option external;                                                     03870000
integer procedure getentry(list);                                       03875000
   value list;                                                          03880000
   integer list;                                                        03885000
   option external;                                                     03890000
procedure getreftabent (segnr);                                         03895000
   value segnr;                                                         03900000
   integer segnr;                                                       03905000
   option forward;                                                      03910000
logical procedure getsir (sir);                                         03915000
   value sir;                                                           03920000
   integer sir;                                                         03925000
   option external;                                                     03930000
integer procedure ldntoa( num, base, ba);                               03935000
   value num, base;                                                     03940000
   double num;                                                          03945000
   integer base;                                                        03950000
   byte array ba;                                                       03955000
   option forward;                                                      03960000
integer procedure lntoa( num, base, ba);                                03965000
   value num, base;                                                     03970000
   integer num, base;                                                   03975000
   byte array ba;                                                       03980000
   option forward;                                                      03985000
integer procedure mountvolset(filenum,some'other'pin);                  03990000
    value   filenum,some'other'pin;                                     03995000
    integer filenum,some'other'pin;                                     04000000
    option external,variable;                                           04005000
integer procedure dismountvolset (pvinfo,some'other'pin);               04010000
    value   pvinfo,some'other'pin;                                      04015000
    integer pvinfo,some'other'pin;                                      04020000
    option external,variable;                                           04025000
procedure getslnames (flag);                                            04030000
   value flag;                                                          04035000
   logical flag;                                                        04040000
   option forward;                                                      04045000
procedure help;                                                         04050000
   option external;                                                     04055000
procedure lcreate (length,type,pmode,library,key);                      04060000
   value length,type,pmode,library,key;                                 04065000
   integer length,type,pmode,library;                                   04070000
   double key;                                                          04075000
   option external;                                                     04080000
procedure ldelete;                                                      04085000
   option external;                                                     04090000
integer procedure getdataseg(memsize,vdsize);                           04095000
   value      memsize,vdsize;                                           04100000
   integer    memsize,vdsize;                                           04105000
   option     external;                                                 04110000
procedure initloadcache;                                                04115000
   option external;                                                     04120000
integer procedure linelength;                                           04125000
   option forward;                                                      04130000
procedure loadbit (key,bit,dstnr);                                      04135000
   value key,bit,dstnr;                                                 04140000
   double key;                                                          04145000
   logical bit;                                                         04150000
   integer dstnr;                                                       04155000
   option external;                                                     04160000
procedure loadexternals;                                                04165000
   option forward;                                                      04170000
procedure loadprogram;                                                  04175000
   option forward;                                                      04180000
procedure loadsegment(fnum,segnr,segtype,seglen,segrecd,                04185000
         segptr,capability,privmode);                                   04190000
  value fnum,segnr,segtype,seglen,segrecd,                              04195000
         capability,privmode,segptr;                                    04200000
  integer fnum,segnr,segtype,seglen,segrecd;                            04205000
  logical capability,privmode;                                          04210000
  integer pointer segptr;                                               04215000
  option forward;                                                       04220000
logical procedure lsearch (key,pmode,type);                             04225000
   value key,pmode,type;                                                04230000
   double key;                                                          04235000
   integer pmode,type;                                                  04240000
   option external;                                                     04245000
logical procedure lsearch'(key,pmode,type);                    <<06541>>04250000
   value key,pmode,type;                                       <<06541>>04255000
   double key;                                                 <<06541>>04260000
   integer pmode,type;                                         <<06541>>04265000
   option external;                                            <<06541>>04270000
procedure makeroomindl (nrwords);                                       04275000
   value nrwords; integer nrwords;                                      04280000
   option forward;                                                      04285000
procedure ntoa (num,base,buf);                                          04290000
   value num,base;                                                      04295000
   integer num,base;                                                    04300000
   byte array buf;                                                      04305000
   option forward;                                                      04310000
procedure parmcheck (formalp,actualp,parms);                            04315000
   integer array formalp,actualp,parms;                                 04320000
   option forward;                                                      04325000
integer procedure parmlen (parms);                                      04330000
   integer array parms;                                                 04335000
   option forward;                                                      04340000
procedure printline;                                                    04345000
   option forward;                                                      04350000
procedure printline';                                                   04355000
   option forward;                                                      04360000
procedure putcst(en,mask,dev,diskadr,sysflag);                          04365000
   value en,mask,dev,diskadr;                                           04370000
   integer en,mask,dev;                                                 04375000
   logical sysflag;                                                     04380000
   double diskadr;                                                      04385000
   option external;                                                     04390000
procedure putcstblock(eix,lsegnum,mask,dev,diskadr,sysflag);            04395000
   value eix,lsegnum,mask,dev,diskadr;                                  04400000
   integer eix,lsegnum,mask,dev;                                        04405000
   logical sysflag;                                                     04410000
   double diskadr;                                                      04415000
   option external;                                                     04420000
procedure relsir (sir,flag);                                            04425000
   value sir,flag;                                                      04430000
   integer sir,flag;                                                    04435000
   option external;                                                     04440000
procedure returnentry (type,entrynr);                                   04445000
   value type,entrynr;                                                  04450000
   integer type,entrynr;                                                04455000
   option external;                                                     04460000
logical procedure samename (name1,name2);                               04465000
   integer array name1,name2;                                           04470000
   option forward;                                                      04475000
procedure satisfyproc;                                                  04480000
   option forward;                                                      04485000
procedure satisfyprog;                                                  04490000
   option forward;                                                      04495000
procedure satisfy;                                                      04500000
   option forward;                                                      04505000
procedure savereftabbuf;                                                04510000
   option forward;                                                      04515000
procedure setbit (bitarray,bitnumber);                                  04520000
   value bitnumber;                                                     04525000
   integer array bitarray;                                              04530000
   integer bitnumber;                                                   04535000
   option forward;                                                      04540000
logical procedure testbit (bitarray,bitnumber);                         04545000
   value bitnumber;                                                     04550000
   integer array bitarray;                                              04555000
   integer bitnumber;                                                   04560000
   option forward;                                                      04565000
procedure unimpede(p);                                                  04570000
   value p;                                                             04575000
   integer p;                                                           04580000
   option external;                                                     04585000
procedure updatesegtab;                                                 04590000
   option forward;                                                      04595000
procedure validcap (flag);                                              04600000
   value flag;                                                          04605000
   logical flag;                                                        04610000
   option forward;                                                      04615000
procedure linklstentry;                                                 04620000
  option external;                                                      04625000
procedure unlinklstentry;                                               04630000
  option external;                                                      04635000
procedure buildgarbage(position,length);                                04640000
  value position,length;                                                04645000
  integer position,length;                                              04650000
  option external;                                                      04655000
integer procedure get'phy'cst;                                 <<06281>>04660000
   option external;                                            <<06281>>04665000
integer procedure getdatasegc(msize,vsize);                    <<06541>>04670000
   value msize,vsize;                                          <<06541>>04675000
   integer msize,vsize;                                        <<06541>>04680000
   option external;                                            <<06541>>04685000
procedure trans'lst'to'xdst;                                   <<06541>>04690000
   option external;                                            <<06541>>04695000
procedure adjustlocality(procinx,objid,reqsize,flags);         <<07300>>04700000
   value procinx,objid,reqsize,flags;                          <<07300>>04705000
   logical procinx,reqsize,flags;                              <<07300>>04710000
   double objid;                                               <<07300>>04715000
   option external;                                            <<07300>>04720000
intrinsic fsetmode;                                            <<07301>>04725000
procedure sendmsg(descpin,subq,msglength,flags);               <<*7545>>04730000
   value descpin,subq,msglength,flags;                         <<*7545>>04735000
   integer descpin,subq,msglength;                             <<*7545>>04740000
   logical flags;                                              <<*7545>>04745000
   option external;                                            <<*7545>>04750000
procedure receivemsg(subq,msglength,flags);                    <<*7545>>04755000
   value subq,msglength,flags;                                 <<*7545>>04760000
   integer subq,msglength;                                     <<*7545>>04765000
   logical flags;                                              <<*7545>>04770000
   option external;                                            <<*7545>>04775000
$page                                                                   04780000
<<----------------------------------------------------------->>         04785000
<<                                                           >>         04790000
<< utility procedures                                        >>         04795000
<<                                                           >>         04800000
<<----------------------------------------------------------->>         04805000
                                                                        04810000
logical procedure testbit (bitarray,bitnumber);                         04815000
  <<tests bit number bitnumber in the bit array bitarray>>              04820000
  value bitnumber;                                                      04825000
  integer array bitarray;                                               04830000
  integer bitnumber;                                                    04835000
  option uncallable;                                                    04840000
  begin                                                                 04845000
    tos := bitnumber.(0:12)+@bitarray;                                  04850000
    tos := ps0;                                                         04855000
    xreg := bitnumber.(12:4);                                           04860000
    assemble(csl 1,x);                                                  04865000
    testbit := tos                                                      04870000
  end;                                                                  04875000
$page                                                                   04880000
procedure setbit (bitarray,bitnumber);                                  04885000
  <<sets bit number bitnumber in the bit array bitarray>>               04890000
  value bitnumber;                                                      04895000
  integer array bitarray;                                               04900000
  integer bitnumber;                                                    04905000
  option uncallable;                                                    04910000
  begin                                                                 04915000
    tos := bitnumber.(0:12)+@bitarray;                                  04920000
    tos := ps0;                                                         04925000
    xreg := bitnumber;                                                  04930000
    assemble(tsbc 0,x);                                                 04935000
    ps1 := tos                                                          04940000
  end;                                                                  04945000
$page                                                                   04950000
integer procedure nextbit(bitarray);                                    04955000
  <<return next available index from bitarray>>                         04960000
  <<if none available return 0             >>                           04965000
  integer array bitarray;                                               04970000
  begin                                                                 04975000
    integer index:=0;                                                   04980000
    <<search for available index>>                                      04985000
    while (index:=index+1) <= 255 do                                    04990000
      begin                                                             04995000
        if not testbit(bitarray,index) then                             05000000
          begin            <<found available index>>                    05005000
            <<reserve index>>                                           05010000
            setbit(bitarray,index);                                     05015000
            nextbit:=index;                                             05020000
            return;                                                     05025000
          end;                                                          05030000
      end; <<while>>                                                    05035000
    <<no available index>>                                              05040000
    nextbit:=0;                                                         05045000
  end;                                                                  05050000
$page                                                                   05055000
procedure clearbitmap (bitmap);                                         05060000
  <<clears a 16 word bit map>>                                          05065000
  array bitmap;                                                         05070000
  option uncallable;                                                    05075000
  begin                                                                 05080000
    tos := @bitmap; ps0 := 0;                                           05085000
    assemble(dup,incb); tos := 15; assemble(move 3)                     05090000
  end;                                                                  05095000
$page                                                                   05100000
procedure clearbuffer (buffer);                                         05105000
  <<clears a 128 word buffer>>                                          05110000
  array buffer;                                                         05115000
  option uncallable;                                                    05120000
  begin                                                                 05125000
    tos := @buffer; ps0 := 0;                                           05130000
    assemble(dup,incb); tos := 127; assemble(move 3)                    05135000
  end;                                                                  05140000
$page                                                                   05145000
integer procedure findsegentry(slnr,segnr);                             05150000
  value slnr,segnr;                                                     05155000
  integer slnr,segnr;                                                   05160000
  <<find seg entry in satisfied data base>>                             05165000
  <<found- return pointer to entry   >>                                 05170000
  <<     - condition code=cce        >>                                 05175000
  <<not found - return 0             >>                                 05180000
  <<          - condition code=ccl   >>                                 05185000
  <<slnr--sl chain to use>>                                             05190000
  <<segnr--log seg # for search>>                                       05195000
  begin                                                                 05200000
    integer pointer segptr;                                             05205000
    integer index;                                                      05210000
    index:=slnr&lsl(4)+segnr&lsr(4); <<directory index>>                05215000
    @segptr:=sldb'seg'dir(index);    <<ptr for search start>>           05220000
    <<search for entry>>                                                05225000
    while @segptr <> 0 and                                              05230000
          segptr(dblogseg) <> segnr do                                  05235000
      begin                 <<wrong entry-go next>>                     05240000
        if segptr(dblogseg) < segnr                                     05245000
          then @segptr:=segptr(segnext) <<keep up search>>              05250000
          else @segptr:=0;           <<stop search>>                    05255000
      end; <<while>>                                                    05260000
    <<return info >>                                                    05265000
    findsegentry:=@segptr;           <<return ptr>>                     05270000
    if @segptr <> 0                                                     05275000
      then condcode:=cce             <<found code>>                     05280000
      else condcode:=ccl;            <<not found code>>                 05285000
    return;                                                             05290000
  end;                                                                  05295000
$page                                                                   05300000
integer procedure findsttentry(segptr,sttnr,sttptr);                    05305000
  value sttnr,segptr,sttptr;                                            05310000
  integer sttnr;                                                        05315000
  integer pointer segptr,sttptr;                                        05320000
  <<find stt entry in satisfied data base>>                             05325000
  <<entry found - return pointer to entry>>                             05330000
  <<            - condition code=cce     >>                             05335000
  <<entry not found - return 0           >>                             05340000
  <<                - condition code=ccl >>                             05345000
  <<segptr--ptr to head seg entry        >>                             05350000
  <<sttnr --stt # for search             >>                             05355000
  <<sttptr--starting ptr in search       >>                             05360000
  <<         =0 - start at head          >>                             05365000
  <<        <>0 - start at sttptr        >>                             05370000
  begin                                                                 05375000
    if @sttptr = 0 then                                                 05380000
      begin                 <<start search at head>>                    05385000
        @sttptr:=segptr(sttnext);                                       05390000
      end;                                                              05395000
    <<search for entry>>                                                05400000
    while @sttptr <> 0 and                                              05405000
          sttptr(dbstt) <> sttnr do                                     05410000
      begin                 <<wrong entry-go next>>                     05415000
        if sttptr(dbstt) < sttnr                                        05420000
          then @sttptr:=sttptr(sttnext) <<keep up search>>              05425000
          else @sttptr:=0;           <<stop search>>                    05430000
      end; <<while>>                                                    05435000
    <<return info >>                                                    05440000
    findsttentry:=@sttptr;           <<return ptr>>                     05445000
    if @sttptr <> 0                                                     05450000
      then condcode:=cce             <<found code>>                     05455000
      else condcode:=ccl;            <<not found code>>                 05460000
    return;                                                             05465000
  end;                                                                  05470000
$page                                                                   05475000
integer procedure bldsegentry(slnr,segnr);                              05480000
  value slnr,segnr;                                                     05485000
  integer slnr,segnr;                                                   05490000
  <<build seg entry for satisfied data base>>                           05495000
  <<entry built - return pointer to entry>>                             05500000
  <<            - condition code=cce     >>                             05505000
  <<entry not built - return 0           >>                             05510000
  <<                - condition code=ccl >>                             05515000
  <<slnr--sl chain to use>>                                             05520000
  <<segnr--log seg nr for entry>>                                       05525000
  begin                                                                 05530000
    integer pointer oldsegptr,currsegptr,newsegptr;                     05535000
    integer index,index2;                                               05540000
    <<check if entry already exists>>                                   05545000
    bldsegentry:=findsegentry(slnr,segnr);                              05550000
    if = then                                                           05555000
      begin                <<entry already exists>>                     05560000
        condcode:=cce;     <<ok code             >>                     05565000
        return;                                                         05570000
      end;                                                              05575000
    <<allocate space for entry>>                                        05580000
    makeroomindl(5);                                                    05585000
    if < then                                                           05590000
      begin                <<no room>>                                  05595000
        bldsegentry:=0;    <<return 0>>                                 05600000
        condcode:=ccl;     <<error code>>                               05605000
        return;                                                         05610000
      end;                                                              05615000
    tos:=@dlarea1-5;                                                    05620000
    @newsegptr:=s0;        <<new entry ptr>>                            05625000
    @dlarea1:=tos;                                                      05630000
    <<find position for entry>>                                         05635000
    index:=slnr&lsl(4)+segnr&lsr(4); <<directory index>>                05640000
    <<check if new entry can be linked in front of list>>               05645000
    @currsegptr:=sldatabase(slnr);                                      05650000
    if @currsegptr = 0 or                                               05655000
       currsegptr(dblogseg) > segnr then                                05660000
      begin                                                             05665000
        <<list is empty or               >>                             05670000
        <<first entry has logseg > segnr >>                             05675000
        <<link new entry first           >>                             05680000
        sldatabase(slnr):=@newsegptr;                                   05685000
        go finishlink;                                                  05690000
      end;                                                              05695000
    <<new entry must be linked after first entry>>                      05700000
    <<find starting point for search of proper slot for>>               05705000
    <<the new entry.  starting point is such that the  >>               05710000
    <<new segnr is > segnr of starting entry           >>               05715000
    index2:=index;                                                      05720000
    @currsegptr:=sldb'seg'dir(index2);                                  05725000
    while @currsegptr = 0 or                                            05730000
          currsegptr(dblogseg) > segnr do                               05735000
      begin                                                             05740000
        index2:=index2-1;                                               05745000
        @currsegptr:=sldb'seg'dir(index2);                              05750000
      end;                                                              05755000
    <<found starting point--now find proper slot>>                      05760000
    while @currsegptr <> 0 and                                          05765000
          currsegptr(dblogseg) < segnr do                               05770000
      begin                                                             05775000
        @oldsegptr:=@currsegptr;                                        05780000
        @currsegptr:=currsegptr(segnext);                               05785000
      end;                                                              05790000
    <<found slot>>                                                      05795000
    oldsegptr(segnext):=@newsegptr;                                     05800000
finishlink:                                                             05805000
    <<update directory ptrs (sldb'seg'dir)>>                            05810000
    @oldsegptr:=sldb'seg'dir(index); <<current ptr>>                    05815000
    if @oldsegptr = 0 or             <<no ptr or      >>                05820000
       oldsegptr(dblogseg) > segnr   <<old logseg > new>>               05825000
      then sldb'seg'dir(index):=@newsegptr;                             05830000
    <<initialize entry>>                                                05835000
    newsegptr(0):=0;                                                    05840000
    move newsegptr(1):=newsegptr(0),(4);                                05845000
    newsegptr(segnext):=@currsegptr;                                    05850000
    newsegptr(dblogseg):=segnr;                                         05855000
    <<return info>>                                                     05860000
    bldsegentry:=@newsegptr;                                            05865000
    condcode:=cce;                                                      05870000
  end;                                                                  05875000
$page                                                                   05880000
integer procedure bldsttentry(segptr,sttnr);                            05885000
  value sttnr,segptr;                                                   05890000
  integer sttnr;                                                        05895000
  integer pointer segptr;                                               05900000
  <<build new stt entry in satisfied data base>>                        05905000
  <<entry built - return ptr to entry >>                                05910000
  <<            - condition code=cce  >>                                05915000
  <<entry not built - return 0        >>                                05920000
  <<                - condition code=ccl>>                              05925000
  <<segptr - pointer to seg entry     >>                                05930000
  <<sttnr  - stt # for new entry      >>                                05935000
  begin                                                                 05940000
    integer pointer oldsttptr,currsttptr,newsttptr;                     05945000
    <<check if entry already exists>>                                   05950000
    @currsttptr:=0;        <<start search at head>>                     05955000
    bldsttentry:=findsttentry(segptr,sttnr,currsttptr);                 05960000
    if = then                                                           05965000
      begin                <<entry already exists>>                     05970000
        condcode:=cce;     <<ok code             >>                     05975000
        return;                                                         05980000
      end;                                                              05985000
    <<allocate space for entry>>                                        05990000
    makeroomindl(3);                                                    05995000
    if < then                                                           06000000
      begin                <<no room>>                                  06005000
        bldsttentry:=0;    <<return 0>>                                 06010000
        condcode:=ccl;     <<error code>>                               06015000
        return;                                                         06020000
      end;                                                              06025000
    tos:=@dlarea1-3;                                                    06030000
    @newsttptr:=s0;        <<new entry ptr>>                            06035000
    @dlarea1:=tos;                                                      06040000
    <<find position for entry>>                                         06045000
    @oldsttptr:=0;                                                      06050000
    @currsttptr:=segptr(sttnext);                                       06055000
    while @currsttptr <> 0 and                                          06060000
          currsttptr(dbstt) < sttnr do                                  06065000
      begin                                                             06070000
        @oldsttptr:=@currsttptr;                                        06075000
        @currsttptr:=currsttptr(sttnext);                               06080000
      end; <<while>>                                                    06085000
    <<found spot--link in new entry>>                                   06090000
    if @oldsttptr = 0 then                                              06095000
      begin                <<link to head>>                             06100000
        segptr(sttnext):=@newsttptr;                                    06105000
      end else                                                          06110000
      begin                <<link other than head>>                     06115000
        oldsttptr(sttnext):=@newsttptr;                                 06120000
      end;                                                              06125000
    <<initialize entry>>                                                06130000
    newsttptr(0):=0;                                                    06135000
    move newsttptr(1):=newsttptr(0),(2);                                06140000
    newsttptr(sttnext):=@currsttptr;                                    06145000
    newsttptr(dbstt):=sttnr;                                            06150000
    <<return info>>                                                     06155000
    bldsttentry:=@newsttptr;                                            06160000
    condcode:=cce;                                                      06165000
  end;                                                                  06170000
logical procedure samename (name1,name2);                               06175000
$page                                                                   06180000
  <<compares two names (the first byte being the # of char>>            06185000
  <<and returns true if they are the same; otherwise false>>            06190000
  integer array name1,name2;                                            06195000
  option uncallable;                                                    06200000
  begin                                                                 06205000
    integer result = samename;                                          06210000
    tos := @name1&lsl(1);                                               06215000
    tos := @name2&lsl(1);                                               06220000
    assemble(inca,incb);                                                06225000
    tos := name1.(4:4);                                                 06230000
    if name2.(4:4) = s0 and * = *,(tos) then result:=result+1;          06235000
  end;                                                                  06240000
$page                                                                   06245000
procedure ferror (fnum);                                                06250000
  <<determines the error numb for the eof or i/o error just>>           06255000
  <<detected>>                                                          06260000
  value fnum;                                                           06265000
  integer fnum;                                                         06270000
  option uncallable;                                                    06275000
  begin                                                                 06280000
    integer temp;                                                       06285000
    temp:=mlibsearch+1;                                                 06290000
    while (temp:=temp-1) >= 0 do                                        06295000
      begin  <<find sl # for this fnum>>                                06300000
        if slfnum(temp) = fnum then go reporterr;                       06305000
      end; <<while>>                                                    06310000
    if fnum = progfnum and progfnum <> 0 then                  <<07301>>06315000
      begin                                                    <<07301>>06320000
         temp:=3;                                              <<07301>>06325000
         go to reporterr;                                      <<07301>>06330000
      end;                                                     <<07301>>06335000
    <<match not found - use sys sl>>                                    06340000
    temp:=0;                                                            06345000
reporterr:                                                              06350000
    merror:=err60+temp;                                                 06355000
    fcheck(fnum,mferror);                                               06360000
  end;                                                                  06365000
$page                                                                   06370000
procedure printbitmap( map);                                            06375000
  array map;                                                            06380000
  option uncallable;                                                    06385000
  begin                                                                 06390000
    integer col, i;                                                     06395000
    logical firstparm := true;                                          06400000
    col := (-linelength)+1;                                             06405000
    for *i := 0 until %77 do                                            06410000
       begin                                                            06415000
         if col > 66 then                                               06420000
            begin                                                       06425000
              printline';                                               06430000
              if <> then go abort;                                      06435000
              col := 0;                                                 06440000
            end;                                                        06445000
         if testbit( map, i) then                                       06450000
            begin                                                       06455000
              if col <> 0 and not firstparm then                        06460000
                 begin                                                  06465000
                   bline(col) := ",";                                   06470000
                   col:=col+1;                                          06475000
                 end;                                                   06480000
              firstparm := false;                                       06485000
              col := col+lntoa(i+1,10,bline(col));                      06490000
            end;                                                        06495000
       end;                                                             06500000
    if col <> 0 then                                                    06505000
       begin                                                            06510000
         printline';                                                    06515000
         if <> then go abort;                                           06520000
       end;                                                             06525000
    clearline;                                                          06530000
                                                                        06535000
    condcode := cce;                                                    06540000
    return;                                                             06545000
                                                                        06550000
abort:                                                                  06555000
    condcode := ccl;                                                    06560000
  end;                                                                  06565000
$page                                                                   06570000
procedure clearline;                                                    06575000
  <<clears the list buffer>>                                            06580000
  option uncallable;                                                    06585000
  begin                                                                 06590000
    tos := @line; ps0 := "  ";                                          06595000
    assemble(dup,incb); tos := 35; assemble(move 3)                     06600000
  end;                                                                  06605000
$page                                                                   06610000
integer procedure linelength;                                           06615000
  <<returns the negative # of char in the list buffer>>                 06620000
  option uncallable;                                                    06625000
  begin                                                                 06630000
    tos := @bline(71);  <<pointer to last char.>>                       06635000
    if bps0 = " " then                                                  06640000
       begin                                                            06645000
         assemble(dup,decb);                                            06650000
         tos := -71;                                                    06655000
         assemble(cmpb 2)                                               06660000
       end;                                                             06665000
    linelength := -(tos-@bline+1);  <<neg. nr. char's>>                 06670000
  end;                                                                  06675000
$page                                                                   06680000
procedure printline;                                                    06685000
  <<prints the contents of the list buff on the list file>>             06690000
  <<note that this procedure uses the condition code     >>             06695000
  <<to indicate an error>>                                              06700000
  option uncallable;                                                    06705000
  begin                                                                 06710000
    entry blankline,printline';                                         06715000
                                                                        06720000
    blankline:                                                          06725000
    if mlmap then  <<listing wanted?>>                                  06730000
       begin                                                            06735000
         printline':                                                    06740000
         fwrite(listfnum,line,linelength,0);                            06745000
         if <> then  <<error?>>                                         06750000
            begin                                                       06755000
              tos := err64; go abort                                    06760000
            end;                                                        06765000
         listflag := true;                                              06770000
       end;                                                             06775000
    tos := cce;  <<ok condition code>>                                  06780000
    go getout;                                                          06785000
                                                                        06790000
abort:                                                                  06795000
    merror := tos;  <<error nr.>>                                       06800000
    tos := ccl;  <<error condition code>>                               06805000
                                                                        06810000
getout:                                                                 06815000
    clearline;                                                          06820000
    condcode := tos  <<store condition code>>                           06825000
  end;                                                                  06830000
$page                                                                   06835000
procedure ntoa (num,base,buf);                                          06840000
  <<converts the number into an ascii string that is >>                 06845000
  <<right justified in the specified buffer>>                           06850000
  value num,base;                                                       06855000
  integer num,base;                                                     06860000
  byte array buf;                                                       06865000
  option uncallable;                                                    06870000
  begin                                                                 06875000
    buf(0) := "0";                                                      06880000
    while num <> 0 do                                                   06885000
       begin                                                            06890000
         tos := 0; tos := num; tos := base;                             06895000
         assemble(ldiv);                                                06900000
         buf(xreg) := tos+%60;                                          06905000
         num := tos;                                                    06910000
         xreg := xreg-1                                                 06915000
       end                                                              06920000
  end;                                                                  06925000
$page                                                                   06930000
   integer procedure ldntoa(num, base, ba);                             06935000
     value num, base;                                                   06940000
     double num;                                                        06945000
     integer base;                                                      06950000
     byte array ba;                                                     06955000
     option uncallable;                                                 06960000
     begin                                                              06965000
       byte array buf(0:11)=q;                                          06970000
       xreg := 12;                                                      06975000
       do begin                                                         06980000
            assemble(zero; load num; load base; ldiv;                   06985000
                     ldd num; delb; load base; ldiv;                    06990000
                     addi %60);                                         06995000
            buf(xreg:=xreg-1) := tos;                                   07000000
            num := tos;                                                 07005000
          end until num=0d;                                             07010000
       move ba := buf(xreg),(ldntoa:=12-xreg);                          07015000
     end;                                                               07020000
$page                                                                   07025000
   integer procedure lntoa( num, base, ba);                             07030000
     value num, base;                                                   07035000
     integer num, base;                                                 07040000
     byte array ba;                                                     07045000
     option uncallable;                                                 07050000
     begin                                                              07055000
       lntoa := ldntoa(double(logical(num)),base,ba);                   07060000
     end;                                                               07065000
$page                                                                   07070000
procedure makeroomindl (nrwords);                                       07075000
  <<checks the available dl to see if there is room for>>               07080000
  <<the specified number of words.  if not, the dl area>>               07085000
  <<is expanded by the necessary amount.  note that this>>              07090000
  <<procedure uses condition code to indicate an error>>                07095000
  value nrwords;                                                        07100000
  integer nrwords;                                                      07105000
  option uncallable;                                                    07110000
  begin                                                                 07115000
    integer nwavail;                                                    07120000
    nwavail:=@dlarea1-@dlavail; <<# words available>>                   07125000
    if nrwords > nwavail then  <<not enough room?>>                     07130000
       begin                                                            07135000
                                                                        07140000
         <<* * * expand dl area * * *>>                                 07145000
                                                                        07150000
         tos := 0;  <<for result of dlsize>>                            07155000
         tos := @dlarea2;                                               07160000
         tos := dlincrement;  <<init. increment>>                       07165000
         while nrwords > s0+nwavail do tos := tos+dlincrement;          07170000
         tos := tos-tos;  <<new dl limit>>                              07175000
         tos := dlsize(*);  <<expand dl area>>                          07180000
                                                                        07185000
         <<* * * move tables and fix pointers in area 2 * * *>>         07190000
                                                                        07195000
         move ps0 := dlarea2,(@dlavail-@dlarea2);  <<move tables>>      07200000
         tos := tos-@dlarea2;  <<pointer fix term>>                     07205000
         @saveuxp := @saveuxp+s0;                                       07210000
         @uxp := @uxp+s0;                                               07215000
         @uxp1 := @uxp1+s0;                                             07220000
         @uxp2 := @uxp2+s0;                                             07225000
         @dlarea2 := @dlarea2+s0;                                       07230000
         @dlavail := tos+@dlavail;                                      07235000
         if nrwords > @dlarea1-@dlavail then <<room now?>>              07240000
           begin                             <<no>>                     07245000
             tos:=err71; go abort;                                      07250000
           end;                                                         07255000
       end;                                                             07260000
    condcode:=cce;              <<ok code>>                             07265000
    return;                                                             07270000
                                                                        07275000
abort:                                                                  07280000
    merror:=tos;                <<error #>>                             07285000
    condcode:=ccl;              <<error code>>                          07290000
    return;                                                             07295000
  end;                                                                  07300000
$page                                                                   07305000
integer procedure parmlen (parms);                                      07310000
  <<returns the #of words in the parameter info block>>                 07315000
  integer array parms;                                                  07320000
  option uncallable;                                                    07325000
  begin                                                                 07330000
    integer p = q+1;                                                    07335000
    tos := parms.(0:2);  <<level of checking>>                          07340000
    parmlen:=if = then 1                                                07345000
                  else if p = 3 then parms.(2:6)+2                      07350000
                                else 2;                                 07355000
  end;                                                                  07360000
$page                                                                   07365000
procedure parmcheck (formalp,actualp,parms);                            07370000
  <<checks for compatability between the actual parameter>>             07375000
  <<info block and the formal parameter info block>>                    07380000
  integer array formalp,actualp,parms;                                  07385000
  option uncallable;                                                    07390000
  begin                                                                 07395000
    integer p = q+1;  <<level of checking>>                             07400000
    integer pointer parmmap = q+2; <<bad parms bit map>>                07405000
                                                                        07410000
    <<* * * level 0 - no checking * * *>>                               07415000
                                                                        07420000
    parms := 0;                                                         07425000
    move parms(1) := parms,(4);                                         07430000
    tos := formalp.(0:2); tos := actualp.(0:2);                         07435000
    assemble(ddup,cmp);                                                 07440000
    if > then assemble(xch);                                            07445000
    assemble(del,test);                                                 07450000
    if = then go match;                                                 07455000
    tos := @parms(1);  <<initialize parmmap>>                           07460000
                                                                        07465000
    <<* * * level 1 - procedure type * * *>>                            07470000
                                                                        07475000
    tos := formalp(1);                                                  07480000
    if = then go l1;                                                    07485000
    tos := actualp(xreg);                                               07490000
    if = then go l1;                                                    07495000
    if tos <> tos or                                                    07500000
       formalp.(8:8) <> actualp.(8:8) then                              07505000
       begin                                                            07510000
         parms := 1;                                                    07515000
         return;                                                        07520000
       end;                                                             07525000
l1:     if p = 1 then go match;                                         07530000
                                                                        07535000
    <<* * * level 2 - number of parameters * * *>>                      07540000
                                                                        07545000
    tos := formalp.(2:6);                                               07550000
    tos := actualp.(2:6);                                               07555000
    assemble(ddup,cmp);                                                 07560000
    if <> then                                                          07565000
       begin                                                            07570000
         parms := 2;                                                    07575000
         return;                                                        07580000
       end;                                                             07585000
    if p = 2 then go match;                                             07590000
                                                                        07595000
    <<* * * level 3 - parameter types * * *>>                           07600000
                                                                        07605000
    assemble(del,test);                                                 07610000
    if = then go match;  <<check for no parm's>>                        07615000
again:                                                                  07620000
    xreg := xreg+1;                                                     07625000
    tos := formalp(xreg);                                               07630000
    if = then go del1;                                                  07635000
    tos := actualp(xreg);                                               07640000
    if = then go del2;                                                  07645000
                                                                        07650000
    <<check mode>>                                                      07655000
                                                                        07660000
    tos := formalp(xreg).(0:4);                                         07665000
    tos := actualp(xreg).(0:4);                                         07670000
    assemble(ddup,cmp);                                                 07675000
    if <> then                                                          07680000
       if s0 <> 4 and s1 <> 4 then                                      07685000
          begin                                                         07690000
            parms := 3;                                                 07695000
            setbit( parmmap, xreg-2);                                   07700000
          end;                                                          07705000
                                                                        07710000
    <<check structure>>                                                 07715000
                                                                        07720000
    tos := formalp(xreg).(4:6);                                         07725000
    tos := actualp(xreg).(4:6);                                         07730000
    assemble(ddup,cmp);                                                 07735000
    if <> then                                                          07740000
       if s1 <> 0 or s0 <> 1 and s0 <> 2 then                           07745000
          begin                                                         07750000
            parms := 3;                                                 07755000
            setbit( parmmap, xreg-2);                                   07760000
          end;                                                          07765000
                                                                        07770000
    <<check type>>                                                      07775000
                                                                        07780000
    tos := formalp(xreg).(10:6);                                        07785000
    tos := actualp(xreg).(10:6);                                        07790000
    assemble(ddup,cmp);                                                 07795000
    if <> then                                                          07800000
       if s0 <> 11 and s1 <> 11 then                                    07805000
          begin                                                         07810000
            parms := 3;                                                 07815000
            setbit( parmmap, xreg-2);                                   07820000
          end;                                                          07825000
                                                                        07830000
    assemble(subs 6);                                                   07835000
del2:     del;                                                          07840000
del1 :     del;                                                         07845000
    assemble(dabz match);                                               07850000
    go again;                                                           07855000
                                                                        07860000
match:                                                                  07865000
  end;                                                                  07870000
$page                                                                   07875000
logical procedure scancache (name,bucket);                              07880000
  <<scan bucket in load cache for sl directory entry>>                  07885000
  <<for segment name.  if successful, move entry to >>                  07890000
  <<front of bucket and return true, else false.    >>                  07895000
  value bucket;                                                         07900000
  integer bucket;        <<hash bucket number>>                         07905000
  integer array name;    <<segment name>>                               07910000
  option privileged,uncallable,internal;                                07915000
  begin                                                                 07920000
    integer bucketp,length;                                             07925000
    logical array workarea(0:bucketsize-1)=q;                           07930000
    if slnr=0 and loadcacheseg<>0 then                                  07935000
      begin  <<system sl and a cache exists>>                           07940000
                                                                        07945000
        <<move cache bucket to stack>>                                  07950000
                                                                        07955000
        tos:=@wbucket;                   <<target>>                     07960000
        tos:=loadcacheseg;               <<source segment>>             07965000
        tos:=bucket*bucketsize+bucket0;  <<source>>                     07970000
        tos:=bucketsize;                 <<length>>                     07975000
        assemble(mfds 4);                <<move>>                       07980000
                                                                        07985000
        <<scan for entry in bucket>>                                    07990000
                                                                        07995000
        bucketp:=0;                                                     08000000
        while bucketp+(length:=wbucket(bucketp))<=bucketsize            08005000
                        and bucketp<bucketsize                          08010000
          do if samename(name,wbucket(bucketp+1))                       08015000
            then                                                        08020000
              begin   <<entry is in cache bucket>>                      08025000
                if bucketp<>0 then  <<not at front of bucket>>          08030000
                  begin    <<must move to front>>                       08035000
                    move workarea:=wbucket(bucketp),(length);           08040000
                    move wbucket(bucketp+length-1):=                    08045000
                         wbucket(bucketp-1),(-bucketp);                 08050000
                    move wbucket:=workarea,(length);                    08055000
                                                                        08060000
                    <<move to cache>>                                   08065000
                                                                        08070000
                    tos:=loadcacheseg;      <<target segment>>          08075000
                    tos:=bucket*bucketsize+bucket0;  <<target>>         08080000
                    tos:=@wbucket;             <<source>>               08085000
                    tos:=bucketsize;           <<length>>               08090000
                    assemble(mtds 4);          <<move>>                 08095000
                  end;                                                  08100000
                                                                        08105000
                <<set up pointers>>                                     08110000
                                                                        08115000
                @slp:=@wbucket+1;                                       08120000
                @slp1:=@slp+slp.(4:3)+1;                                08125000
                scancache:=true;                                        08130000
                return;                                                 08135000
              end                                                       08140000
            else bucketp:=bucketp+length;                               08145000
      end;                                                              08150000
  end;                                                                  08155000
$page                                                                   08160000
procedure addtocache (direntry,length,bucket);                          08165000
  <<adds directory entry of given length to cache bucket>>              08170000
  value length,bucket;                                                  08175000
  integer pointer direntry;   <<directory direntry pointer>>            08180000
  integer length;          <<length of directory entry>>                08185000
  integer bucket;          <<hash bucket>>                              08190000
  option privileged,uncallable,internal;                                08195000
  begin                                                                 08200000
    integer bucketstart,bucketend,length1;                              08205000
    if loadcacheseg<>0 and length<bucketsize then                       08210000
      begin  <<cache exists and entry fits in bucket>>                  08215000
                                                                        08220000
        <<make room for entry at front of bucket>>                      08225000
                                                                        08230000
        length1:=length+1;                                              08235000
        bucketstart:=bucket*bucketsize+bucket0;                         08240000
        bucketend:=bucketstart+bucketsize-1;                            08245000
        tos:=loadcacheseg;           <<target segment>>                 08250000
        tos:=bucketend;              <<target>>                         08255000
        tos:=loadcacheseg;           <<source segment>>                 08260000
        tos:=bucketend-length1;      <<source>>                         08265000
        tos:=length1-bucketsize;     <<length>>                         08270000
        assemble(mds 4);        <<move - save target segment>>          08275000
                                                                        08280000
        <<move in new entry>>                                           08285000
                                                                        08290000
        tos:=bucketstart;      <<target>>                               08295000
        tos:=@length1;         <<source>>                               08300000
        tos:=1;                <<length>>                               08305000
        assemble(mtds 2);      <<move - save target>>                   08310000
        tos:=@direntry;        <<source>>                               08315000
        tos:=length;           <<length>>                               08320000
        assemble(mtds 4);      <<move>>                                 08325000
      end;                                                              08330000
  end;                                                                  08335000
$page                                                                   08340000
logical procedure searchsl(name,errorflag);                             08345000
  <<searches the current sl file for the entry point. note>>            08350000
  <<that this procedure uses condition code to indicate an>>            08355000
  <<error.  also errorflag=1 on an error>>                              08360000
  integer errorflag;                                                    08365000
  integer array name;                                                   08370000
  option uncallable;                                                    08375000
  begin                                                                 08380000
    integer result = searchsl;                                          08385000
    integer bucket = q+1;                                               08390000
    integer length = q+2;                                               08395000
    byte pointer bname = q+3;  <<identifier>>                           08400000
    double drecd = q+4;  <<current rec. nr.>>                           08405000
    integer recd = drecd+1;                                             08410000
                                                                        08415000
    <<* * * initialize local variables * * *>>                          08420000
                                                                        08425000
    assemble(adds 2);    <<save space for bucket and length>>           08430000
    tos := @name&lsl(1);                                                08435000
    tos := name.(4:12);  <<nc and first char.>>                         08440000
    xreg := name.(4:4)-1;  <<nc-1>>                                     08445000
    tos := bname(xreg)&csl(8);  <<sec. to last char.>>                  08450000
    xreg := xreg+1;                                                     08455000
    tos := bname(xreg);  <<last char.>>                                 08460000
    assemble(add,decx);                                                 08465000
    if = then tos := tos.(4:12);                                        08470000
    tos := nbuckets;                                                    08475000
    assemble(ldiv,zrob);                                                08480000
    bucket:=tos;                                                        08485000
    if scancache(name,bucket) then                                      08490000
      begin  <<found directory entry in cache>>                         08495000
        hits:=hits+1d;  <<increment hit counter>>                       08500000
        result:=result+1;                                               08505000
        go aok;                                                         08510000
      end                                                               08515000
     else                                                               08520000
      begin    <<must read sl directory>>                               08525000
        tos := slrec0(bucket+slfhi);  <<first rec. in list>>            08530000
        while <> do                                                     08535000
          begin                                                         08540000
           freaddir(slfnum(slnr),sldir,128,drecd);                      08545000
           if <> then go ioerror;  <<error?>>                           08550000
           @slp := @sldir(2);  <<init. entry pointer>>                  08555000
           while @slp < @sldir(sldir(1)) do                             08560000
              begin                                                     08565000
              @slp1 := @slp+slp.(4:3)+1; <<secondary pointer>>          08570000
              if samename(name,slname) then  <<name's match?>>          08575000
                 begin                                                  08580000
                 if slnr=0 then   <<system sl>>                         08585000
                   begin                                                08590000
                     misses:=misses+1d;  <<inc miss counter>>           08595000
                     length:=@slp1-@slp+parmlen(slparms)+1;             08600000
                     addtocache(slp,length,bucket);                     08605000
                   end;                                                 08610000
                 result := result+1;                                    08615000
                 go aok                                                 08620000
                 end;                                                   08625000
              @slp := @slp1+parmlen(slparms)+1  <<next entry>>          08630000
              end;                                                      08635000
           recd := sldir  <<next record in list>>                       08640000
          end;                                                          08645000
      end;                                                              08650000
aok:                                                                    08655000
    errorflag:=0; <<return ok code>>                                    08660000
    tos := cce;  <<ok condition code>>                                  08665000
    go getout;                                                          08670000
                                                                        08675000
ioerror:                                                                08680000
    errorflag:=1; <<return error condition>>                            08685000
    ferror(slfnum(xreg));                                               08690000
    tos := ccl;  <<error condition code>>                               08695000
                                                                        08700000
getout:                                                                 08705000
    condcode := tos  <<store condition code>>                           08710000
  end;                                                                  08715000
$page                                                                   08720000
procedure getreftabent (segnr);                                         08725000
  <<loads the record (if necessary) containing the reference>>          08730000
  <<table entry and sets the entry pointer to it.  note that>>          08735000
  <<this procedure uses condition code to indicate an error>>           08740000
  value segnr;                                                          08745000
  integer segnr;                                                        08750000
  option uncallable;                                                    08755000
  begin                                                                 08760000
    tos := segnr; tos := 4;                                             08765000
    assemble(div);                                                      08770000
    @rtp := (tos&lsl(5))+@rtbuf;  <<set entry pointer>>                 08775000
    tos := tos+slrec1(slnr);  <<buffer pointer>>                        08780000
    tos := ps0;  <<rec. nr.>>                                           08785000
    if s0 <> rtrecd then  <<different record?>>                         08790000
       begin                                                            08795000
         savereftabbuf;                                                 08800000
         if < then go nfg;  <<error?>>                                  08805000
         rtrecd := tos;                                                 08810000
         freaddir(slfnum(xreg),rtbuf,128,drtrecd);                      08815000
         if <> then go ioerror  <<error?>>                              08820000
       end;                                                             08825000
    tos := cce;  <<ok condition code>>                                  08830000
    go getout;                                                          08835000
                                                                        08840000
ioerror:                                                                08845000
    ferror(slfnum(xreg));                                               08850000
                                                                        08855000
nfg:                                                                    08860000
    tos := ccl;  <<error condition code>>                               08865000
                                                                        08870000
getout:                                                                 08875000
    condcode := tos  <<store condition code>>                           08880000
  end;                                                                  08885000
$page                                                                   08890000
procedure savereftabbuf;                                                08895000
  <<saves the contents of the reference table buffer if it >>           08900000
  <<has been modified.  note that this procedure uses >>                08905000
  <<condition code to indicate an error>>                               08910000
  option uncallable;                                                    08915000
  begin                                                                 08920000
    tos := rtmodified;  <<modified flag>>                               08925000
    if <> then  <<modified?>>                                           08930000
       begin                                                            08935000
         fwritedir(slfnum(slnr),rtbuf,128,drtrecd);                     08940000
         if <> then go ioerror  <<error?>>                              08945000
       end;                                                             08950000
    rtmodified := 0;  <<clear modified flag>>                           08955000
    tos := cce;  <<ok condition code>>                                  08960000
    go getout;                                                          08965000
                                                                        08970000
ioerror:                                                                08975000
    ferror(slfnum(xreg));                                               08980000
    tos := ccl;  <<error condition code>>                               08985000
                                                                        08990000
getout:                                                                 08995000
    condcode := tos  <<store condition code>>                           09000000
  end;                                                                  09005000
$page                                                                   09010000
procedure getslnames (flag);                                            09015000
   <<initializes the sl file name arrays with the proper set >>         09020000
   <<of file names.  if the flag is true, then the file names>>         09025000
   <<are determined from the domain of the program file;   >>           09030000
   <<otherwise from the log-on domain.  note that this  >>              09035000
   <<procedure uses condition code to indicate an error>>               09040000
   value flag;                                                          09045000
   logical flag;                                                        09050000
   option uncallable;                                                   09055000
   begin                                                                09060000
   byte array b0 (0:2)=pb := "SL.";                                     09065000
   byte array b1 (0:3)=pb := "PUB.";                                    09070000
   byte array b2 (0:3)=pb := "SYS ";                                    09075000
   byte array group (0:8);  <<group name>>                              09080000
   byte array acct (0:8);  <<account name>>                             09085000
   integer libno;                                                       09090000
   array buf (0:40);                                                    09095000
$page                                                                   09100000
subroutine getnames(lineptr);                                           09105000
value lineptr;                                                          09110000
byte pointer lineptr;                                                   09115000
begin                                                                   09120000
   tos := @group&lsr(1);                                                09125000
   ps0 := "  ";                                                         09130000
   asmb(dup,incb);                                                      09135000
   tos := 9;                                                            09140000
   asmb(move 3); << blank buffer >>                                     09145000
   tos := @lineptr;                                                     09150000
   tos := @acct;                                                        09155000
   tos := @group;                                                       09160000
   asmb(cab); << line ptr to tos >>                                     09165000
   scan * until ".",1; << skip file name >>                             09170000
   tos := tos + 1; << skip "." >>                                       09175000
   move * := * while an,0; << get group name >>                         09180000
   delb; << del group name pointer >>                                   09185000
   tos := tos + 1; << skip "." >>                                       09190000
   move * := * while an; << get account name >>                         09195000
end;                                                                    09200000
$page                                                                   09205000
   <<* * * partially initialize file names * * *>>                      09210000
                                                                        09215000
   move sslfname := b0,(3),2;                                           09220000
   move * := b1,(4),2;                                                  09225000
   move * := b2,(4);                                                    09230000
   move pslfname := b0,(3),2;                                           09235000
   move * := b1,(4),2;                                                  09240000
   move gslfname := b0,(3),2;                                           09245000
                                                                        09250000
   <<* * * complete file name initialization * * *>>                    09255000
                                                                        09260000
   if flag then  <<saved file?>>                                        09265000
      begin                                                             09270000
      scan bline until ".",1;  <<skip over local name>>                 09275000
      tos := tos+1;  <<skip over ".">>                                  09280000
      move * := * while an,0;  <<insert group name>>                    09285000
      move * := *,(1),1;  <<insert ".">>                                09290000
      xreg := s0;  <<save pointer to acct. name>>                       09295000
      move * := * while an,1;  <<insert acct. name>>                    09300000
      bps0 := " ";  <<insert trailing blank>>                           09305000
      asmb(xax); << get acct pointer >>                                 09310000
      move * := * while an,1;  <<insert account name>>                  09315000
      bps0 := " ";  <<insert trailing blank>>                           09320000
      getnames(bline);                                                  09325000
      scan group until "  ",1;                                          09330000
      bps0 := "."; << set at end of group string >>                     09335000
      del;                                                              09340000
      end                                                               09345000
   else  <<non-saved file>>                                             09350000
      begin                                                             09355000
      group(8) := " "; acct(8) := " ";                                  09360000
      move  group := mgroup,(8);                                        09365000
      scan group until "  ",1;                                 <<06094>>09370000
      bps0 := ".";                                             <<06094>>09375000
      del;                                                     <<06094>>09380000
      move  acct := macct,(8);                                          09385000
      move * := group while an,1;  <<insert group name>>                09390000
      bps0 := ".";  <<insert ".">>                                      09395000
      assemble (inca);  <<skip over ".">>                               09400000
      move * := acct while an,0;  <<insert account name>>               09405000
      move * := *,(1);  <<insert trailing blank>>                       09410000
      move * := acct while an,0;  <<insert account name>>               09415000
      move * := *,(1)  <<insert trailing blank>>                        09420000
      end;                                                              09425000
<<   * * *  check for valid libraray search  * * *  >>                  09430000
   tos := mlibsearch;             <<library search level>>              09435000
   if group = b1,(4) then         <<public group?>>                     09440000
    if acct = b2,(4) then         <<system account?>>                   09445000
     if tos <> 0 then             <<lib neq to sys?>>                   09450000
     begin                                                              09455000
         mlibsearch:=0;                                                 09460000
     end                                                                09465000
     else                                                               09470000
    else                                                                09475000
     if tos = 2 then mlibsearch := 1 <<default to pub search>>          09480000
     else                                                               09485000
   else                                                                 09490000
     del;                                                               09495000
   slcap(0):=1; <<sys sl has pm capability>>                            09500000
   libno := mlibsearch;                                                 09505000
   while > do                                                           09510000
   begin << determine group capability >>                               09515000
      slcap(libno):=0;                                                  09520000
      tos := slfname(libno);                                            09525000
      getnames(*);                                                      09530000
      direcfind (8,0d,acct,group,buf,buf);<< get group entry >>         09535000
      if = then slcap(libno) := buf(23).(9:1); << pm bit >>             09540000
      libno := libno - 1;                                               09545000
   end;                                                                 09550000
   tos := cce;  <<ok condition code>>                                   09555000
   go getout;                                                           09560000
                                                                        09565000
abort:                                                                  09570000
   merror := tos;  <<insert error nr.>>                                 09575000
   tos := ccl;  <<error condition code>>                                09580000
                                                                        09585000
getout:                                                                 09590000
   condcode := tos  <<store condition code>>                            09595000
   end;                                                                 09600000
$page                                                                   09605000
procedure validcap (flag);                                              09610000
  <<checks the program file capability to see if it is a >>             09615000
  <<subset of the group or user's capability.  note that >>             09620000
  <<this procedure uses condition code to indicate an error>>           09625000
  value flag;                                                           09630000
  logical flag;                                                         09635000
  option uncallable;                                                    09640000
  begin                                                                 09645000
   array buf (0:40) = q;                                                09650000
   array group (*) = buf;                                               09655000
   array acct (*) = buf(4);                                             09660000
   tos := pcapability;                                                  09665000
   tos.(7:2) := 0;  <<clear "IA" and "BA">>                             09670000
   if tos <> 0 then  <<non-standard capabilities?>>                     09675000
     begin                                                              09680000
      tos := @group; ps0 := "  ";                                       09685000
      assemble(dup,incb); tos := 7; assemble(move 3);                   09690000
      if flag then  <<saved file?>>                                     09695000
        begin                                                           09700000
         tos := @acct&lsl(1);                                           09705000
         tos := @group&lsl(1);                                          09710000
         scan bline until ".",1;  <<skip over local name>>              09715000
         tos := tos+1;                                                  09720000
         move * := * while an,0;  <<insert group name>>                 09725000
         assemble(delb,inca);                                           09730000
         move * := * while an;  <<insert account name>>                 09735000
         direcfind (8,0d,acct,group,buf,buf);<<group entry>>            09740000
         if < then  <<error?>>                                          09745000
           begin                                                        09750000
            tos := err74; go abort                                      09755000
           end;                                                         09760000
         tos := buf(23)  <<group's resource capabilities>>              09765000
        end                                                             09770000
      else  <<non-saved file>>                                          09775000
        begin                                                           09780000
         tos := usercap2  <<user's resource capabilities>>              09785000
        end;                                                            09790000
      usercap := s0.(9:1); << pm bit >>                                 09795000
      tos := pcapability;                                               09800000
      assemble(dup,cab; and,cmp);                                       09805000
      if <> then  <<not subset?>>                                       09810000
        begin                                                           09815000
         tos := err39; go abort                                         09820000
        end                                                             09825000
     end;                                                               09830000
   tos := cce;  <<ok condition code>>                                   09835000
   go getout;                                                           09840000
                                                                        09845000
abort:                                                                  09850000
   merror := tos;  <<error nr.>>                                        09855000
   tos := ccl;  <<error condition code>>                                09860000
                                                                        09865000
getout:                                                                 09870000
   condcode := tos  <<store condition code>>                            09875000
   end;                                                                 09880000
$page                                                                   09885000
procedure extnparms;                                                    09890000
   <<calculates the unsatisfied external entry parameters>>             09895000
   option uncallable;                                                   09900000
   begin                                                                09905000
     uxnc := uxp.(4:4);                                                 09910000
     @uxp1 := @uxp+uxp.(4:3)+1;                                         09915000
     @uxp2 := @uxp1+uxnr+1;                                             09920000
     uxnw := @uxp2-@uxp+parmlen(uxparms)                                09925000
   end;                                                                 09930000
$page                                                                   09935000
procedure satisfyprog;                                                  09940000
  <<satisfies the externals of the program and constructs>>             09945000
  <<the satisfied external table.  note this procedure >>               09950000
  <<uses the condition code to indicate an error>>                      09955000
  option uncallable;                                                    09960000
  begin                                                                 09965000
                                                                        09970000
    <<* * * open program file * * *>>                                   09975000
                                                                        09980000
    progkey := mprogkey';  <<prog. file key>>                           09985000
    tos := 0;  <<for result of fopenda>>                                09990000
    tos := 0;                                                           09995000
    tos := mprogkey';                                                   10000000
    s2 := bs1;  <<logical device nr.>>                                  10005000
    bs1 := 0;  <<clear log. dev. nr.>>                                  10010000
    progfnum := fopenda (*,*,%(2)111110111,,,,,,mpvinfo);      <<06094>>10015000
    if < then  <<error?>>                                               10020000
       begin                                                            10025000
       fcheck(0,mferror);  <<file sys. error nr's>>                     10030000
       tos := err53; go abort                                           10035000
       end;                                                             10040000
    flock(progfnum,true);  <<get file exclusively>>                     10045000
                                                                        10050000
    <<* * * read records 0 and 1 * * *>>                                10055000
                                                                        10060000
    dtemp4:=0d;                                                         10065000
    freaddir(progfnum,buf1,p256,dtemp4); <<rec 0,1>>                    10070000
    if <> then go ioerror;  <<error?>>                                  10075000
    npa := buf1(1);  <<nr. segments>>                                   10080000
    if logicalmapping then                                              10085000
      begin     <<mapping firmware present>>                            10090000
        if not (1<=npa<=255) then                                       10095000
          begin <<illegal # segments>>                                  10100000
            tos:=err37;                                                 10105000
            go abort;                                                   10110000
          end;                                                          10115000
      end                                                               10120000
     else                                                               10125000
      begin     <<no mapping firmware>>                                 10130000
        if not (1<=npa<=63) then                                        10135000
          begin <<illegal # segments>>                                  10140000
            tos:=err37;                                                 10145000
            go abort;                                                   10150000
          end;                                                          10155000
      end;                                                              10160000
    tos := abs(maxcodeseg);   << get max # code segments >>             10165000
    if tos < npa then  <<too many segments?>>                           10170000
       begin                                                            10175000
       tos := err38; go abort                                           10180000
       end;                                                             10185000
    temp1:=28+npa+(npa+1)&lsr(1);                                       10190000
    <<temp1=number of words needed>>                                    10195000
    makeroomindl(temp1);                                                10200000
    if < then go nfg;   <<error>>                                       10205000
    @progrec0:=@dlarea1-temp1;                                          10210000
    @dlarea1:=@dlarea1-temp1;                                           10215000
    @ptemp3:=@progrec0;                                                 10220000
    <<move all of program file info into dl area-->>                    10225000
    <<do it in 256 word chunks                    >>                    10230000
    temp2:=p256;                                                        10235000
    while temp1 > 0 do                                                  10240000
      begin           <<move up to 256 words>>                          10245000
        if temp1 < temp2 then temp2:=temp1;                             10250000
        move ptemp3:=buf1,(temp2);                                      10255000
        temp1:=temp1-temp2;                                             10260000
        if temp1 > 0 then                                               10265000
          begin    <<more to move--read next 2 records>>                10270000
            @ptemp3:=@ptemp3+temp2;                                     10275000
            dtemp4:=dtemp4+2d;                                          10280000
            freaddir(progfnum,buf1,p256,dtemp4);                        10285000
            if <> then go ioerror;  <<error>>                           10290000
          end;                                                          10295000
      end; <<while>>                                                    10300000
                                                                        10305000
    <<* * * get file characteristics * * *>>                            10310000
                                                                        10315000
    blankline;                                                          10320000
    if < then go nfg;  <<error?>>                                       10325000
    tos := 0;  <<for foptions>>                                         10330000
    tos := progfnum;                                                    10335000
    move bline := "PROGRAM FILE ",2;                                    10340000
    fgetinfo(*,*,s2);                                                   10345000
    validcap(s0);  <<check capability>>                                 10350000
    if < then go nfg;  <<error?>>                                       10355000
    getslnames(*);                                                      10360000
    if < then go nfg;  <<error?>>                                       10365000
    printline;                                                          10370000
    if < then go nfg;  <<error?>>                                       10375000
    blankline;                                                          10380000
    if < then go nfg;  <<error?>>                                       10385000
                                                                        10390000
    <<* * * format external list * * *>>                                10395000
                                                                        10400000
    tos:=(pentryrecd-pexternalrecd)&lsl(7);<<nr. words>>                10405000
    makeroomindl(s0);                                                   10410000
    if < then go nfg;  <<error?>>                                       10415000
    freaddir(progfnum,dlarea2,s0,                                       10420000
                      double(logical(pexternalrecd)));                  10425000
    if <> then go ioerror;  <<error?>>                                  10430000
    @uxp := @dlarea2;  <<init. entry pointer>>                          10435000
    while uxp <> 0 do                                                   10440000
       begin                                                            10445000
       extnparms;                                                       10450000
       uxutype:=14;  <<source of external=prog seg>>                    10455000
       @uxp := @uxp+uxnw  <<next entry>>                                10460000
       end;                                                             10465000
    @dlavail := @uxp;  <<init. dl available pointer>>                   10470000
                                                                        10475000
    <<* * * satisfy externals of program * * *>>                        10480000
                                                                        10485000
    satisfy;                                                            10490000
    if < then go nfg;  <<error?>>                                       10495000
    tos := cce;  <<ok condition code>>                                  10500000
    go getout;                                                          10505000
                                                                        10510000
ioerror:                                                                10515000
    ferror(progfnum);                                                   10520000
    go nfg;                                                             10525000
                                                                        10530000
abort:                                                                  10535000
    merror := tos;  <<error nr.>>                                       10540000
                                                                        10545000
nfg:                                                                    10550000
    tos := ccl;  <<error condition code>>                               10555000
                                                                        10560000
getout:                                                                 10565000
    condcode := tos  <<store condition code>>                           10570000
  end;                                                                  10575000
$page                                                                   10580000
procedure satisfyproc;                                                  10585000
  <<finds the procedure and satisfies all it's externals>>              10590000
  <<note this procedure uses condtion code to indicate an>>             10595000
  <<error>>                                                             10600000
  option uncallable;                                                    10605000
  begin                                                                 10610000
                                                                        10615000
    <<* * * prime external table with procedure entry * * *>>           10620000
                                                                        10625000
    makeroomindl(10);                                                   10630000
    if < then go nfg;  <<error?>>                                       10635000
    move dlarea2 := mprocname',(8);                                     10640000
    tos := @dlarea2+dlarea2.(4:3)+1;                                    10645000
    tos:=%170001;  <<source of external=loadproc,nr=1>>                 10650000
    ps1:=tos;                                                           10655000
    tos:=tos+1;                                                         10660000
    tos:=0 d;      <<references and parms>>                             10665000
    dps2 := tos;                                                        10670000
    @dlavail := tos+2;  <<reset dl available pointer>>                  10675000
                                                                        10680000
    <<* * * find procedure and satisfy it's externals * * *>>           10685000
                                                                        10690000
    getslnames(false);  <<get sl file names>>                           10695000
    satisfy;                                                            10700000
    if < then go nfg;  <<error?>>                                       10705000
    tos := cce;  <<ok condition code>>                                  10710000
    go getout;                                                          10715000
                                                                        10720000
nfg:                                                                    10725000
    tos := ccl;  <<error condition code>>                               10730000
                                                                        10735000
getout:                                                                 10740000
    condcode := tos  <<store condition code>>                           10745000
  end;                                                                  10750000
procedure satisfy;                                                      10755000
   <<steps thru the sl files and tries to satisfy the >>                10760000
   <<externals in the unsatisfied external table, thereby>>             10765000
   <<constructing a data base of all referenced segs and>>              10770000
   <<their stt entries.  this procedure uses condition  >>              10775000
   <<code to indicate an error.                         >>              10780000
   option uncallable;                                                   10785000
   begin                                                                10790000
   byte array b3 (0:2)=pb := "SPG";                                     10795000
   byte array b4(0:12)=pb := "INCOMPATIBLE ";                           10800000
   byte array b5(0:12)=pb := "FUNCTION FOR ";                           10805000
   byte array b6(0:24)=pb := "NUMBER OF PARAMETERS FOR ";               10810000
   byte array b7(0:14)=pb := "PARAMETERS FOR ";                         10815000
   byte array b8(0:13)=pb := " PARAMETER(S) ";                          10820000
   define uxseg = uxp1(temp2).(8:8)#, <<referencing seg #>>             10825000
          uxstt = uxp1(temp2).(0:8)#; <<referencing stt #>>             10830000
   integer savedb,savesir,segnr,searcherr;                              10835000
   integer array trace0'ext(0:6)=pb:= %3524, <<cn=7 , t >>              10840000
                                      %51101,<<   r , a >>              10845000
                                      %41505,<<   c , e >>              10850000
                                      %30047,<<   0 , ' >>              10855000
                                     %170001,<<src=15,nr=1>>            10860000
                                           0,<<references>>             10865000
                                           0;<<parms    >>              10870000
   integer bindingerror := 0;   <<binding error flag>>                  10875000
   logical array segs (0:15)=q; <<segments referenced bit map>>         10880000
   integer array parms(0:4)=q;  <<parmcheck array>>                     10885000
   integer pointer segptr, <<ptr to data base seg entry>>               10890000
                   sttptr; <<ptr to data base stt entry>>               10895000
   logical pointer ptemp1,ptemp2; <<temp ptrs>>                         10900000
$page                                                                   10905000
subroutine typestring (buf,type);                                       10910000
  value type;                                                           10915000
  byte array buf;                                                       10920000
  integer type;                                                         10925000
  begin                                                                 10930000
    tos := ds2;                                                         10935000
    if tos = 14                                                         10940000
      then move * := "PROG"                                             10945000
      else                                                              10950000
        begin                                                           10955000
          move * := b3(s2),(1),2;                                       10960000
          move * := "SL"                                                10965000
        end                                                             10970000
  end;                                                                  10975000
$page                                                                   10980000
subroutine parms'match;                                                 10985000
  <<parms of external satisfier match.  build loadmap>>                 10990000
  <<info and entries in sldatabase for satisfier.    >>                 10995000
  begin                                                                 11000000
    if mlmap then                                                       11005000
      begin       <<loadmap desired>>                                   11010000
        tos := @bline;                                                  11015000
        tos:=@uxname&lsl(1)+1;                                          11020000
        move * := *,(uxnc);                                             11025000
        typestring(bline(16),uxutype);                                  11030000
        ntoa(uxparms.(0:2),8,bline(21));                                11035000
        typestring(bline(31),slnr);                                     11040000
        ntoa(slparms.(0:2),8,bline(36));                                11045000
        ntoa(slsttnr,8,bline(40));                                      11050000
        ntoa(slsegnr,8,bline(44));                                      11055000
        xreg := uxnr;                                                   11060000
        while <> do                                                     11065000
           begin                                                        11070000
             tos := uxp1(xreg).(0:8);                                   11075000
             tos := 8;                                                  11080000
             tos := @bline+25;                                          11085000
             ntoa(*,*,*);                                               11090000
             tos := uxp1(xreg).(8:8);                                   11095000
             tos := 8;                                                  11100000
             tos := @bline+29;                                          11105000
             ntoa(*,*,*);                                               11110000
             printline;                                                 11115000
             if < then go nfg;                                          11120000
             xreg := xreg-1                                             11125000
           end;                                                         11130000
      end;                                                              11135000
    <<construct satisfied data base entries>>                           11140000
    temp2:=uxnr+1;                <<# references>>                      11145000
    while ( temp2:=temp2-1) > 0 do                                      11150000
      begin                       <<entry for each reference>>          11155000
        tos:=bldsegentry(uxutype,uxseg);                                11160000
        if < then go to nfg; <<no room>>                                11165000
        @segptr:=tos;                                                   11170000
        tos:=bldsttentry(segptr,uxstt);                                 11175000
        if < then go to nfg; <<no room>>                                11180000
        @sttptr:=tos;                                                   11185000
        <<insert stt data>>                                             11190000
        sttptr(dbsat):=slnr;   <<satisfier type>>                       11195000
        sttptr(dbplabel):=slplabel;     <<satisfier plabel>>            11200000
      end; <<while>>                                                    11205000
    <<build seg entry in data base>>                                    11210000
    <<for satisfier               >>                                    11215000
    bldsegentry(slnr,slsegnr);                                          11220000
    if < then go to nfg; <<noroom>>                                     11225000
    if allocproc and slnr=0 and slp.(3:1)=1                             11230000
      then begin                                                        11235000
             tos:=err85; go abort;                                      11240000
           end;                                                         11245000
    if slnr<>0 or slp.(3:1)=0 then                                      11250000
      begin  <<must check indirect refs>>                               11255000
        setbit(segs,slsegnr);  <<set ref'ed bit>>                       11260000
      end;                                                              11265000
  end; <<parms'match>>                                                  11270000
$page                                                                   11275000
subroutine parms'mismatch;                                              11280000
  <<parms of satisfier do not match.  move info to >>                   11285000
  <<loadmap.                                       >>                   11290000
  begin                                                                 11295000
    bindingerror:=bindingerror+1;                                       11300000
    move bline := b4,(13),2;                                            11305000
    case parms of                                                       11310000
       begin                                                            11315000
       ;                                                                11320000
       move * := b5,(13),2;                                             11325000
       move * := b6,(25),2;                                             11330000
       move * := b7,(15),2;                                             11335000
       end;                                                             11340000
    tos := @uxname&lsl(1)+1;                                            11345000
    move * := *,(uxnc),2;                                               11350000
    if parms = 3 then <<one of the parms?>>                             11355000
       begin                                                            11360000
       move * := b8,(14);                                               11365000
       printbitmap(parms(1));                                           11370000
       if < then go nfg; <<error?>>                                     11375000
       end                                                              11380000
    else                                                                11385000
       begin                                                            11390000
       del;  <<move dest>>                                              11395000
       printline';                                                      11400000
       if < then go nfg; <<error?>>                                     11405000
       end;                                                             11410000
  end; <<parms'mismatch>>                                               11415000
$page                                                                   11420000
logical subroutine chkallocated;                                        11425000
  <<determine whether segnr has already been allocated>>                11430000
  begin                                                                 11435000
    chkallocated:=false;                                                11440000
    <<check if current sl has been loaded>>                             11445000
    tos:=0;       <<lsearch result>>                                    11450000
    tos:=slkey(slnr); <<sl key>>                                        11455000
    savesir:=getsir(segtabsir);                                         11460000
    savedb:=exchangedb(segtabdst);                                      11465000
    if lsearch(*,normal,slfile) then                                    11470000
      begin       <<sl exists>>                                         11475000
        <<check if segnr has been loaded>>                              11480000
        tos:=0;   <<testbit result>>                                    11485000
        tos:=@entp2; <<array>>                                          11490000
        if testbit(*,segnr) then                                        11495000
          begin   <<segnr has been loaded>>                             11500000
            <<check if segnr has been allocated>>                       11505000
            <<find correct seglist entry       >>                       11510000
            si:=@entp3;                                                 11515000
            @entp3:=@entp3+eslseg'sl*3;                                 11520000
            while (@entp3:=@entp3-3) >= si do                           11525000
              begin  <<check each seglist entry>>                       11530000
                if entp3.(0:8) = segnr then                             11535000
                  begin  <<found correct seglist entry>>                11540000
                    chkallocated:=entp3.(12:1);<<get "A" bit>>          11545000
                    relsir(segtabsir,savesir);                          11550000
                    exchangedb(savedb);                                 11555000
                    return;                                             11560000
                  end;                                                  11565000
              end; <<while>>                                            11570000
          end;                                                          11575000
      end;                                                              11580000
    relsir(segtabsir,savesir);                                          11585000
    exchangedb(savedb);                                                 11590000
  end; <<chkallocated>>                                                 11595000
$page                                                                   11600000
  <<* * * initialize hit/miss counters * * *>>                          11605000
                                                                        11610000
  if loadcacheseg<>0 then                                               11615000
    begin                                                               11620000
      tos:=@hits;             <<target>>                                11625000
      tos:=loadcacheseg;      <<source segment>>                        11630000
      tos:=cachehits;         <<source>>                                11635000
      tos:=4;                 <<length>>                                11640000
      assemble(mfds 4);       <<move>>                                  11645000
    end;                                                                11650000
                                                                        11655000
  <<allocate space for slsegs>>                                         11660000
  tos:=(mlibsearch+1)&lsl(4); <<16 words/sl>>                           11665000
  makeroomindl(*);                                                      11670000
  if < then go to nfg;  <<no room>>                                     11675000
  <<setup pointers to slsegs>>                                          11680000
  slnr:=mlibsearch+1;                                                   11685000
  while (slnr:=slnr-1) >= 0 do                                          11690000
    begin                                                               11695000
      tos:=@dlarea1-16;                                                 11700000
      slsegs(slnr):=s0;                                                 11705000
      assemble(dup);                                                    11710000
      clearbitmap(*);                                                   11715000
      @dlarea1:=tos;                                                    11720000
      slpvinfo(slnr):=0;                                                11725000
    end;                                                                11730000
  <<search each sl for satisfiers of externals>>                        11735000
  slnr:=mlibsearch+1;  <<sl counter>>                                   11740000
  while (slnr:=slnr-1) >= 0 and                                         11745000
        @dlavail <> @dlarea2 do                                         11750000
   begin                                                                11755000
    clearbitmap(segs);                                                  11760000
    if slnr = 0 and       <<ready to search sys sl>>                    11765000
       progload and       <<loading a program     >>                    11770000
       psastlt <> -1 then <<and program is being traced>>               11775000
      begin                                                             11780000
        <<insert external reference to trace0'>>                        11785000
        makeroomindl(7);                                                11790000
        move dlavail:=trace0'ext,(7);                                   11795000
        @dlavail:=@dlavail+7;                                           11800000
      end;                                                              11805000
                                                               <<06094>>11810000
      << dismount unused mounted vol.      >>                  <<06094>>11815000
                                                               <<06094>>11820000
      if slnr < mlibsearch then                                <<06094>>11825000
         if slpvinfo(slnr+1) <> 0 then                         <<06094>>11830000
            begin                                              <<06094>>11835000
               dismountvolset(slpvinfo(slnr+1),mpin);          <<06094>>11840000
               slpvinfo(slnr+1):=0;                            <<06094>>11845000
            end;                                               <<06094>>11850000
                                                                        11855000
    <<* * * open sl file * * *>>                                        11860000
                                                                        11865000
    xreg := slnr;                                                       11870000
    if <> then  <<public or group sl>>                                  11875000
      begin                                                             11880000
       if xreg = 1 and pslfname = sslfname,(11) then                    11885000
          go endloop;  <<ignore public sl?>>                            11890000
       tos := 0;  <<for result of fopen>>                               11895000
       tos := slfname(xreg);  <<sl file name>>                          11900000
       slfnum(xreg):=fopen(*,%(2)10000000001,%(2)111110110);            11905000
       if < then  <<error?>>                                            11910000
          begin                                                         11915000
          tos := 0; fcheck(0,s0);                                       11920000
          if s0=51 or s0=52 then                                        11925000
            begin  <<non-existing sl>>                                  11930000
              del;                                                      11935000
              slkey(xreg):=0d;                                          11940000
              go to endloop;                                            11945000
            end;                                                        11950000
          mferror := tos;  <<file sys. error nr's>>                     11955000
          tos := err50+slnr;  <<error nr.>>                             11960000
          go abort                                                      11965000
          end;                                                          11970000
       assemble(adds 4);                                                11975000
       fgetinfo(slfnum(xreg),,,,,,s1,,s0,,,,,,,,,,,ds3);                11980000
       if tos <> slfilecode then  <<type sl?>>                          11985000
          begin                                                         11990000
          invalidsl:                                                    11995000
          tos := err28+xreg;                                            12000000
          go abort                                                      12005000
          end;                                                          12010000
       bs2 := tos;  <<insert log. dev. nr.>>                            12015000
       slkey(xreg) := tos;  <<sl file key>>                             12020000
       tos := mountvolset (slfnum (slnr),mpin);                         12025000
         if < then  << mount failure >>                        <<06094>>12030000
            begin                                              <<06094>>12035000
               slpvinfo (slnr) := 0;                           <<06094>>12040000
               tos := err94 + slnr;                            <<06094>>12045000
               go abort;                                       <<06094>>12050000
            end                                                <<06094>>12055000
         else                                                           12060000
            slpvinfo(slnr) := tos;                                      12065000
      end;                                                              12070000
    flock(slfnum(slnr),true);  <<get file exclusively>>                 12075000
      fsetmode(slfnum(xreg),2); <<wait until buffer flushed>>  <<07301>>12080000
                                                                        12085000
    <<* * * allocate dl buffers * * *>>                                 12090000
                                                                        12095000
    makeroomindl(128);                                                  12100000
    if < then go nfg;                                                   12105000
    tos:=@dlarea1-128;                                                  12110000
    slrec1(xreg):=s0;                                                   12115000
    @dlarea1:=tos;                                                      12120000
    freaddir(slfnum(xreg),buf1,p256,0d);  <<read rec's 0,1>>            12125000
    if <> then go ioerror;  <<error?>>                                  12130000
    if slid <> slfileid then go invalidsl;  <<old version?>>            12135000
    tos:=slrec1(xreg);                                                  12140000
    move *:=buf2,(128);  <<save record 1>>                              12145000
$page                                                                   12150000
                                                                        12155000
    <<* * * try to satisfy externals * * * >>                           12160000
                                                                        12165000
    searcherr:=0; <<init error flag>>                                   12170000
    @uxp := @dlarea2;  <<init. unsatis. extn. pointer>>                 12175000
    while @uxp <> @dlavail do                                           12180000
     begin                                                              12185000
      <<cycle thru each unsatisfied entry>>                             12190000
      extnparms;                                                        12195000
      if uxp >= 0 and                                                   12200000
         searchsl(uxname,searcherr) then                                12205000
        begin                                                           12210000
          <<entry is unsatisfied and    >>                              12215000
          <<sl has entry pt of same name>>                              12220000
          @saveuxp := @uxp;  <<save entry pointer>>                     12225000
          while @uxp <> @dlavail do                                     12230000
           begin                                                        12235000
            <<cycle thru each unsatisfied entry for>>                   12240000
            <<entries of this name--satisfy at once>>                   12245000
            extnparms;                                                  12250000
            if uxp >= 0 and                                             12255000
               samename(uxname,slname) then                             12260000
              begin                                                     12265000
                <<unsatisfied entry of same name>>                      12270000
                <<check if parameters match     >>                      12275000
                parmcheck(slparms,uxparms,parms);                       12280000
                if parms = 0                                            12285000
                  then parms'match <<parms match>>                      12290000
                  else parms'mismatch;<<parms mismatch>>                12295000
                uxp.(0:1):=1;<<set sat. flag>>                          12300000
              end;                                                      12305000
            @uxp:=@uxp+uxnw; <<next entry>>                             12310000
           end; <<while>>                                               12315000
          @uxp:=@saveuxp; <<restore pointer>>                           12320000
          extnparms;                                                    12325000
        end                                                             12330000
       else if searcherr <> 0 then go nfg;<<error>>                     12335000
      @uxp:=@uxp+uxnw; <<next entry>>                                   12340000
     end; <<while>>                                                     12345000
    <<remove satisfied externals from list>>                            12350000
    @uxp:=@dlarea2;            <<source ptr>>                           12355000
    @ptemp3:=@dlarea2;         <<target ptr>>                           12360000
    while @uxp <> @dlavail do                                           12365000
     begin                    <<examine all entries>>                   12370000
      extnparms;             <<setup secondary ptrs>>                   12375000
      if uxp >= 0 then                                                  12380000
        begin                <<entry not satisfied-save>>               12385000
          temp2:=uxnw;       <<entry length>>                           12390000
          if @ptemp3 <> @uxp then                                       12395000
            begin            <<move required>>                          12400000
              move ptemp3:=uxp,(temp2);                                 12405000
            end;                                                        12410000
          @ptemp3:=@ptemp3+temp2; <<update target>>                     12415000
          @uxp:=@uxp+temp2;       <<update source>>                     12420000
        end                                                             12425000
       else                                                             12430000
        begin                <<entry satisfied-skip>>                   12435000
          @uxp:=@uxp+uxnw;   <<update source>>                          12440000
        end;                                                            12445000
     end; <<while>>                                                     12450000
    @dlavail:=@ptemp3;         <<update available space>>               12455000
                                                                        12460000
    <<* * * get indirectly referenced segments * * *>>                  12465000
                                                                        12470000
    drtrecd := 0d;  <<init. rec. nr.>>                                  12475000
    @ptemp1:=slsegs(slnr);                                              12480000
    segnr:=256;                                                         12485000
    while (segnr:=segnr-1) >= 0 do                                      12490000
     begin                                                              12495000
      if testbit(segs,segnr) then                                       12500000
        begin                   <<seg directly ref'ed>>                 12505000
          getreftabent(segnr);                                          12510000
          if < then go nfg;  <<error?>>                                 12515000
          <<if allocate procedure check if segnr is>>                   12520000
          <<already allocated                      >>                   12525000
          if allocproc then                                             12530000
            begin           <<allocate procedure>>                      12535000
              if chkallocated then                                      12540000
                begin       <<segnr already allocated>>                 12545000
                  tos:=err84;                                           12550000
                  go abort;                                             12555000
                end                                                     12560000
               else                                                     12565000
                begin       <<segnr not allocated>>                     12570000
                  <<find seg entry of segnr in sldatabase>>             12575000
                  @segptr:=findsegentry(slnr,segnr);                    12580000
                  if < then suddendeath(350);                           12585000
                  segptr(dblbit):=1;<<set being alloc flag>>            12590000
                end;                                                    12595000
            end;                                                        12600000
          <<get bit map of all indirectly ref'ed segs>>                 12605000
          @ptemp2:=@slrefedsegs;                                        12610000
          xreg:=16;                                                     12615000
          while (xreg:=xreg-1) >= 0 do                                  12620000
            begin                                                       12625000
              ptemp1(xreg):=ptemp1(xreg) lor ptemp2(xreg);              12630000
            end;                                                        12635000
        end;                                                            12640000
     end; <<while>>                                                     12645000
                                                                        12650000
          <<* * * get externals of segments * * *>>                     12655000
                                                                        12660000
    <<externals of all directly or indirectly >>                        12665000
    <<referenced segments must be checked     >>                        12670000
    segnr:=256;                                                         12675000
    while (segnr:=segnr-1) >= 0 do                                      12680000
     begin                                                              12685000
      tos:=0; <<testbit result>>                                        12690000
      tos:=slsegs(slnr);                                                12695000
      tos:=segnr;                                                       12700000
      if testbit(*,*) then                                              12705000
        begin  <<seg ref'ed directly or indirectly>>                    12710000
          <<build seg entry in data base >>                             12715000
          bldsegentry(slnr,segnr);                                      12720000
          if < then go to nfg;  <<no room>>                             12725000
          getreftabent(segnr);                                          12730000
          if < then go nfg;  <<error?>>                                 12735000
          if not slsatisfiedseg then                                    12740000
            begin  <<unsatisfied externals exist>>                      12745000
              tos := slfnum(slnr);                                      12750000
              tos := (slnrrecs-slsld.(2:7)-1)&lsl(7);                   12755000
              tos := p256-slsld.(9:7);<<# words of spacing>>            12760000
              assemble(ddup,add);                                       12765000
              makeroomindl(*);                                          12770000
              if < then go nfg;  <<error?>>                             12775000
              tos := tos+@dlavail;  <<buffer adr.>>                     12780000
              assemble(xch,zero);                                       12785000
              tos := slsld.(2:7)+slsa+1;  <<rec. nr.>>                  12790000
              freaddir(*,*,*,*);                                        12795000
              if <> then go ioerror;  <<error?>>                        12800000
              <<examine each external reference>>                       12805000
              tos := @dlavail;  <<target pointer>>                      12810000
              tos := @dlavail+p256;  <<source pointer>>                 12815000
              tos := ps0;  <<first word of name>>                       12820000
              do                                                        12825000
               begin                                                    12830000
                 if < then                                              12835000
                   begin <<this external satisfied>>                    12840000
                     <<skip to next entry>>                             12845000
                     tos := tos+tos.(4:3)+2;                            12850000
                     assemble(ddup,zrob);                               12855000
                     tos := tos+parmlen(*)                              12860000
                   end                                                  12865000
                  else                                                  12870000
                   begin <<this external unsatisfied>>                  12875000
                     <<build unsat'ed entry in list>>                   12880000
                     tos := tos.(4:3)+1;                                12885000
                     assemble(move 1);  <<move name>>                   12890000
                     ps1:=slnr&lsl(12)+1;<<type and # refs>>            12895000
                     assemble(incb,ddup; zrob,inca);                    12900000
                     tos := parmlen(*)+1;                               12905000
                     assemble(move 1)<<p-label & parm info>>            12910000
                   end;                                                 12915000
                 tos := ps0;  <<next first word of name>>               12920000
               end until =;                                             12925000
              ddel;  <<1st word name,source ptr>>                       12930000
              @dlavail := tos                                           12935000
            end;                                                        12940000
        end;                                                            12945000
     end; <<while>>                                                     12950000
    savereftabbuf;  <<save buffer>>                                     12955000
    if < then go nfg;  <<error?>>                                       12960000
                                                                        12965000
endloop:                                                                12970000
   end;                                                                 12975000
                                                                        12980000
  <<* * * list unsatisfied externals * * *>>                            12985000
                                                                        12990000
  if @dlavail <> @dlarea2 then  <<remaining entries?>>                  12995000
    begin                                                               13000000
     @uxp := @dlarea2;  <<init. entry pointer>>                         13005000
     do                                                                 13010000
      begin                                                             13015000
        extnparms;                                                      13020000
         if uxutype = 15 then <<unknown procedure?>>                    13025000
           begin                                                        13030000
           tos := err41; go abort                                       13035000
           end;                                                         13040000
        move bline := "UNRESOLVED ",2;                                  13045000
        tos := uxutype;  <<external type>>                              13050000
        assemble(ddup);                                                 13055000
        typestring(*,*);                                                13060000
        tos := if tos = 3 then tos+5 else tos+4;                        13065000
        move * := "EXTERNAL ",2;                                        13070000
        tos := @uxname&lsl(1)+1;                                        13075000
        move * := *,(uxnc);                                             13080000
        printline';                                                     13085000
        if < then go nfg;  <<error?>>                                   13090000
        @uxp := @uxp+uxnw  <<next entry>>                               13095000
      end until @uxp = @dlavail;                                        13100000
     bindingerror := bindingerror+1  <<set flag>>                       13105000
    end;                                                                13110000
  tos := bindingerror;                                                  13115000
  if <> then  <<binding error?>>                                        13120000
     begin                                                              13125000
     tos := err27; go abort                                             13130000
     end;                                                               13135000
  tos := cce;  <<ok condition code>>                                    13140000
  go getout;                                                            13145000
                                                                        13150000
ioerror:                                                                13155000
  ferror(slfnum(slnr));                                                 13160000
  go nfg;                                                               13165000
                                                                        13170000
abort:                                                                  13175000
  merror := tos;  <<store error nr.>>                                   13180000
                                                                        13185000
nfg:                                                                    13190000
   slnr := mlibsearch;                                         <<06094>>13195000
   while >= do                                                 <<06094>>13200000
      begin                                                    <<06094>>13205000
         if slpvinfo(slnr) <> 0 then                           <<06094>>13210000
            dismountvolset(slpvinfo(slnr),mpin);               <<06094>>13215000
         slnr:=slnr-1;                                         <<06094>>13220000
      end;                                                     <<06094>>13225000
  tos := ccl;  <<error condition code>>                                 13230000
                                                                        13235000
getout:                                                                 13240000
                                                                        13245000
  <<* * * store hit/miss counters in cache * * *>>                      13250000
                                                                        13255000
  if loadcacheseg<>0 then                                               13260000
    begin                                                               13265000
      tos:=loadcacheseg;       <<target segment>>                       13270000
      tos:=cachehits;          <<target>>                               13275000
      tos:=@hits;              <<source>>                               13280000
      tos:=4;                  <<length>>                               13285000
      assemble(mtds 4);        <<move>>                                 13290000
    end;                                                                13295000
                                                                        13300000
  @dlavail := @dlarea2;  <<reset dl available pointer>>                 13305000
  condcode := tos  <<store condition code>>                             13310000
 end;                                                                   13315000
$page                                                                   13320000
procedure initsegmap(allocflag);                                        13325000
  value allocflag;                                                      13330000
  logical allocflag;                                                    13335000
  <<allocate segmapdst (if allocflag=true) and>>                        13340000
  <<set up dst and pointers into dst          >>                        13345000
  begin                                                                 13350000
    integer temp=q+1;                                                   13355000
    integer temp2=q+2;                                                  13360000
    integer p1del=q+3;                                                  13365000
    integer sttcount=q+4;                                               13370000
    integer segmapdel=q+5;                                              13375000
    integer array workarea(*)=q+6;                                      13380000
                                                                        13385000
    <<initialize local variables>>                                      13390000
    tos:=0d;      <<temp,temp2>>                                        13395000
    assemble(ddup,dup); <<p1del,sttcount,segmapdel>>                    13400000
    assemble(ddup); <<workarea(0),workarea(1)>>                         13405000
                                                                        13410000
    if allocflag then                                                   13415000
      begin           <<allocate dst>>                                  13420000
        segmapdst:=getdataseg(initsegmapsize,maxsegmapsize);            13425000
        if <> then                                                      13430000
          begin   <<error>>                                             13435000
            merror:=err99;                                              13440000
            condcode:=ccl;                                              13445000
            return;                                                     13450000
          end;                                                          13455000
        segmapsttposition:=(maxmcstidx+1)&lsl(1);                       13460000
        segmaplength:=initsegmapsize;                                   13465000
      end                                                               13470000
     else                                                               13475000
      begin           <<segmap already exists>>                         13480000
        <<get header entry from dst>>                                   13485000
        tos:=@workarea;    <<target>>                                   13490000
        tos:=segmapdst;    <<source dst>>                               13495000
        tos:=0;            <<source offset>>                            13500000
        tos:=2;            <<count>>                                    13505000
        assemble(mfds 4);                                               13510000
        segmaplength:=(dsti(segmapdst&lsl(2)).dslen-1)&lsl(2);          13515000
        <<determine if part 2 of segmap must move for part 1>>          13520000
        if workarea.(8:8) < maxmcstidx then                             13525000
          begin          <<part 2 must be moved>>                       13530000
            temp:=(maxmcstidx+16)&lsl(1);<<new part 1 len >>            13535000
            if temp > 510 then temp:=510;                               13540000
            <<allocate additional space for workarea>>                  13545000
            tos:=temp;                                                  13550000
            assemble(adds 0);                                           13555000
            <<clear rest of workarea>>                                  13560000
            workarea(2):=0;                                             13565000
            move workarea(3):=workarea(2),(temp-1);                     13570000
            <<get part 1 from segmap>>                                  13575000
            tos:=@workarea(2);  <<target>>                              13580000
            tos:=segmapdst;     <<source dst>>                          13585000
            tos:=2;             <<source offset>>                       13590000
            tos:=workarea.(8:8)&lsl(1); <<count>>                       13595000
            assemble(mfds 4);                                           13600000
            <<adjust stt pointer in each entry>>                        13605000
            p1del:=temp-workarea.(8:8)&lsl(1);<<move distance>>         13610000
            temp2:=workarea.(8:8)&lsl(1)+3;                             13615000
            while (temp2:=temp2-2) > 1 do                               13620000
              begin                                                     13625000
                if workarea(temp2) <> 0                                 13630000
                  then workarea(temp2):=workarea(temp2)+p1del;          13635000
              end; <<while>>                                            13640000
            <<insure dst length is sufficient>>                         13645000
            segmapdel:=workarea(1)+p1del-segmaplength;                  13650000
            if segmapdel > 0 then                                       13655000
              begin              <<must expand segmap>>                 13660000
                segmaplength:=altdsegsize(segmapdst,segmapdel);         13665000
                if <> then                                              13670000
                  begin    <<error>>                                    13675000
                    merror:=err99;                                      13680000
                    condcode:=ccl;                                      13685000
                    return;                                             13690000
                  end;                                                  13695000
              end;                                                      13700000
            <<move part 2 of segmap>>                                   13705000
            sttcount:=(workarea.(8:8)+1)&lsl(1)-workarea(1);            13710000
            tos:=segmapdst;        <<target dst>>                       13715000
            tos:=workarea(1)+p1del-1;<<target offset>>                  13720000
            tos:=segmapdst;        <<source dst>>                       13725000
            tos:=workarea(1)-1;    <<source offset>>                    13730000
            tos:=sttcount;         <<negative count>>                   13735000
            assemble(mds 5);                                            13740000
            <<adjust segmap header>>                                    13745000
            workarea(0):=temp&lsr(1); <<len part 1>>           <<06539>>13750000
            workarea(1):=workarea(1)+p1del; <<map length>>              13755000
            <<move new part 1 to segmap>>                               13760000
            tos:=segmapdst;        <<target dst>>                       13765000
            tos:=0;                <<target offset>>                    13770000
            tos:=@workarea(0);     <<source>>                           13775000
            tos:=temp+2;           <<count>>                            13780000
            assemble(mtds 4);                                           13785000
                                                                        13790000
            segmapsttposition:=workarea(1);                             13795000
          end                                                           13800000
         else                                                           13805000
          begin          <<part 2 does not have to move>>               13810000
            segmapsttposition:=workarea(1);                             13815000
          end;                                                          13820000
      end;                                                              13825000
    condcode:=cce;                                                      13830000
  end; <<initsegmap>>                                                   13835000
$page                                                                   13840000
procedure addsegdata'sldb;                                              13845000
  <<this procedure uses sl entries within the lst>>                     13850000
  <<to complete sldatabase seg entries. note this>>                     13855000
  <<procedure uses condition code to indicate an >>                     13860000
  <<error.                                       >>                     13865000
  begin                                                                 13870000
    integer temp  =q+1,                                                 13875000
            workareaspace=q+2;                                          13880000
    logical slexists=q+3;                                               13885000
    integer pointer segptr=q+4,                                         13890000
                    seglistptr=q+5,                                     13895000
                    seglist=q+6;                                        13900000
    integer workarea'dl=q+7;                                            13905000
    integer lprocmtab'dl=q+8;                                           13910000
    integer numbslid=q+9;                                               13915000
    integer numbmcst=q+10;                                              13920000
    double pointer slidptr=q+11;                                        13925000
    integer pointer mcstlsptr=q+12;                                     13930000
    double dtemp=q+13;                                                  13935000
    integer array workarea(*)=q+15;                                     13940000
    double array dworkarea(*)=workarea;                                 13945000
                                                                        13950000
    define active'lprocs'= lprocmastertab(2).(8:8)#;                    13955000
                                                                        13960000
    <<local sl entry definitions>>                                      13965000
    define seglogseg = 0).(0:8#,   <<logseg>>                           13970000
           segflags= 0).(12:4#,    <<a,c,x,m bits>>                     13975000
           segphycst = 2#;         <<phycst>>                           13980000
$page                                                                   13985000
    logical subroutine segallocated;                                    13990000
      <<determine whether the logical segment    >>                     13995000
      <<in sldatabase seg entry has already been >>                     14000000
      <<allocated a physical cst by examining the>>                     14005000
      <<sl entry in the lst.                     >>                     14010000
      begin                                                             14015000
        segallocated:=false;    <<initialize>>                          14020000
        if slexists then                                                14025000
          begin                 <<sl entry exists>>                     14030000
            if testbit(workarea(5),segptr(dblogseg)) then               14035000
              begin             <<logseg allocated>>                    14040000
                <<find seglist entry>>                                  14045000
                @seglist:=@seglistptr;                                  14050000
                temp:=workarea(4).(8:8);<<# seglist entries>>           14055000
                while (temp:=temp-1) >= 0 do                            14060000
                  begin                                                 14065000
                    if segptr(dblogseg)=seglist(seglogseg) then         14070000
                      begin       <<found entry>>                       14075000
                        segallocated:=true;                             14080000
                        return;                                         14085000
                      end                                               14090000
                     else                                               14095000
                      begin       <<wrong entry>>                       14100000
                        @seglist:=@seglist+3; <<next entry>>            14105000
                      end;                                              14110000
                  end; <<while>>                                        14115000
                <<allocated but no seglist entry>>                      14120000
                suddendeath(343);                                       14125000
              end;                                                      14130000
          end;                                                          14135000
      end; <<segallocated>>                                             14140000
$page                                                                   14145000
logical subroutine matchslid;                                           14150000
  <<return true if slid in mcstlogseg entry>>                           14155000
  <<matches one of the slkeys being used   >>                           14160000
  <<for this procedure load                >>                           14165000
  begin                                                                 14170000
    if mcstlsptr(temp).(8:8) < 14 then                                  14175000
      begin  <<sl seg--check for slid match>>                           14180000
        dtemp:=slidptr(mcstlsptr(temp).(8:8)); <<get slid>>             14185000
        slnr:=mlibsearch+1;                                             14190000
        while (slnr:=slnr-1) >= 0 do                                    14195000
          begin                                                         14200000
            if dtemp = slkey(slnr) then                                 14205000
              begin               <<found match>>                       14210000
                matchslid:=true;                                        14215000
                return;                                                 14220000
              end;                                                      14225000
          end; <<while>>                                                14230000
      end;                                                              14235000
    matchslid:=false;                                                   14240000
  end; <<matchslid>>                                                    14245000
$page                                                                   14250000
    <<initialize local variables>>                                      14255000
    tos:=0d;     <<temp,workareaspace>>                                 14260000
    assemble(ddup);<<slexists,segptr>>                                  14265000
    tos:=@workarea+21; <<seglistptr>>                                   14270000
    assemble(dup);    <<seglist>>                                       14275000
    tos:=0d;          <<workarea'dl,lprocmtab'dl>>                      14280000
    assemble(ddup,ddup);<<numbslid,numbmcst>>                           14285000
                        <<slidptr,mcstlsptr>>                           14290000
    assemble(ddup);   <<dtemp>>                                         14295000
                                                                        14300000
    if progload then                                                    14305000
      begin         <<load/allocate program>>                          14310000
        <<allocate space for mapped cst index table>>                   14315000
        makeroomindl(16);                                               14320000
        if < then go to error; <<no room>>                              14325000
        tos:=@dlarea1-16;                                               14330000
        @mcsttab:=s0;                                                   14335000
        @dlarea1:=tos;                                                  14340000
      end                                                               14345000
     else                                                               14350000
      begin         <<load/allocate procedure>>                         14355000
        <<allocate space for max size loadproc master>>                 14360000
        if logicalmapping then                                          14365000
          begin     <<mapping firmware present>>                        14370000
            makeroomindl(576);                                          14375000
            if < then go to error; <<no room>>                          14380000
            tos:=@dlarea1-576;                                          14385000
          end                                                           14390000
         else                                                           14395000
          begin     <<mapping firmware not present>>                    14400000
            makeroomindl(66);                                           14405000
            if < then go to error;                                      14410000
            tos:=@dlarea1-66;                                           14415000
          end;                                                          14420000
        @lprocmastertab:=s0;                                            14425000
        @dlarea1:=tos;                                                  14430000
        @mcsttab:=@lprocmastertab(19);                                  14435000
      end;                                                              14440000
    <<initialize dl relative variables>>                                14445000
    workarea'dl:=@workarea-@dlarea2; <<dl relative>>                    14450000
    lprocmtab'dl:=@lprocmastertab-@dlarea2; <<dl relative>>             14455000
    <<initialize mcsttab>>                                              14460000
    tos:=@mcsttab;                                                      14465000
    clearbitmap(*);                                                     14470000
    <<check if further mcsttab initialization required>>                14475000
    if progload then                                                    14480000
      begin          <<load/allocate program>>                          14485000
        if logicalmapping then                                          14490000
          begin                                                         14495000
            <<mapped firmware--each prog seg is mapped>>                14500000
            <<set index for each program seg>>                          14505000
            temp:=npa+1;                                                14510000
            tos:=@mcsttab;                                              14515000
            while (temp:=temp-1) > 0 do                                 14520000
              begin                                                     14525000
                assemble(dup);       <<mcsttab ptr>>                    14530000
                setbit(*,temp);                                         14535000
              end; <<while>>                                            14540000
            assemble(del);           <<mcsttab ptr>>                    14545000
          end;                                                          14550000
      end                                                               14555000
     else                                                               14560000
      begin                <<load/allocate procedure>>                  14565000
        if not(allocproc) then                                          14570000
          begin  <<use loadprocmaster on load procedure only>>          14575000
            <<find loadproc master entry>>                              14580000
            tos:=0;        <<lsearch result>>                           14585000
            tos:=double(mpin); <<key>>                                  14590000
            exchangedb(segtabdst);                                      14595000
            if lsearch(*,normal,loadprocmaster) then                    14600000
              begin        <<entry exists>>                             14605000
                numbslid:=eslid'lproc; <<# slid entries>>               14610000
                numbmcst:=emcstls'lproc;<<# mcstlogseg entries>         14615000
                                                                        14620000
                <<move loadprocmaster from lst to stack>>               14625000
                <<allow for expansion of slid array>>                   14630000
                tos:=lprocmtab'dl;  <<target>>                          14635000
                tos:=@entp;         <<source>>                          14640000
                tos:=35+numbslid&lsl(1); <<count>>                      14645000
                assemble(mvbl 3); <<move db to dl>>                     14650000
                <<move mcstlogseg array>>                               14655000
                tos:=lprocmtab'dl+64; <<target>>                        14660000
                tos:=@entp3;          <<source>>                        14665000
                tos:=(numbmcst+1)&lsl(1); <<count>>                     14670000
                assemble(mvbl 3); <<move db to dl>>                     14675000
                                                                        14680000
                exchangedb(0);                                          14685000
                @slidptr:=@lprocmastertab(35);                          14690000
                @mcstlsptr:=@lprocmastertab(64);                        14695000
                <<increment count of active loadproc's>>                14700000
                active'lprocs':=active'lprocs'+1;                       14705000
                                                                        14710000
                <<examine each valid mapped cst # to  >>                14715000
                <<determine if its corresponding segment >>             14720000
                <<was ref'ed by this loadproc            >>             14725000
                temp:=(numbmcst+1)&lsl(1);                              14730000
                while (temp:=temp-2) > 0 do                             14735000
                  begin                                                 14740000
                    tos:=0;           <<testbit result>>                14745000
                    tos:=@mcsttab;    <<bit  map>>                      14750000
                    if testbit(*,temp&lsr(1)) and                       14755000
                       matchslid then                                   14760000
                      begin           <<valid mcst entry>>              14765000
                        @segptr:=findsegentry(slnr,                     14770000
                               mcstlsptr(temp).(0:8));                  14775000
                        if = then                                       14780000
                          begin  <<this mapped cst needed >>            14785000
                                 <<for loadproc           >>            14790000
                            segptr(dbmcst):=temp&lsr(1);                14795000
                            segptr(dbrefflag):=1;                       14800000
                          end;                                          14805000
                      end;                                              14810000
                  end; <<while>>                                        14815000
              end                                                       14820000
             else                                                       14825000
              begin           <<loadproc master not found>>             14830000
                suddendeath(348);                                       14835000
              end;                                                      14840000
          end;                                                          14845000
      end;                                                              14850000
    <<complete each seg entry in sldatabase>>                           14855000
    slnr:=mlibsearch+1;                                                 14860000
    while (slnr:=slnr-1) >= 0 do                                        14865000
      begin                      <<cycle thru each sl>>                 14870000
        nsla(slnr):=0;           <<# segs allocated>>                   14875000
        if sldatabase(slnr) <> 0 then                                   14880000
          begin                  <<ref'ed segs in this sl>>             14885000
            <<find sl entry in lst>>                                    14890000
            tos:=0;              <<lsearch result>>                     14895000
            tos:=slkey(slnr);    <<slfile id>>                          14900000
            exchangedb(segtabdst);                                      14905000
            if lsearch(*,normal,slfile) then                            14910000
              begin              <<sl entry exists>>                    14915000
                slexists:=true;                                         14920000
                sr:=entrylength;                                        14925000
                if sr > workareaspace then                              14930000
                  begin  <<more space needed for workarea>>             14935000
                    tos:=sr-workareaspace;                              14940000
                    assemble(adds 0);                                   14945000
                    workareaspace:=sr;                                  14950000
                  end;                                                  14955000
                <<move sl entry to stack>>                              14960000
                tos:=workarea'dl; <<target>>                            14965000
                tos:=@entp;          <<source>>                         14970000
                tos:=sr;             <<count>>                          14975000
                assemble(mvbl 3);    <<move db to dl>>                  14980000
                <<sl entry now exists on stack>>                        14985000
              end                                                       14990000
             else                                                       14995000
              begin              <<sl entry non-existent>>              15000000
                slexists:=false;                                        15005000
              end;                                                      15010000
            exchangedb(0);       <<db back to stack>>                   15015000
            <<complete each seg entry in sldatabase for slnr>>          15020000
            @segptr:=sldatabase(slnr);                                  15025000
            while @segptr <> 0 do                                       15030000
              begin              <<cycle thru each seg entry>>          15035000
                if segallocated then                                    15040000
                  begin          <<seg already allocated>>              15045000
                    segptr(dbflags):=seglist(segflags);                 15050000
                    segptr(dbphycst):=seglist(segphycst);               15055000
                    if segptr(dbmapflag) = 0 and                        15060000
                       segptr(dbrefflag) = 0 then                       15065000
                      begin  <<mapped and not ref'ed before>>           15070000
                        tos:=0; <<nextbit result>>                      15075000
                        tos:=@mcsttab; <<bit array>>                    15080000
                        tos:=nextbit(*);<<get map index>>               15085000
                        if s0 = 0 then                                  15090000
                          begin <<none available>>                      15095000
                            tos:=err100;                                15100000
                            go abort;                                   15105000
                          end;                                          15110000
                        segptr(dbmcst):=tos;                            15115000
                        needsegmap:=true;                               15120000
                      end;                                              15125000
                  end                                                   15130000
                 else                                                   15135000
                  begin           <<seg not allocated>>                 15140000
                    if logicalmapping and                      <<06281>>15145000
                       loaddomain = phydomain and              <<06281>>15150000
                       procload then                           <<06281>>15155000
                          tos := get'phy'cst                   <<06281>>15160000
                    else                                       <<06281>>15165000
                       tos := getentry(1);                     <<06281>>15170000
                    if s0 = 0 then                                      15175000
                      begin       <<insufficient cst's>>                15180000
                        tos:=err65;                                     15185000
                        go abort;                                       15190000
                      end;                                              15195000
                    cstsallocated:=1;                                   15200000
                    nsla(slnr):=nsla(slnr)+1;<<# segs alloc>>           15205000
                    segptr(dbphycst):=tos;                              15210000
                    segptr(dbmapflag):=loaddomain;                      15215000
                    segptr(dbnewflag):=1;                               15220000
                    if segptr(dbmapflag) = 0 then                       15225000
                      begin        <<mapped cst>>                       15230000
                        tos:=0; <<nextbit result>>                      15235000
                        tos:=@mcsttab; <<bit array>>                    15240000
                        tos:=nextbit(*);<<get map index>>               15245000
                        if s0 = 0 then                                  15250000
                          begin    <<none available>>                   15255000
                            tos:=err100;                                15260000
                            go abort;                                   15265000
                          end;                                          15270000
                        segptr(dbmcst):=tos;                            15275000
                        needsegmap:=true;                               15280000
                      end;                                              15285000
                  end;                                                  15290000
                @segptr:=segptr(segnext); <<next seg entry>>            15295000
              end; <<while>>                                            15300000
          end;                                                          15305000
      end; <<while>>                                                    15310000
    <<determine max mapped index used>>                                 15315000
    if logicalmapping then                                              15320000
      begin               <<mapping firmware present>>                  15325000
        maxmcstidx:=256;                                                15330000
        do begin                                                        15335000
             maxmcstidx:=maxmcstidx-1;                                  15340000
             tos:=0;                                                    15345000
             tos:=@mcsttab;                                             15350000
           end until testbit(*,maxmcstidx) or                           15355000
                     maxmcstidx = 0;                                    15360000
      end                                                               15365000
     else                                                               15370000
      begin               <<no mapping firmware>>                       15375000
        maxmcstidx:=0;                                                  15380000
      end;                                                              15385000
    if needsegmap and not(allocproc) then                               15390000
      begin           <<segmap required>>                               15395000
        if progload                                                     15400000
          then initsegmap(true) <<allocate segmap>>                     15405000
          else initsegmap(false);<<setup segmap>>                       15410000
        if < then go to error;                                          15415000
      end                                                      <<07301>>15420000
    else                                                       <<07301>>15425000
      if segmapdst <> 0 then                                   <<07301>>15430000
        begin                                                  <<07301>>15435000
          exchangedb(segmapdst);                               <<07301>>15440000
          tos:=segmap(1);                                      <<07301>>15445000
          exchangedb(0);                                       <<07301>>15450000
          segmapsttposition := segmaplength := tos;            <<*7598>>15455000
        end;                                                   <<07301>>15460000
    condcode:=cce;               <<ok code>>                            15465000
    return;                                                             15470000
abort:                                                                  15475000
    merror:=tos;                                                        15480000
error:                                                                  15485000
    condcode:=ccl;                                                      15490000
  end; <<addsegdata'sldb>>                                              15495000
$page                                                                   15500000
procedure loadexternals;                                                15505000
  <<load the library segments specified by sldatabase>>                 15510000
  <<note this procedure uses condition code to indicate>>               15515000
  <<an error.                                          >>               15520000
  begin                                                                 15525000
    integer pointer segptr;                                             15530000
$page                                                                   15535000
    subroutine loadseg;                                                 15540000
      <<call loadsegment for the current seg>>                          15545000
      begin                                                             15550000
        getreftabent(segptr(dblogseg)); <<read ref tab>>                15555000
        tos:=slfnum(slnr);              <<sl file id>>                  15560000
        tos:=segptr(dblogseg);          <<log seg #>>                   15565000
        tos:=slnr;                      <<sl type>>                     15570000
        tos:=rtdp;               <<seg len,seg addr>>                   15575000
        tos:=@segptr;                   <<segptr>>                      15580000
        tos:=slcap(slnr);               <<sl capability>>               15585000
        tos:=true;                      <<priv mode>>                   15590000
        loadsegment(*,*,*,*,*,*,*,*);                                   15595000
        if < then go to loaderror;                                      15600000
      end; <<loadseg>>                                                  15605000
$page                                                                   15610000
    <<load segments from each sl>>                                      15615000
    slnr:=mlibsearch+1;                                                 15620000
    while (slnr:=slnr-1) >= 0 do                                        15625000
      begin                     <<each sl>>                             15630000
        drtrecd:=0d;                                                    15635000
        @segptr:=sldatabase(slnr);                                      15640000
        while @segptr <> 0 do                                           15645000
          begin                 <<each seg entry>>                      15650000
            <<loadseg must be called for each seg that is:>>            15655000
            <<1. newly allocated  or                      >>            15660000
            <<2. logical mapping firmware is present and  >>            15665000
            <<   seg is logically mapped and              >>            15670000
            <<   seg has not been previously loaded for   >>            15675000
            <<       this process                         >>            15680000
            if segptr(dbnewflag) = 1 or                                 15685000
               logicalmapping        and                                15690000
               segptr(dbmapflag) = 0 and                                15695000
               segptr(dbrefflag) = 0 then                               15700000
              begin             <<must load segment>>                   15705000
                loadseg;                                                15710000
              end;                                                      15715000
            @segptr:=segptr(segnext); <<next entry>>                    15720000
          end; <<while>>                                                15725000
        savereftabbuf;                                                  15730000
      end; <<while>>                                                    15735000
    << update segmapdst for the sl segs>>                               15740000
    if segmapdst <> 0 then                                              15745000
      begin               <<segmapdst exists>>                          15750000
        tos:=segmapsttposition; <<length of map>>                       15755000
        exchangedb(segmapdst);                                          15760000
        segmap(1):=tos;                                                 15765000
        exchangedb(0);                                                  15770000
        if procload then                                                15775000
          begin         <<load/allocate procedure>>                     15780000
            <<adjust final segmap size>>                                15785000
            altdsegsize(segmapdst,segmapsttposition+2                   15790000
                                   -segmaplength);                      15795000
          end;                                                          15800000
      end;                                                              15805000
    condcode:=cce;                                                      15810000
    return;                                                             15815000
abort:                                                                  15820000
    merror:=tos;                                                        15825000
loaderror:                                                              15830000
    condcode:=ccl;                                                      15835000
  end;                                                                  15840000
$page                                                                   15845000
procedure loadsegment(fnum,segnr,segtype,seglen,segrecd,                15850000
                segptr,capability,privmode);                            15855000
  <<loads the specified segment.  note this procedure >>                15860000
  <<uses the condition code to indicate an error>>                      15865000
  value fnum,segnr,segtype,seglen,segrecd,capability,                   15870000
           privmode,segptr;                                             15875000
  integer fnum,segnr,segtype,seglen,segrecd;                            15880000
  logical capability,privmode;                                          15885000
  integer pointer segptr;                                               15890000
  option uncallable;                                                    15895000
  begin                                                                 15900000
    double segdescrip = seglen;                                         15905000
    integer temp1   :=0,                                                15910000
            numbext :=0,                                                15915000
            sttnr   :=0,                                                15920000
            sat'slnr:=0,                                                15925000
            sat'logsegnr:=0,                                            15930000
            sat'plabel:=0,                                              15935000
            sttwork1:=0,                                                15940000
            sttwork2:=0,                                                15945000
            tempsegmapdst:=0,                                           15950000
            tempsegmapdel:=0,                                           15955000
            tempsegmaplen:=0,                                           15960000
            tempsegmapvds:=0,                                           15965000
            seglen' ,                                                   15970000
            sttrecd ;                                                   15975000
    integer pointer sat'segptr,                                         15980000
                    sttptr,                                             15985000
                    stt,                                                15990000
                    stt2,                                               15995000
                    sttsec;                                             16000000
    integer tempdb;                                            <<*7547>>16005000
                                                               <<*7547>>16010000
    byte pointer sttmap;                                                16015000
    <<note:   storesttsec & sttbuf must !always! be the>>               16020000
    <<      last two local variables defined!          >>               16025000
    logical storesttsec;                                                16030000
    integer array sttbuf(*) =storesttsec+1;                             16035000
    define progseg = segtype=14#,                                       16040000
           slseg = segtype <> 14#;                                      16045000
$page                                                                   16050000
subroutine chksegmapsize;                                               16055000
  <<insure segmap is large enough>>                                     16060000
  begin                                                                 16065000
    tos:=segmapsttposition+numbext+1;                                   16070000
    if s0 <= 0 then                                                     16075000
      begin        <<too big>>                                          16080000
        tos:=err101;                                                    16085000
        go abort;                                                       16090000
      end;                                                              16095000
    if tos > segmaplength then                                          16100000
      begin        <<must expand segmap>>                               16105000
        tempsegmapdel:=32760-segmaplength; <<max delta>>                16110000
        if tempsegmapdel > 1024 then                                    16115000
          begin  <<use delta=1024>>                                     16120000
            tempsegmapdel:=1024;                                        16125000
          end;                                                          16130000
        if tempsegmapdel < numbext+1 then                               16135000
          begin  <<segmap too big>>                                     16140000
            tos:=err101;                                                16145000
            go abort;                                                   16150000
          end;                                                          16155000
        tempsegmaplen:=altdsegsize(segmapdst,tempsegmapdel);            16160000
        if < then                                                       16165000
          begin   <<error--segmap locked or frozen>>                    16170000
            tos:=err102;                                                16175000
            go abort;                                                   16180000
          end;                                                          16185000
        if > then                                                       16190000
          begin     <<error--exceeded vds>>                             16195000
            <<get new data seg with more vds>>                          16200000
            tempsegmaplen:=segmaplength+tempsegmapdel;                  16205000
            tempsegmapvds:=((segmaplength+4095)&lsr(12))                16210000
                              &lsl(12);                                 16215000
            tempsegmapdst:=getdataseg(tempsegmaplen,                    16220000
                                       tempsegmapvds);                  16225000
            if <> then                                                  16230000
              begin    <<unable to get new segmap>>                     16235000
                tos:=err99;                                             16240000
                go abort;                                               16245000
              end;                                                      16250000
            <<move segmap data to new dst>>                             16255000
            tos:=tempsegmapdst; <<target dst>>                          16260000
            tos:=0;             <<target offset>>                       16265000
            tos:=segmapdst;     <<source dst>>                          16270000
            tos:=0;             <<source offset>>                       16275000
            tos:=segmapsttposition; <<count>>                           16280000
            assemble(mds 5);                                            16285000
            <<release old segmap dst>>                                  16290000
            if progload then                                            16295000
              begin         <<load/allocate program>>                   16300000
                reldataseg(segmapdst); <<release current dst>>          16305000
              end                                                       16310000
             else                                                       16315000
              begin         <<load/allocate procedure>>                 16320000
                <<save current dst if this is 1st dst switch>>          16325000
                if oldsegmapdst = 0                                     16330000
                  then oldsegmapdst:=segmapdst                          16335000
                  else reldataseg(segmapdst);                           16340000
                newsegmapflag:=1; <<set flag for dst switch>>           16345000
              end;                                                      16350000
            segmapdst:=tempsegmapdst;  <<new dst>>                      16355000
          end;                                                          16360000
        segmaplength:=tempsegmaplen;  <<new length>>                    16365000
      end;                                                              16370000
    end; <<chksegmapsize>>                                              16375000
$page                                                                   16380000
subroutine storestt;                                                    16385000
<<write stt back to disc>>                                              16390000
  begin                                                                 16395000
    tos:=fnum;                                                          16400000
    tos:=@sttbuf;                                                       16405000
    tos:=p384;                                                          16410000
if slseg then tos:=tos+128; <<sl seg>>                                  16415000
    tos:=0;                                                             16420000
    tos:=sttrecd;                                                       16425000
    if < then                                                           16430000
      begin      <<special case>>                                       16435000
        s3:=s3+128; <<adj buf addr>>                                    16440000
        s2:=s2-128; <<adj count>>                                       16445000
        tos:=tos+1; <<adj rec #>>                                       16450000
      end;                                                              16455000
    if progseg then                                                     16460000
      begin                                                             16465000
        <<insure write of stt does not include >>                       16470000
        <<prog file header records             >>                       16475000
        while s0 <= ((28+npa+(npa+1)&lsr(1))/128) do                    16480000
          begin                                                         16485000
            <<adjust write parameters>>                                 16490000
            s3:=s3+128;    <<buffer address>>                           16495000
            s2:=s2-128;    <<word count    >>                           16500000
            tos:=tos+1;    <<record #      >>                           16505000
          end; <<while>>                                                16510000
      end;                                                              16515000
    fwritedir(*,*,*,*); <<write stt>>                                   16520000
    if <> then go ioerror; <<error>>                                    16525000
  end; <<storestt>>                                                     16530000
$page                                                                   16535000
subroutine countext;                                                    16540000
<<count # of external stt entries in current stt>>                      16545000
  begin                                                                 16550000
    numbext:=0; <<count of ext stt>>                                    16555000
    temp1:=stt.(8:8); <<# stt>>                                         16560000
    tos:=@stt; <<ptr to stt>>                                           16565000
    while (temp1:=temp1-1) >=0 do                                       16570000
      begin <<cycle thru stt entries>>                                  16575000
        tos:=tos-1; <<ptr to stt entry>>                                16580000
        if ps0 < 0                                                      16585000
          then numbext:=numbext+1;                                      16590000
      end;                                                              16595000
    assemble(del); <<ptr to stt>>                                       16600000
  end; <<countext>>                                                     16605000
$page                                                                   16610000
subroutine getnumbstt;                                                  16615000
<<convert to new format if necessary>>                                  16620000
<<determine number of internal and  >>                                  16625000
<<external stt entries              >>                                  16630000
  begin                                                                 16635000
    if progseg then                                                     16640000
      begin         <<loading prog seg>>                                16645000
        tos:=@progrec0+(npa+57)&lsr(1);<<ptr to seg desc>>              16650000
        if ps0(segnr).progextstt=1 then                                 16655000
          begin  <<stt in mapping format>>                              16660000
            <<# external stt=#stt-# internal stt>>                      16665000
            numbext:=stt.(8:8)-stt.(0:8);                               16670000
            sttnr:=stt.(0:8); << # internal stt's>>                     16675000
            if logicalmapping then                                      16680000
              begin  <<mapping firmware present>>                       16685000
                <<leave stt in present form>>                           16690000
                assemble(del); <<ptr to descriptor>>                    16695000
              end                                                       16700000
             else                                                       16705000
              begin  <<no mapping firmware>>                            16710000
                <<convert stt and seg descriptor back>>                 16715000
                stt.(0:8):=%100; <<set uncallable bit>>                 16720000
                ps0(segnr).progextstt:=0; <<clear flag>>                16725000
                assemble(del); <<ptr to descriptor>>                    16730000
                storestt;      <<write updated stt>>                    16735000
                tos:=progfnum; <<write updated seg>>                    16740000
                tos:=@progrec0;<< descriptor      >>                    16745000
                tos:=((28+npa+(npa+1)&lsr(1)+127)/128)*128;             16750000
                tos:=0d;                                                16755000
                fwritedir(*,*,*,*);                                     16760000
              end;                                                      16765000
          end                                                           16770000
         else                                                           16775000
          begin  <<stt not in mapping format>>                          16780000
            countext; <<count # external stt's>>                        16785000
            sttnr:=stt.(8:8)-numbext; <<# internal stt's>>              16790000
            if logicalmapping then                                      16795000
              begin  <<mapping firmware present>>                       16800000
                <<convert stt to mapping format>>                       16805000
                stt.(0:8):=sttnr;                                       16810000
                <<init stt head = #int stt,#stt>>                       16815000
                <<write updated stt back to disc>>                      16820000
                storestt;                                               16825000
                ps0(segnr).progextstt:=1; <<set init flag>>             16830000
                assemble(del); <<ptr to descriptor>>                    16835000
                <<write updated progrec0 back to disc>>                 16840000
                tos:=progfnum;                                          16845000
                tos:=@progrec0;                                         16850000
                tos:=((28+npa+(npa+1)&lsr(1)+127)/128)*128;             16855000
                tos:=0d;                                                16860000
                fwritedir(*,*,*,*);                                     16865000
              end                                                       16870000
             else                                                       16875000
              begin  <<no mapping firmware>>                            16880000
                <<leave stt in present form>>                           16885000
                assemble(del);  <<ptr to descriptor>>                   16890000
              end;                                                      16895000
          end;                                                          16900000
      end                                                               16905000
     else                                                               16910000
      begin         <<loading sl seg>>                                  16915000
        if reftab'extstt = 1 then                                       16920000
          begin  <<stt in mapping format>>                              16925000
            <<# external stt = # stt - # internal stt>>                 16930000
            numbext:=stt.(8:8)-stt.(0:8);                               16935000
            sttnr:=stt.(0:8); <<# internal stt's>>                      16940000
            <<if mapping firmware present leave stt alone>>             16945000
            <<if no mapping firmware convert stt back    >>             16950000
            if not logicalmapping then                                  16955000
              begin  <<no mapping firmware>>                            16960000
                reftab'extstt:=0;  <<clear flag>>                       16965000
                rtmodified:=1;           <<reftab modified>>            16970000
                stt.(0:8):=%100;         <<set uncallable bit>>         16975000
                storestt;                <<write updated stt>>          16980000
              end;                                                      16985000
          end                                                           16990000
         else                                                           16995000
          begin  <<stt in non-mapping format>>                          17000000
            countext;  <<count # external stt's>>                       17005000
            sttnr:=stt.(8:8)-numbext; <<# internal stt's>>              17010000
            <<if no mapping firmware leave stt alone>>                  17015000
            <<if mapping firmware present convert stt>>                 17020000
            if logicalmapping then                                      17025000
              begin  <<mapping firmware present>>                       17030000
                reftab'extstt:=1; <<set flag>>                          17035000
                rtmodified:=1;          <<reftab modified>>             17040000
                stt.(0:8):=sttnr;                                       17045000
                storestt;               <<write updated stt>>           17050000
              end;                                                      17055000
          end;                                                          17060000
      end;                                                              17065000
  end; <<getnumbstt>>                                                   17070000
$page                                                                   17075000
subroutine findsatisfier;                                               17080000
<<locate the satisfier for the current external stt>>                   17085000
<<sat'segptr will be pointing to the data base seg >>                   17090000
<<entry.  sat'slnr will be sl of satisfier.        >>                   17095000
<<sat'plabel will be the plabel of the satisfier.  >>                   17100000
  begin                                                                 17105000
    if slseg then                                                       17110000
      begin         <<loading sl segment>>                              17115000
        sat'logsegnr:=sttmap(sttnr);                                    17120000
      end                                                               17125000
     else                                                               17130000
      begin         <<loading program segment>>                         17135000
        if lastprogloadlogical then                                     17140000
          begin     <<prog last loaded logically>>                      17145000
            if stt2 > 0 and                                             17150000
               stt2.(8:8) <= npa then                                   17155000
              begin <<satisfier is in prog file>>                       17160000
                sat'logsegnr:=stt2.(8:8)-1;                             17165000
              end                                                       17170000
             else                                                       17175000
              begin <<satisfier is not in prog file>>                   17180000
                sat'logsegnr:=255;                                      17185000
              end;                                                      17190000
          end                                                           17195000
         else                                                           17200000
          begin     <<prog last loaded physically>>                     17205000
            sat'logsegnr:=sttmap(stt2.(8:8));                           17210000
          end;                                                          17215000
      end;                                                              17220000
    if sat'logsegnr <> 255 then                                         17225000
      begin     <<satisfier is internal to prog/sl>>                    17230000
        sat'slnr:=segtype; <<satisfier source>>                         17235000
        sat'plabel:=sat'logsegnr; <<sat seg #>>                         17240000
        sat'plabel.(1:7):=stt2.(1:7); <<sat stt #>>                     17245000
      end                                                               17250000
     else                                                               17255000
      begin     <<satisfier is external to prog/sl>>                    17260000
        <<an stt entry should exist giving the >>                       17265000
        <<satisfier of this external           >>                       17270000
        @sttptr:=findsttentry(segptr,sttnr,sttptr);                     17275000
        if < then                                                       17280000
          begin          <<satisfier not found>>                        17285000
            tos:=err28+(if segtype=14 then 3 else segtype);             17290000
            go abort;                                                   17295000
          end;                                                          17300000
        sat'slnr:=sttptr(dbsat); <<satisfier source>>                   17305000
        sat'plabel:=sttptr(dbplabel); <<satisfier plabel>>              17310000
      end;                                                              17315000
  end;  <<findsatisfier>>                                               17320000
$page                                                                   17325000
    <<initialize local variables>>                                      17330000
                                                                        17335000
    seglen':=seglen-1;                                                  17340000
    sttrecd:=seglen'.(2:7)+segrecd-2;                                   17345000
    @sat'segptr:=0;                                                     17350000
    @sttptr:=0;                                                         17355000
    @stt:=seglen'.(9:7)+@sttbuf+p256;                                   17360000
    @stt2:=@stt;                                                        17365000
    @sttsec:=@sttbuf+512;                                               17370000
    @sttmap:=(@stt+1)&lsl(1);                                           17375000
    storesttsec:=false;                                                 17380000
    tos:=768;             <<space for stt,sttmap,sttsec>>               17385000
    assemble(adds 0);     <<sttbuf>>                                    17390000
                                                                        17395000
    if progseg then @sttmap:=@progmap;                                  17400000
                                                                        17405000
                                                                        17410000
    <<* * * load stt * * *>>                                            17415000
                                                                        17420000
    tos := fnum;                                                        17425000
    tos := @sttbuf;                                                     17430000
    tos := p384;                                                        17435000
    if slseg then tos:=tos+128; <<sl seg>>                              17440000
    tos := 0; tos := sttrecd;                                           17445000
    if < then  <<special case?>>                                        17450000
       begin                                                            17455000
       s3 := s3+128;  <<adj. buffer adr.>>                              17460000
       s2 := s2-128;  <<adj. count>>                                    17465000
       tos := tos+1  <<adj. rec. nr.>>                                  17470000
       end;                                                             17475000
    freaddir(*,*,*,*);  <<load stt>>                                    17480000
    if <> then go ioerror;  <<error?>>                                  17485000
                                                                        17490000
    <<* * * repair stt * * *>>                                          17495000
                                                                        17500000
    getnumbstt;  <<get # of external and internal stt's>>               17505000
                                                                        17510000
    <<cycle thru each external stt>>                                    17515000
    << .find satisfier for external>>                                   17520000
    << .build satisfied stt        >>                                   17525000
    << .if logical mapping then    >>                                   17530000
    <<     build secondary map stt >>                                   17535000
    << .write repaired stt to disc >>                                   17540000
    << .if logical mapping write   >>                                   17545000
    <<     secondary stt to map    >>                                   17550000
    << .initialize cst entry       >>                                   17555000
                                                                        17560000
    storesttsec:=false;                                                 17565000
    @sttptr:=0;                                                         17570000
    temp1:=numbext;                                                     17575000
    @stt2:=@stt-sttnr; <<ptr to external stt>>                          17580000
    while (temp1:=temp1-1) >= 0 do                                      17585000
      begin            <<each external stt>>                            17590000
        sttnr:=sttnr+1;<<stt #>>                                        17595000
        @stt2:=@stt2-1;<<ptr to stt>>                                   17600000
        findsatisfier; <<satisfy external stt>>                         17605000
        <<find seg entry in data base for satisfier>>                   17610000
        @sat'segptr:=findsegentry(sat'slnr,                             17615000
                           sat'plabel.(8:8));                           17620000
        if < then                                                       17625000
          begin      <<satisfier not found>>                            17630000
            tos:=err28+(if segtype=14 then 3 else segtype);             17635000
            go abort;                                                   17640000
          end;                                                          17645000
        if logicalmapping then                                          17650000
          begin      <<mapping firmware present>>                       17655000
            <<build stt entry for code segment and>>                    17660000
            <<for stt list in segment map         >>                    17665000
            if progseg then                                             17670000
              begin         <<loading program segment>>                 17675000
                sttwork1:=sat'plabel;                                   17680000
                sttwork1.(0:1):=sat'segptr(dbmapflag);                  17685000
                if sat'segptr(dbmapflag) = 0                            17690000
                  then sttwork1.(8:8):=sat'segptr(dbmcst)               17695000
                  else sttwork1.(8:8):=sat'segptr(dbphycst);            17700000
              end                                                       17705000
             else                                                       17710000
              begin         <<loading sl segment>>                      17715000
                if segptr(dbmapflag) = 1 then                           17720000
                  begin     <<loading seg in phy domain>>               17725000
                    sttwork1:=sat'plabel;                               17730000
                    sttwork1.(0:1):=sat'segptr(dbmapflag);              17735000
                    sttwork1.(8:8):=sat'segptr(dbphycst);               17740000
                  end                                                   17745000
                 else                                                   17750000
                  begin     <<loading seg in mapped domain>>            17755000
                    sttwork1:=sat'plabel;                               17760000
                    sttwork1.(0:1):=0;                                  17765000
                    sttwork1.(8:8):=0;                                  17770000
                    sttwork2:=sttwork1;                                 17775000
                    if sat'segptr(dbmapflag)=0 then                     17780000
                      begin <<sat is logically mapped>>                 17785000
                        sttwork2.(8:8):=sat'segptr(dbmcst);             17790000
                      end                                               17795000
                     else                                               17800000
                      begin <<sat is physically mapped>>                17805000
                        sttwork2.(0:1):=1;                              17810000
                        sttwork2.(8:8):=sat'segptr(dbphycst);           17815000
                      end;                                              17820000
                    storesttsec:=true;                                  17825000
                  end;                                                  17830000
              end;                                                      17835000
          end                                                           17840000
         else                                                           17845000
          begin      <<mapping firmware not present>>                   17850000
            sttwork1:=sat'plabel;                                       17855000
            sttwork1.(0:1):=1;                                          17860000
            sttwork1.(8:8):=sat'segptr(dbphycst);                       17865000
          end;                                                          17870000
        stt2:=sttwork1;  <<satisfied external stt>>                     17875000
        if storesttsec then sttsec(temp1):=sttwork2;                    17880000
      end; <<while>>                                                    17885000
    <<write repaired stt to disc if seg is newly allocated>>            17890000
    if segptr(dbnewflag) = 1 then storestt;                             17895000
    <<construct segment map>>                                           17900000
    if segmapdst <> 0 and                                               17905000
       segptr(dbmapflag) = 0 then                                       17910000
      begin                 <<segment map required>>                    17915000
        <<build part 2 of map>>                                         17920000
        if storesttsec then                                             17925000
          begin            <<secondary stt info required>>              17930000
            sttsec(numbext):=numbext;                                   17935000
            chksegmapsize; <<check size of segmap>>                     17940000
            tos:=segmapdst;                                             17945000
            tos:=segmapsttposition;                                     17950000
            tos:=@sttsec;                                               17955000
            tos:=numbext+1;                                             17960000
            assemble(mtds 4);                                           17965000
            segmapsttposition:=segmapsttposition+numbext+1;             17970000
          end;                                                          17975000
        <<construct part 1 of segment map>>                             17980000
        sttsec(0):=segptr(dbphycst);                                    17985000
        sttsec(1):=if storesttsec                                       17990000
                     then segmapsttposition-1                           17995000
                     else 0;                                            18000000
        tos:=segmapdst;                                                 18005000
        tos:=segptr(dbmcst)&lsl(1);                                     18010000
        tos:=@sttsec;                                                   18015000
        tos:=2;                                                         18020000
        assemble(mtds 2);                                               18025000
      end;                                                              18030000
    <<initialize cst entry>>                                            18035000
    if segptr(dbnewflag) = 1 then                                       18040000
      begin                      <<segment newly allocated>>            18045000
        if progseg then                                                 18050000
          begin         <<prog seg to be allocated>>                    18055000
            tos:=cstbx; <<cst blk>>                                     18060000
            tos:=segnr; <<log seg nr>>                                  18065000
          end                                                           18070000
         else                                                           18075000
          begin         <<sl seg to be allocated>>                      18080000
            tos:=segptr(dbphycst); <<cst #>>                            18085000
          end;                                                          18090000
        tos := seglen.(2:12);   << length/4 >>                          18095000
        tos := privmode land logical(seglen.(0:1));                     18100000
        if ls0 and not capability then                                  18105000
          begin << priv. mode violation >>                              18110000
             tos := err44;                                              18115000
             go abort;                                                  18120000
          end;                                                          18125000
        tos.(1:1) := tos; << insert mode bit >>                         18130000
        tos := 0;                                                       18135000
        tos := fgetdiskadr(fnum,double(logical(segrecd)));              18140000
        tos := tos&tasl(8)&dlsr(8); << disc addr to s-2>>               18145000
        <<insert system bit (x) from flags>>                            18150000
        tos := segptr(dbxbit);                                          18155000
        if progseg                                                      18160000
          then putcstblock(*,*,*,*,*,*)                                 18165000
          else putcst(*,*,*,*,*);                                       18170000
      end;                                                              18175000
    condcode:=cce;       <<ok code>>                                    18180000
    return;                                                             18185000
abort:                                                                  18190000
    merror:=tos;                                                        18195000
nfg:                                                                    18200000
    condcode:=ccl;       <<error code>>                                 18205000
    return;                                                             18210000
ioerror:                                                                18215000
    ferror(fnum);                                                       18220000
    condcode:=ccl;       <<error code>>                                 18225000
  end;                                                                  18230000
$page                                                                   18235000
procedure addprogdata'sldb;                                             18240000
  <<this procedure completes sldatabase seg entries>>                   18245000
  <<for each program segment.  note this procedure >>                   18250000
  <<uses condition code to indicate an error       >>                   18255000
  begin                                                                 18260000
    integer index;                                                      18265000
    integer pointer segptr;                                             18270000
    index:=npa;                                                         18275000
    slnr:=14;                                                           18280000
    while (index:=index-1) >= 0 do                                      18285000
      begin               <<each program seg>>                          18290000
        @segptr:=bldsegentry(slnr,index);                               18295000
        if < then go error;                                             18300000
        segptr(dbmcst):=index+1;                                        18305000
        segptr(dbnewflag):=1; <<newly allocated>>                       18310000
        if logicalmapping then                                          18315000
          begin          <<mapping firmware present>>                   18320000
            segptr(dbphycst):=index+1;                                  18325000
            segptr(dbmapflag):=0;                                       18330000
          end                                                           18335000
         else                                                           18340000
          begin          <<mapping firmware not present>>               18345000
            segptr(dbphycst):=index+%301;                               18350000
            segptr(dbmapflag):=1;                                       18355000
          end;                                                          18360000
      end; <<while>>                                                    18365000
    <<allocate block of cst's in cstx area>>                            18370000
    cstbx:=alcstblock(npa);                                             18375000
    if < then                                                           18380000
      begin     <<error>>                                               18385000
        merror:=err65;                                                  18390000
        condcode:=ccl;  <<error code>>                                  18395000
        return;                                                         18400000
      end;                                                              18405000
    cstblockallocated:=1;                                               18410000
    condcode:=cce;      <<ok code>>                                     18415000
    return;                                                             18420000
error:                                                                  18425000
    condcode:=ccl;      <<error code>>                                  18430000
  end;                                                                  18435000
$page                                                                   18440000
procedure loadprogram;                                                  18445000
   <<repairs the stt's of the program file and loads the >>             18450000
   <<segments. also updates the cst re-mapping array in  >>             18455000
   <<record 0. note that this procedure uses condition>>                18460000
   <<code to indicate an error>>                                        18465000
   option uncallable;                                                   18470000
   begin                                                                18475000
     byte pointer bpline,                                               18480000
                  progremap;                                            18485000
     integer pointer segdescrip,                                        18490000
                     segptr;                                            18495000
     integer temp,                                                      18500000
             temp1;                                                     18505000
     define maxsegment = abs(maxcode)#;                                 18510000
                                                                        18515000
     <<initialize local variables>>                                     18520000
                                                                        18525000
     @progremap:=@progrec0(28)&lsl(1);     <<remap array>>              18530000
     @segdescrip:=@progrec0+(npa+57)&lsr(1);<<seg desc array>>          18535000
     if progremap(0) = 1                                                18540000
       then lastprogloadlogical:=true                                   18545000
       else lastprogloadlogical:=false;                                 18550000
     <<lastprogloadlogical can be true only if the program>>            18555000
     <<were last loaded using logical mapping firmware    >>            18560000
     <<                                                   >>            18565000
     temp1:=npa;                                                        18570000
     while (temp1:=temp1-1) >=0 do                                      18575000
       begin                                                            18580000
         <<verify all program segs are smaller>>                        18585000
         <<than max seg size                  >>                        18590000
         if segdescrip(temp1).(2:14) > maxsegment then                  18595000
           begin    <<too big>>                                         18600000
             tos:=err33;                                                18605000
             go abort;                                                  18610000
           end;                                                         18615000
         <<verify there are no priv mode violations>>                   18620000
         if segdescrip(temp1).(0:1) = 1 and                             18625000
            not mpmode                  and                             18630000
            not logical(pprivmode) then                                 18635000
           begin                <<violation>>                           18640000
             tos:=err39;                                                18645000
             go abort;                                                  18650000
           end;                                                         18655000
       end; <<while>>                                                   18660000
     <<build progmap for use by procedure loadsegment if>>              18665000
     <<lastprogloadlogical = false.                     >>              18670000
     if not lastprogloadlogical then                                    18675000
       begin                                                            18680000
         tos:=128;                                                      18685000
         makeroomindl(*);                                               18690000
         if < then go to error;                                         18695000
         tos:=@dlarea1-128;                                             18700000
         @progmap:=s0&lsl(1);    <<byte addr>>                          18705000
         @dlarea1:=s0;                                                  18710000
         <<initialize each byte to 255>>                                18715000
         ps0:=-1;     <<255 in each byte>>                              18720000
         assemble(dup,incb);                                            18725000
         tos:=127;                                                      18730000
         assemble(move 3);                                              18735000
       end;                                                             18740000
     <<rebuild progremap array and if necessary>>                       18745000
     <<fill in progmap array                   >>                       18750000
     slnr:=14;                                                          18755000
     temp:=-1;                                                          18760000
     while (temp:=temp+1) < npa do                                      18765000
       begin                                                            18770000
         @segptr:=findsegentry(slnr,temp);                              18775000
         if < then suddendeath(341);                                    18780000
         if not lastprogloadlogical                                     18785000
           then progmap(progremap(temp)):=temp;                         18790000
         progremap(temp):=segptr(dbphycst);                             18795000
         if mlmap then                                                  18800000
           begin      <<load map desired>>                              18805000
             blankline;                                                 18810000
             if < then go to error;                                     18815000
             @bpline:=@bline;                                           18820000
             ntoa(segptr(dbphycst),8,bpline(2));                        18825000
             @bpline:=@bpline+4;                                        18830000
             if @bpline-@bline = 64 then                                18835000
               begin            <<line full>>                           18840000
                 printline;                                             18845000
                 if < then go error; <<error>>                          18850000
                 @bpline:=@bline;                                       18855000
               end;                                                     18860000
           end;                                                         18865000
       end; <<while>>                                                   18870000
     if mlmap then                                                      18875000
       begin      <<load map desired>>                                  18880000
         if @bpline <> @bline then                                      18885000
            begin                                                       18890000
            printline;                                                  18895000
            if < then go error; <<error?>>                              18900000
            end;                                                        18905000
       end;                                                             18910000
                                                                        18915000
     <<***save record 0 and get starting cst number***>>                18920000
                                                                        18925000
     tos:=progfnum;                                                     18930000
     tos:=@progrec0;                                                    18935000
     tos:=((28+npa+(npa+1)&lsr(1)+127)&lsr(7))&lsl(7);                  18940000
     tos:=0d;                                                           18945000
     fwritedir(*,*,*,*);    <<write rec 0,1>>                           18950000
     if <> then go ioerror;  <<error?>>                                 18955000
     mstartingcst:=progremap(pstartingseg) cat                          18960000
                          segdescrip(pstartingseg)(0:0:1);              18965000
                                                                        18970000
     <<* * * load segments * * *>>                                      18975000
                                                                        18980000
     slnr:=14;                                                          18985000
     temp1:=psegmentrecd;  <<first seg rec #>>                          18990000
     @segptr:=sldatabase(slnr);                                         18995000
     while @segptr <> 0 do                                              19000000
       begin                                                            19005000
         temp:=segptr(dblogseg);                                        19010000
         tos:=progfnum;    <<prog file #>>                              19015000
         tos:=temp;        <<seg #>>                                    19020000
         tos:=slnr;        <<seg type>>                                 19025000
         tos:=segdescrip(temp); <<seg mode and seg len>>                19030000
         tos:=temp1;       <<seg rec #>>                                19035000
         tos:=@segptr;     <<segptr>>                                   19040000
         tos:=usercap;     <<capability>>                               19045000
         tos:=not mpmode;  <<privmode>>                                 19050000
         loadsegment(*,*,*,*,*,*,*,*);                                  19055000
         if < then go to error;                                         19060000
         temp1:=temp1+(segdescrip(temp).(2:14)+127)&lsr(7);             19065000
         @segptr:=segptr(segnext);                                      19070000
       end;                                                             19075000
     <<complete segmap dst>>                                            19080000
     if segmapdst <> 0 then                                             19085000
      begin                <<segmap exists>>                            19090000
        <<build 2 word header>>                                         19095000
        tos:=segmapsttposition; <<length of map>>                       19100000
        tos:=maxmcstidx;        <<# mapped segs>>                       19105000
        exchangedb(segmapdst);                                          19110000
        segmap(0):=tos;                                                 19115000
        segmap(1):=tos;                                                 19120000
        exchangedb(0);                                                  19125000
        <<adjust size of map>>                                          19130000
        altdsegsize(segmapdst,segmapsttposition+2-                      19135000
                                 initsegmapsize);                       19140000
      end;                                                              19145000
                                                                        19150000
     <<* * * mark program file as loaded * * *>>                        19155000
                                                                        19160000
     loadbit(progkey,1,0); <<set "LOADED" bit>>                         19165000
     if < then  <<error?>>                                              19170000
        begin                                                           19175000
        tos := err72;                                                   19180000
        go abort;                                                       19185000
        end;                                                            19190000
     progloadbit := 1;              <<set load bit flag>>               19195000
     condcode:=cce;     <<ok code>>                                     19200000
     return;                                                            19205000
ioerror:                                                                19210000
     ferror(progfnum);                                                  19215000
     condcode:=ccl;     <<error code>>                                  19220000
     return;                                                            19225000
abort:                                                                  19230000
     merror:=tos;                                                       19235000
error:                                                                  19240000
     condcode:=ccl;                                                     19245000
   end;                                                                 19250000
$page                                                                   19255000
procedure updatesegtab;                                                 19260000
   <<makes the necessary entries in the segment table for >>            19265000
   <<the set of loaded and referenced segments>>                        19270000
   option uncallable;                                                   19275000
   begin                                                                19280000
     integer posit=q+1,                                                 19285000
             numbslinfo=q+2,                                            19290000
             temp=q+3,                                                  19295000
             logsegnr=q+4,                                              19300000
             slloaded=q+5,                                              19305000
             tempmode=q+6,                                              19310000
             temptype=q+7,                                              19315000
             slpvinfo'=q+8,                                             19320000
             comword =q+9;                                              19325000
     double tempkey = q+10,                                             19330000
            slkey'  = q+12;                                             19335000
     double lprockey=slkey';                                            19340000
     integer lproclen=posit;                                            19345000
     integer slididx=q+14;                                              19350000
     integer pointer psegmap=q+15,                                      19355000
                     segptr =q+16,                                      19360000
                     sttptr =q+17;                                      19365000
     integer pointer mcstlsptr=q+18;                                    19370000
     double pointer slidptr=q+19;                                       19375000
     integer saveallocseg =q+20;                                        19380000
     integer array workarea(*)=q+21;                                    19385000
     define mcommand'=comword.(0:2)#;                                   19390000
     define procload' = logical(mcommand')#,                            19395000
            allocproc'= mcommand'=3#;                                   19400000
     define numbslid = lprocmastertab(2).(0:8)#,                        19405000
            numbmcst = lprocmastertab(64).(8:8)#;                       19410000
$page                                                                   19415000
subroutine insertslinfo;                                                19420000
  <<insert slinfo area into workarea>>                                  19425000
  <<if logicalmapping then also build              >>                   19430000
  <<  .psegmap array (progload)                    >>                   19435000
  <<  .mcstref array (procload)                    >>                   19440000
  begin                                                                 19445000
    if sldatabase(slnr) = 0 then return;                                19450000
    tos:=slkey(slnr);                                                   19455000
    workarea(posit+2):=tos;  <<slid>>                                   19460000
    workarea(posit+1):=tos;                                             19465000
    numbslinfo:=numbslinfo+1;                                           19470000
    workarea(posit):=slnr;   <<sl search sequence #>>                   19475000
    posit:=posit+3;                                                     19480000
    tos:=slsegs(slnr); <<source>>                                       19485000
    move workarea(posit):=*,(16); <<move slsegs to workarea>>           19490000
    posit:=posit+16;                                                    19495000
    if allocproc' then return;                                          19500000
    if procload' then                                                   19505000
      begin            <<load/allocate procedure>>                      19510000
        <<insert slkey into lprocmastertab>>                            19515000
        slididx:=-1;                                                    19520000
        while (slididx:=slididx+1) < numbslid do                        19525000
          begin                                                         19530000
            if slidptr(slididx) = slkey(slnr)                           19535000
              then go foundslid; <<found slid in array>>                19540000
          end; <<while>>                                                19545000
        <<slid not already in array -insert it>>                        19550000
        slididx:=numbslid;                                              19555000
        numbslid:=numbslid+1;                                           19560000
        slidptr(slididx):=slkey(slnr);                                  19565000
foundslid:                                                              19570000
      end;                                                              19575000
    <<build psegmap or mcstref array>>                                  19580000
    if logicalmapping then                                              19585000
      begin               <<mapping firmware present>>                  19590000
        @segptr:=sldatabase(slnr);                                      19595000
        while @segptr <> 0 do                                           19600000
          begin       <<cycle thru ref'ed segs>>                        19605000
            if segptr(dbmapflag) = 0 then                               19610000
              begin   <<seg logically mapped>>                          19615000
                if progload then                                        19620000
                  begin           <<load/allocate program>>             19625000
                    tos:=numbslinfo-1;<<curr slinfo index>>             19630000
                    tos.(0:8):=segptr(dblogseg);                        19635000
                    psegmap(segptr(dbmcst)):=tos;                       19640000
                  end                                                   19645000
                 else                                                   19650000
                  begin           <<load/allocate procedure>>           19655000
                    psegmap(0):=psegmap(0)+1;                           19660000
                    tos:=segptr(dbmcst);                                19665000
                    tos.(0:1):=segptr(dbnewflag);                       19670000
                    psegmap(psegmap(0)):=tos;                           19675000
                                                                        19680000
                    <<update mcstlogseg array in lprocmtab>>            19685000
                    if segptr(dbrefflag) = 0 then                       19690000
                      begin        <<newly referenced seg>>             19695000
                        <<create new mcst entry in array>>              19700000
                        tos:=slididx;                                   19705000
                        tos.(0:8):=segptr(dblogseg);                    19710000
                        mcstlsptr(segptr(dbmcst)&lsl(1)):=tos;          19715000
                        mcstlsptr(xreg+1):=1; <<refcount>>              19720000
                      end                                               19725000
                     else                                               19730000
                      begin       <<already referenced seg>>            19735000
                        <<increment refcount>>                          19740000
                        mcstlsptr(xreg):=1+                             19745000
                           mcstlsptr(segptr(dbmcst)&lsl(1)+1);          19750000
                      end;                                              19755000
                                                                        19760000
                  end;                                                  19765000
              end;                                                      19770000
            @segptr:=segptr(segnext);                                   19775000
          end; <<while>>                                                19780000
      end;                                                              19785000
  end; <<insertslinfo>>                                                 19790000
$page                                                                   19795000
subroutine expandseglist;                                               19800000
  <<temp contains the count of the additional  >>                       19805000
  <<seg list entries needed                    >>                       19810000
  <<temp=0 is returned if no room exists       >>                       19815000
  begin                                                                 19820000
    sj:=temp*3;       <<extra space>>                                   19825000
    sk:=entrylength;  <<current length>>                                19830000
    sq:=rlength;      <<region size>>                                   19835000
    sl:=@entp;        <<save ptrs>>                                     19840000
    sm:=@entp1;                                                         19845000
    sn:=@entp2;                                                         19850000
    si:=@entp3;                                                         19855000
    unlinklstentry;   <<unlink current entry>>                          19860000
    <<create new entry of increased size>>                              19865000
    lcreate(sj+sk,slfile,normal,0,slkey');                              19870000
    if < then                                                           19875000
      begin           <<error-no room>>                                 19880000
        @entp:=sl;    <<restore ptrs>>                                  19885000
        @entp1:=sm;                                                     19890000
        @entp2:=sn;                                                     19895000
        @entp3:=si;                                                     19900000
        temp:=0;      <<error flag>>                                    19905000
        linklstentry; <<relink current entry>>                          19910000
        return;                                                         19915000
      end;                                                              19920000
    <<ptrs now point to new entry>>                                     19925000
    <<move old entry data to new entry>>                                19930000
    tos:=@entp;       <<destination>>                                   19935000
    tos:=sl;          <<source>>                                        19940000
    tos:=sk;          <<length>>                                        19945000
    assemble(move 3); <<move it>>                                       19950000
    <<initialize new seglist entries>>                                  19955000
    sm:=@entp3;       <<save entp3>>                                    19960000
    sn:=temp;                                                           19965000
    @entp3:=@entp3+eslseg'sl*3;                                         19970000
    while (sn:=sn-1) >= 0 do                                            19975000
      begin           <<each new seglist entry>>                        19980000
        entp3(0):=%177400; <<free>>                                     19985000
        entp3(1):=0;       <<ref count>>                                19990000
        entp3(2):=0;       <<cst #>>                                    19995000
        @entp3:=@entp3+3;  <<next>>                                     20000000
      end;<<while>>                                                     20005000
    @entp3:=sm;       <<restore entp3>>                                 20010000
    eslseg'sl:=eslseg'sl+temp; <<update count>>                         20015000
    <<turn old entry into garbage>>                                     20020000
    buildgarbage(sl-3,sq);                                              20025000
  end; <<expandseglist>>                                                20030000
$page                                                                   20035000
  <<initialize local variables>>                                        20040000
  assemble(adds 20);  <<space for locals>>                              20045000
  tos:=512;                                                             20050000
  assemble(adds 0);   <<space for workarea>>                            20055000
  @psegmap:=@workarea(256);                                             20060000
  saveallocseg:=0;                                                      20065000
  comword:=lctbuf;  <<command word>>                                    20070000
                                                                        20075000
  if procload' then                                                     20080000
    begin           <<load/allocate procedure>>                         20085000
      @slidptr:=@lprocmastertab(35); <<slid array>>                     20090000
      @mcstlsptr:=@lprocmastertab(64); <<mcstlogseg array>>             20095000
      <<get plabel of loadproc satisfier>>                              20100000
      @segptr:=findsegentry(15,0);                                      20105000
      if < then suddendeath(349);                                       20110000
      @sttptr:=segptr(sttnext); <<ptr to stt entry>>                    20115000
      @segptr:=findsegentry(sttptr(dbsat),                              20120000
                            sttptr(dbplabel).(8:8));                    20125000
      if < then suddendeath(349);                                       20130000
      mplabel:=sttptr(dbplabel);                                        20135000
      mplabel.(0:1):=segptr(dbmapflag);                                 20140000
      if segptr(dbmapflag) = 0                                          20145000
        then mplabel.(8:8):=segptr(dbmcst)<<logically mapped>>          20150000
        else mplabel.(8:8):=segptr(dbphycst);<<phy. mapped>>            20155000
      <<construct extension entry in workarea>>                         20160000
      if allocproc'                                                     20165000
        then workarea(3):=sttptr(dbplabel).(8:8) <<logseg #>>           20170000
        else workarea(3):=1; <<loadproc count>>                         20175000
      workarea(4):=mplabel;                                             20180000
      <<get procedure name>>                                            20185000
      move workarea(5):=mprocname',(mprocname'.(4:3)+1);                20190000
      <<insert slinfo areas into extension entry>>                      20195000
      psegmap(0):=0;                                                    20200000
      posit:=7+mprocname'.(4:3); <<position in workarea>>               20205000
      numbslinfo:=0;                                                    20210000
      slnr:=mlibsearch+1;                                               20215000
      while (slnr:=slnr-1) >= 0 do                                      20220000
        insertslinfo;                                                   20225000
      workarea(6+mprocname'.(4:3)):=numbslinfo;                         20230000
      <<create extension entry in lst>>                                 20235000
      tos:=mpin;                                                        20240000
      tos:=mextension;                                                  20245000
      tempkey:=tos;          <<save parms for later>>                   20250000
      tempmode:=normal;                                                 20255000
      temptype:=extension;                                              20260000
    end else                                                            20265000
    begin       <<load/allocate program >>                              20270000
      <<construct program file entry in workarea>>                      20275000
      workarea(3) := cstbx;                                             20280000
      workarea(4) := segmapdst;                                         20285000
      workarea(5) := 0;        <<share count>>                          20290000
      workarea(7) := mpvinfo;  <<pv info>>                              20295000
      <<construct trace0' external label>>                              20300000
      if psastlt = -1 then                                              20305000
        begin  <<program not being traced>>                             20310000
          workarea(8):=0;                                               20315000
        end                                                             20320000
       else                                                             20325000
        begin  <<program being traced>>                                 20330000
          <<find trace0' seg entry>>                                    20335000
          @segptr:=findsegentry(15,0);                                  20340000
          if < then suddendeath(349);                                   20345000
          @sttptr:=segptr(sttnext);                                     20350000
          <<find satisfier>>                                            20355000
          @segptr:=findsegentry(sttptr(dbsat),                          20360000
                      sttptr(dbplabel).(8:8));                          20365000
          if < then suddendeath(349);                                   20370000
          <<construct external label>>                                  20375000
          workarea(8):=sttptr(dbplabel);                                20380000
          workarea(8).(0:1):=segptr(dbmapflag);                         20385000
          if segptr(dbmapflag) = 0                                      20390000
            then workarea(8).(8:8):=segptr(dbmcst)                      20395000
            else workarea(8).(8:8):=segptr(dbphycst);                   20400000
        end;                                                            20405000
      <<insert slinfo area into program file entry>>                    20410000
      posit:=9;  <<position in workarea>>                               20415000
      numbslinfo:=0;                                                    20420000
      slnr:=mlibsearch+1;                                               20425000
      while (slnr:=slnr-1) >= 0 do                                      20430000
        insertslinfo;                                                   20435000
      tos:=numbslinfo;                                                  20440000
      tos.(0:8):=npa;                                                   20445000
      workarea(6):=tos;  <<# prog segs,#slinfo areas>>                  20450000
      psegmap(0):=maxmcstidx; <<# entries in psegmap>>                  20455000
      if logicalmapping then                                            20460000
        begin            <<insert prog info in psegmap>>                20465000
          temp:=0;                                                      20470000
          while (temp:=temp+1) <= npa do                                20475000
            begin                                                       20480000
              psegmap(temp):=(temp-1)&lsl(8)+14;                        20485000
            end; <<while>>                                              20490000
        end;                                                            20495000
      <<create user entry in lst>>                                      20500000
      tempkey:=progkey;           <<save parms for later>>              20505000
      tempmode:=mpmode;                                                 20510000
      temptype:=progfile;                                               20515000
    end;                                                                20520000
  tos:=posit+psegmap(0)+1;  <<length>>                                  20525000
  tos:=temptype;            <<type>>                                    20530000
  tos:=tempmode;            <<mode>>                                    20535000
  tos:=mlibsearch;          <<lib>>                                     20540000
  tos:=tempkey;             <<key>>                                     20545000
  exchangedb(segtabdst);          <<db to lst>>                         20550000
  lcreate(*,*,*,*,*);             <<create user entry>>                 20555000
  if < then go noroom;            <<error>>                             20560000
  tos:=@entp;                     <<entry>>                             20565000
  exchangedb(0);                  <<db to stack>>                       20570000
  <<move data to entry>>                                                20575000
  tos:=segtabdst;                                                       20580000
  assemble(xch);                                                        20585000
  if procload' then                                                     20590000
    begin                         <<procedure>>                         20595000
      tos:=tos+3;                 <<offset into entry>>                 20600000
      tos:=@workarea+3;           <<data>>                              20605000
      tos:=posit-3;               <<count>>                             20610000
    end else                                                            20615000
    begin                         <<program>>                           20620000
      tos:=tos+3;                 <<offset into entry>>                 20625000
      tos:=@workarea+3;           <<data>>                              20630000
      tos:=posit-3;               <<count>>                             20635000
    end;                                                                20640000
  assemble (mtds 2);    <<move slinfo data>>                            20645000
  <<move psegmap array>>                                                20650000
  tos:=@psegmap;  <<source>>                                            20655000
  tos:=psegmap(0)+1; <<count>>                                          20660000
  assemble(mtds 4);                                                     20665000
  <<update sl tables>>                                                  20670000
  slnr:=mlibsearch+1;                                                   20675000
  while (slnr:=slnr-1) >=0 do                                           20680000
   begin                         <<cycle thru each sl>>                 20685000
    if nsla(slnr) <> 0 or  <<segs loaded?>>                             20690000
       allocproc' and      <<or allocate procedure?>>                   20695000
       slnr = 0 then       <<and slnr=sys sl?>>                         20700000
      begin                     <<segs allocated>>                      20705000
        <<build 2 word seg list entry for each  >>                      20710000
        <<loaded segment                        >>                      20715000
        posit:=0;                                                       20720000
        @segptr:=sldatabase(slnr);                                      20725000
        while @segptr <> 0 do                                           20730000
         begin        <<cycle thru ref'ed segs>>                        20735000
          if segptr(dbnewflag) = 1 then                                 20740000
            begin    <<seg just allocated>>                             20745000
              tos:=segptr(dbflags); <<a,c,x,m bits>>                    20750000
              tos.(0:8):=segptr(dblogseg); <<log seg #>>                20755000
              workarea(posit):=tos;                                     20760000
              workarea(posit+1):=segptr(dbphycst);                      20765000
              posit:=posit+2;                                           20770000
            end;                                                        20775000
          if allocproc' and                                             20780000
             segptr(dblbit)=1 then                                      20785000
            begin        <<seg is being allocated>>                     20790000
              <<save log seg # for use later>>                          20795000
              saveallocseg:=segptr(dblogseg);                           20800000
              saveallocseg.(0:1):=1;<<force <> 0>>                      20805000
            end;                                                        20810000
          @segptr:=segptr(segnext);                                     20815000
         end; <<while>>                                                 20820000
        <<update sl entry in lst>>                                      20825000
        slloaded:=0;                                                    20830000
        slkey':=slkey(slnr);                                            20835000
        slpvinfo':=slpvinfo(slnr);                                      20840000
        exchangedb(segtabdst);  <<db to lst>>                           20845000
        if not lsearch(slkey',normal,slfile) then                       20850000
          begin                 <<sl entry must be created>>            20855000
            tos:=posit&lsr(1)+10; <<#seg list entries>>                 20860000
            if s0>255 then                                              20865000
              begin               <<too many>>                          20870000
                assemble(del);                                          20875000
                tos:=255;                                               20880000
              end;                                                      20885000
            tos:=tos*3+21;        <<length of entry>>                   20890000
            lcreate(*,slfile,normal,0,slkey');                          20895000
            if < then                                                   20900000
              begin               <<error no room>>                     20905000
                lsearch'(tempkey,tempmode,temptype);           <<06541>>20910000
                ldelete;  <<find user entry and delete>>                20915000
                go noroom;                                              20920000
              end;                                                      20925000
            loadbit(slkey',true,segtabdst);                             20930000
            if < then                                                   20935000
              begin               <<error>>                             20940000
                lsearch'(tempkey,tempmode,temptype);           <<06541>>20945000
                ldelete;  <<find user entry and delete>>                20950000
                tos:=err72;                                             20955000
                go nfg;                                                 20960000
              end;                                                      20965000
            slloaded:=-1;         <<sl loaded flag>>                    20970000
            <<initialize sl entry>>                                     20975000
            tos:=posit&lsr(1)+10;                                       20980000
            if s0 > 255 then                                            20985000
              begin                                                     20990000
                assemble(del);                                          20995000
                entp(4):=255;                                           21000000
              end else                                                  21005000
              begin                                                     21010000
                entp(4):=tos;                                           21015000
              end;                                                      21020000
            tos:=@entp+5;          <<ptr to seg array>>                 21025000
            clearbitmap(*);        <<clear seg array>>                  21030000
            <<set all seglist entries as free>>                         21035000
            temp:=entp(4)*3;                                            21040000
            while (temp:=temp-3) >=0 do                                 21045000
              begin                                                     21050000
                entp3(temp):=%177400;                                   21055000
                entp3(temp+1):=0;                                       21060000
                entp3(temp+2):=0;                                       21065000
              end;                                                      21070000
          end;                                                          21075000
        <<sl entry exists - update it >>                                21080000
        epvinfo'sl:=slpvinfo';     <<pv info >>                         21085000
        <<insure sufficient free seglist entries exist>>                21090000
        temp:=posit&lsr(1)-(eslseg'sl-eallocseg'sl);<<#needed>>         21095000
        if temp > 0 then                                                21100000
          begin              <<seg list must be expanded>>              21105000
            if eslseg'sl+temp+10 > 255                                  21110000
              then temp:=255-eslseg'sl                                  21115000
              else temp:=temp+10;                                       21120000
            expandseglist;                                              21125000
            if temp = 0 then                                            21130000
              begin          <<error no room>>                          21135000
                lsearch'(tempkey,tempmode,temptype);           <<06541>>21140000
                ldelete;  <<find user entry and delete>>                21145000
                go noroom;                                              21150000
              end;                                                      21155000
          end;                                                          21160000
        <<sufficient seg list entries exist>>                           21165000
        <<add allocated seg to seglist>>                                21170000
        sl:=@entp3;          <<save pointer>>                           21175000
        temp:=-2;                                                       21180000
        while (temp:=temp+2) < posit do                                 21185000
          begin              <<cycle thru workarea>>                    21190000
            while entp3.(0:8) <> 255                                    21195000
              do @entp3:=@entp3+3;                                      21200000
            <<found free entry>>                                        21205000
            entp3(0):=workarea(temp); <<logseg,flags>>                  21210000
            entp3(2):=workarea(temp+1);<<cst #>>                        21215000
            <<set allocated bit in seg array>>                          21220000
            tos:=@entp+5; <<ptr to seg array>>                          21225000
            tos:=workarea(temp).(0:8); <<log seg #>>                    21230000
            setbit(*,*);  <<set the bit>>                               21235000
            @entp3:=@entp3+3;                                           21240000
            <<increment # allocated segs in sl>>                        21245000
            eallocseg'sl:=eallocseg'sl+1;                               21250000
          end; <<while>>  <<next workarea entry>>                       21255000
        if allocproc' and                                               21260000
           saveallocseg <> 0 then                                       21265000
          begin           <<allocate procedure and>>                    21270000
                          <<seg needs "A" bit set>>                     21275000
            @entp3:=sl;   <<head of seglist>>                           21280000
            while entp3.(0:8) <> saveallocseg.(8:8)                     21285000
              do @entp3:=@entp3+3;                                      21290000
            <<found seglist entry--set "A" bit>>                        21295000
            entp3.(12:1):=1;                                            21300000
          end;                                                          21305000
        @entp3:=sl;    <<restore value>>                                21310000
        <<lst has been updated for this sl>>                            21315000
        exchangedb(0);    <<db to stack>>                               21320000
        nsla(slnr):=slloaded; <<save flag>>                             21325000
      end;                                                     <<06094>>21330000
   end; <<while>>  <<next sl>>                                          21335000
  if procload' and not(allocproc') then                                 21340000
    begin          <<load procedure>>                                   21345000
      <<update loadprocmaster entry in lst>>                            21350000
      <<set up for split stack operations on loadprocmaster>>           21355000
      numbmcst:=maxmcstidx;                                             21360000
      lprockey:=double(mpin); <<key>>                                   21365000
      lproclen:=35+(numbmcst+1)&lsl(1)+numbslid&lsl(1);<<lgth>>         21370000
      <<setup for moves in split stack>>                                21375000
      tos:=@lprocmastertab(64)-@dlarea2; <<dl relative>>                21380000
      tos:=(numbmcst+1)&lsl(1); <<count for move 2>>                    21385000
      tos:=@lprocmastertab-@dlarea2; <<dl relative>>                    21390000
       tos:=35+numbslid&lsl(1);  <<count for move 1>>                   21395000
      exchangedb(segtabdst);                                            21400000
      <<find current  loadprocmaster entry in lst>>                     21405000
      if lsearch(lprockey,normal,loadprocmaster) then                   21410000
        begin     <<found entry>>                                       21415000
          if rlength < lproclen+3 then                                  21420000
            begin <<entry too small--create new one>>                   21425000
              temp:=@entp;  <<save ptr>>                                21430000
              lcreate(lproclen,loadprocmaster,                          21435000
                               normal,0,lprockey);                      21440000
              if < then                                                 21445000
                begin    <<no room>>                                    21450000
                  lsearch'(tempkey,tempmode,temptype);         <<06541>>21455000
                  ldelete;                                              21460000
                  go noroom;                                            21465000
                end;                                                    21470000
              tos:=@entp;  <<save ptr>>                                 21475000
              @entp:=temp; <<ptr to old loadprocmaster entry>>          21480000
              ldelete;                                                  21485000
              @entp:=tos;<<restore ptr to new loadprocmaster>>          21490000
            end;                                                        21495000
          <<move lprocmastertab to lst>>                                21500000
          tos:=@entp;                                                   21505000
          assemble(cab,cab); <<target,source,count>>                    21510000
          assemble(mvlb 3);  <<move mcstidx,slid array>>                21515000
          tos:=@entp+35+eslid'lproc&lsl(1);                             21520000
          assemble(cab,cab); <<target,source,count>>                    21525000
          assemble(mvlb 3);  <<move mcstlogseg array>>                  21530000
        end                                                             21535000
       else                                                             21540000
        begin     <<did not find loadprocmaster>>                       21545000
          suddendeath(348);                                             21550000
        end;                                                            21555000
    end                                                                 21560000
   else                                                                 21565000
    begin       <<load/allocate program or allocate procedure>>         21570000
      exchangedb(segtabdst);                                            21575000
    end;                                                                21580000
                                                                        21585000
  <<update tables for user entry>>                                      21590000
  lsearch'(tempkey,tempmode,temptype);                         <<06541>>21595000
  adjrefcounts(1); <<increment ref counts>>                             21600000
  exchangedb(0);                                                        21605000
  tos := cce;  <<ok condition code>>                                    21610000
  go getout;                                                            21615000
                                                                        21620000
  noroom:                                                               21625000
  tos := err70;                                                         21630000
                                                                        21635000
  nfg:                                                                  21640000
  exchangedb(0);  <<reset db to stack>>                                 21645000
  merror := tos;  <<error nr.>>                                         21650000
                                                                        21655000
  tos := ccl;  <<error condition code>>                                 21660000
                                                                        21665000
  getout:                                                               21670000
  condcode:=tos; <<condition code>>                                     21675000
 end;                                                                   21680000
$page                                                                   21685000
procedure rel'resources;                                                21690000
  <<release resources acquired during aborted load>>                    21695000
  begin                                                                 21700000
    integer pointer segptr;                                             21705000
    <<release allocated cst's>>                                         21710000
    if logical(cstsallocated) then                                      21715000
      begin          <<cst's were allocated>>                           21720000
        slnr:=mlibsearch+1;                                             21725000
        while (slnr:=slnr-1) >= 0 do                                    21730000
          begin      <<each sl>>                                        21735000
            @segptr:=sldatabase(slnr);                                  21740000
            while @segptr <> 0 do                                       21745000
              begin                                                     21750000
                if segptr(dbnewflag) = 1                                21755000
                  then returnentry(1,segptr(dbphycst));                 21760000
                @segptr:=segptr(segnext);                               21765000
              end; <<while>>                                            21770000
          end; <<while>>                                                21775000
      end;                                                              21780000
                                                                        21785000
    <<release cst block>>                                               21790000
    if logical(cstblockallocated)                                       21795000
      then dealcstblock(cstbx);                                         21800000
                                                                        21805000
    <<release segmap>>                                                  21810000
    if segmapdst <> 0 then                                              21815000
      begin               <<dst exists>>                                21820000
        if progload                                                     21825000
          then reldataseg(segmapdst)                                    21830000
          else if newsegmapflag = 1                                     21835000
                 then reldataseg(segmapdst);                            21840000
      end;                                                              21845000
                                                                        21850000
                                                                        21855000
    <<reset program loaded flag>>                                       21860000
    if logical(progloadbit)                                             21865000
      then loadbit(progkey,0,0);                                        21870000
                                                                        21875000
    <<reset sl loaded flag - except sys sl>>                            21880000
    slnr:=mlibsearch+1;                                                 21885000
    while (slnr:=slnr-1) > 0 do                                         21890000
      begin                                                             21895000
        if nsla(slnr) = -1                                              21900000
          then loadbit(slkey(slnr),0,0);                                21905000
      end; <<while>>                                                    21910000
  end; <<rel'resources>>                                                21915000
$page                                                                   21920000
procedure awake'waiting'pins;                                           21925000
  <<awake pins waiting for program load>>                               21930000
  begin                                                                 21935000
    double lctdback',progkey';                                          21940000
    integer mpmode',waitingpin';                                        21945000
    <<get data into local variables>>                                   21950000
    lctdback':=lctdback; <<starting cst & error #>>                     21955000
    progkey':=progkey;     <<prog file key         >>                   21960000
    mpmode':=mpmode;       <<prog mode             >>                   21965000
    exchangedb(segtabdst);                                              21970000
    while lsearch(progkey',mpmode',waiting) do                          21975000
      begin                                                             21980000
        <<found pin waiting on this prog load>>                         21985000
        waitingpin':=ewaitingpin; <<pin #>>                             21990000
        ldelete;           <<delete waiting entry>>                     21995000
        <<create loaded entry for waiting pin>>                         22000000
        lcreate(5,loaded,mpmode',0,progkey');                           22005000
        entdp2:=lctdback';<<insert load status>>                        22010000
        unimpede(waitingpin'*pcbsize); <<awake pin>>                    22015000
      end; <<while>>                                                    22020000
    <<delete loading entry for pin which started prog load>>            22025000
    if lsearch(progkey',mpmode',loading) then ldelete;                  22030000
    exchangedb(0);                                                      22035000
  end; <<awake'waiting'pins>>                                           22040000
procedure init'segtabdstx;                                     <<06541>>22045000
                                                               <<06541>>22050000
<< this procedure initializes extra dst. it has the same >>    <<06541>>22055000
<< format as lst so that all the lst procedure can be    >>    <<06541>>22060000
<< used. the extra dst is for extension entries only.    >>    <<06541>>22065000
<< db is in extra dst while this procedure is called.    >>    <<06541>>22070000
                                                               <<06541>>22075000
begin                                                          <<06541>>22080000
   @dir:=128+38;                                               <<06541>>22085000
   dirlen := dsti(segtabdst'ex*4).(3:13)*4-38-128;             <<06541>>22090000
   @sbuf0 := 38;                                               <<06541>>22095000
   @entp := hdfwdlink(garbage) := hdbkwdlink(garbage)          <<06541>>22100000
         := @dir+3;                                            <<06541>>22105000
   fwdlink := bkwdlink := 0;                                   <<06541>>22110000
   etype := garbage;                                           <<06541>>22115000
   rlength := dirlen;                                          <<06541>>22120000
end;                                                           <<06541>>22125000
<<----------------------------------------->>                           22130000
<<                                         >>                           22135000
<<        main program                     >>                           22140000
<<                                         >>                           22145000
<<----------------------------------------->>                           22150000
                                                                        22155000
$page                                                                   22160000
    turnofftraps;                                                       22165000
    push(dl);                                                           22170000
    dlsze := tos;                                                       22175000
    <<get pointer to lct>>                                              22180000
    tos:=@lctoffset;       <<receive lct offset>>                       22185000
    tos:=segtabdst;        <<lst>>                                      22190000
    tos:=lctptr;           <<offset to lctptr>>                         22195000
    tos:=1;                <<1 word>>                                   22200000
    assemble(mfds 4);                                                   22205000
    <<move info from lct to lctbuf>>                                    22210000
    tos:=@lctbuf;         <<receive request>>                           22215000
    tos:=segtabdst;        <<lst>>                                      22220000
    tos:=lctoffset;        <<offset to lct in lst>>                     22225000
    tos:=lctlength;       <<transfer size>>                             22230000
    assemble(mfds 4);                                                   22235000
                                                                        22240000
    << open the system sl >>                                            22245000
                                                                        22250000
    tos := 0d;                                                          22255000
    tos := abs(sslkeya);                                                22260000
    tos := abs(xreg:=xreg+1);  <<system sl key>>                        22265000
    slkey(0):=ds1;                                                      22270000
    s2 := bs1;   <<extract the logical device>>                         22275000
    bs1 := 0;                                                           22280000
    slfnum(0):=fopenda(*,*,%(2)111110110);                              22285000
    if  <>  then                                                        22290000
       begin                                                            22295000
         ferror(0);                                                     22300000
         go returnlct;                                                  22305000
       end;                                                             22310000
                                                                        22315000
    << get an extra dst for lst extension >>                   <<06541>>22320000
    << size of the xdst is the same as lst>>                   <<06541>>22325000
                                                               <<06541>>22330000
    tos := 0;                                                  <<06541>>22335000
    tos := dsti(segtabdst*4).(3:13)*4;  << lst size >>         <<06541>>22340000
    tos := dsti(segtabdst*4+1).(9:7)*%1000; << lst vm >>       <<06541>>22345000
    tos := getdatasegc(*,*);                                   <<06541>>22350000
    segtabdst'ex := tos;                                       <<06541>>22355000
    exchangedb(segtabdst'ex);                                  <<06541>>22360000
    init'segtabdstx;                                           <<06541>>22365000
    exchangedb(0);                                             <<06541>>22370000
                                                                        22375000
    << open the loadlist file >>                                        22380000
                                                                        22385000
retrylist:                                                              22390000
    listfnum := fopen(listdesig,%2001,%304);                            22395000
    if  <  then                                                         22400000
       begin  << error, or must build the file >>                       22405000
         fcheck(listfnum,listfnum);                                     22410000
         if  <>  or  listfnum <> 52  then                               22415000
            begin                                                       22420000
listerr:                                                                22425000
              tos := err54;                                             22430000
              go nfg;                                                   22435000
            end;                                                        22440000
         listfnum := fopen(listdesig,%2104,4,36);                       22445000
         if  <>  then  go listerr;                                      22450000
         fclose(listfnum,1,0);                                          22455000
         if  <>  then  go listerr;                                      22460000
         go retrylist;                                                  22465000
       end;                                                             22470000
    fgetinfo(listfnum,,,,,,,,,,,,,,,,,,,listaddr);                      22475000
    if  <>  then  go listerr;                                           22480000
                                                                        22485000
    <<get cache data segment>>                                          22490000
    loadcacheseg:=getdataseg(bucket0+nbuckets*bucketsize,0);            22495000
    initloadcache;                                                      22500000
assemble(adds 1);                                              <<*7545>>22505000
receivemsg(4,1,%40000);                                        <<*7909>>22510000
if tos<>load'message then                                      <<*7545>>22515000
   suddendeath(347);                                           <<*7545>>22520000
                                                                        22525000
l:   <<  restart here >>                                                22530000
    push( dl );                                                         22535000
    @dlarea2 := s0;                                                     22540000
    @dlavail := tos;                                                    22545000
    @dlarea1 := -sysdl;                                                 22550000
                                                                        22555000
    <<* * * extract command from lct * * *>>                            22560000
                                                                        22565000
    savesir := getsir(segtabsir);                              <<*8527>>22570000
    tos:=@lctbuf;         <<receive request>>                           22575000
    tos:=segtabdst;        <<lst>>                                      22580000
    tos:=lctoffset;        <<offset to lct in lst>>                     22585000
    tos:=lctlength;       <<transfer size>>                             22590000
    assemble(mfds 4);                                                   22595000
    relsir(segtabsir,savesir);                                 <<*8527>>22600000
                                                                        22605000
    <<initialize variables>>                                            22610000
                                                                        22615000
    pcbpt := mpin * pcbsize;                                            22620000
    savesir:=-1;                                                        22625000
    listflag:=false;                                                    22630000
    lctdback:=0d;                                                       22635000
    sldatabase(0):=0;                                                   22640000
    move sldatabase(1):=sldatabase(0),(15);                             22645000
    sldb'seg'dir(0):=0;                                                 22650000
    move sldb'seg'dir(1):=sldb'seg'dir(0),(255);                        22655000
    globalflags:=0;                                                     22660000
    nsla(0):=0;                                                         22665000
    move nsla(1):=nsla(0),(15);                                         22670000
    npa:=0;                                                             22675000
    oldsegmapdst:=0;                                                    22680000
    segmapdst := if progload or allocproc then 0                        22685000
       else spcbmapdst;                                                 22690000
    needsegmap:=false;                                                  22695000
    drtrecd:=0d;                                                        22700000
    slfnum(1):=0;                                                       22705000
    move slfnum(2):=slfnum(1),(14);                                     22710000
    progfnum:=0;                                                        22715000
    loaddomain:=mloaddomain;                                            22720000
                                                                        22725000
    <<clear list file>>                                                 22730000
                                                                        22735000
    clearline;                                                          22740000
    fcontrol(listfnum,5,listflag);                                      22745000
    if  <>  then                                                        22750000
       begin                                                            22755000
         tos := err64;                                                  22760000
         go nfg;                                                        22765000
       end;                                                             22770000
                                                                        22775000
    <<* * * process command * * *>>                                     22780000
                                                                        22785000
    if procload                                                         22790000
      then satisfyproc  <<satisfy procedure external>>                  22795000
      else satisfyprog; <<satisfy program externals >>                  22800000
    if < then go recover; <<error>>                                     22805000
    savesir:=getsir(segtabsir);                                         22810000
    addsegdata'sldb; <<complete sldatabase for sl segs>>                22815000
    if < then go recover; <<error>>                                     22820000
    loadexternals;   <<load sl segs>>                                   22825000
    if < then go recover; <<error>>                                     22830000
    if progload then                                                    22835000
      begin          <<load/allocate program>>                          22840000
        addprogdata'sldb; <<complete sldatabase for prog segs>>         22845000
        if < then go recover; <<error>>                                 22850000
        loadprogram; <<load program segs>>                              22855000
        if < then go recover; <<error>>                                 22860000
      end;                                                              22865000
    updatesegtab;    <<update loader segment table>>                    22870000
    if < then go recover; <<error>>                                     22875000
    if procload then                                           <<06541>>22880000
       begin                                                   <<06541>>22885000
          trans'lst'to'xdst;                                   <<06541>>22890000
          if <> then                                           <<06541>>22895000
             begin                                             <<06541>>22900000
               cstsallocated := 0;                                      22905000
                tos:=err70;                                    <<06541>>22910000
                go to nfg;                                     <<06541>>22915000
             end;                                              <<06541>>22920000
       end;                                                    <<06541>>22925000
                                                                        22930000
returnlct:                                                              22935000
                                                                        22940000
    <<wake up waiting processes>>                                       22945000
    if progload then                                                    22950000
      begin         <<load/allocate program>>                           22955000
        awake'waiting'pins;                                             22960000
      end;                                                              22965000
                                                                        22970000
    <<release resources>>                                               22975000
                                                                        22980000
    if savesir <> -1 then relsir(segtabsir,savesir);                    22985000
    funlock(slfnum(0)); <<unlock sys sl>>                               22990000
                                                                        22995000
    <<close sl files except sys sl>>                                    23000000
    slnr:=mlibsearch+1;                                                 23005000
    while (slnr:=slnr-1) > 0 do                                         23010000
      begin                                                             23015000
        if slfnum(slnr) <> 0 then fclose(slfnum(slnr),0,0);             23020000
      end; <<while>>                                                    23025000
                                                                        23030000
    <<close program file>>                                              23035000
    if progfnum <> 0 then fcloseda(progfnum,0,0);                       23040000
    if procload and newsegmapflag = 1 then                              23045000
       begin <<segmapdst was switched during load--update pcb>>         23050000
       adjustlocality(pcbpt,double(oldsegmapdst),0,1);         <<07300>>23055000
       reldataseg( oldsegmapdst ); <<release old dst>>                  23060000
       spcbmapdst := segmapdst;    <<update pcb>>                       23065000
       tos := pcb(pcbpt+sllixwordnum);                                  23070000
       tos := double(segmapdst);                               <<06641>>23075000
       setsysdb;                                                        23080000
       addtolocality( *, *, %400 );                                     23085000
       resetdb( -1 );                                                   23090000
       end;                                                             23095000
                                                                        23100000
    <<* * * insert answer in lct * * *>>                                23105000
                                                                        23110000
    lctanswer:=mferror;                                                 23115000
    lcterror:=merror;                                                   23120000
    lctlistflag:=listflag;                                              23125000
    lctlmapldev:=listaddr1.(0:8);  <<ldev>>                             23130000
    lctlmaphida:=listaddr1.(8:8);  <<disk>>                             23135000
    lctlmaploda:=listaddr2;        <<addr>>                             23140000
                                                               <<*8527>>23145000
    savesir := getsir(segtabsir);                              <<*8527>>23150000
    tos:=segtabdst;        <<lst>>                                      23155000
    tos:=lctoffset;        <<offset to lct in lst>>                     23160000
    tos:=@lctbuf;         <<addr of lctbuf>>                            23165000
    tos:=lctlength;       <<transfer size>>                             23170000
    assemble(mtds 4);                                                   23175000
    relsir(segtabsir,savesir);                                 <<*8527>>23180000
                                                               <<*8527>>23185000
    if listflag then fcontrol(listfnum,6,listflag);<< eof >>            23190000
    absolute(syswaittodispmsg).phasetransflag := 1;            <<06094>>23195000
tos:=load'done'message;                                        <<*7545>>23200000
awake(wproc,%20,0);                                            <<*7545>>23205000
sendmsg(wproc/pcbsize,4,1,%40000);                             <<*7909>>23210000
assemble(adds 1);                                              <<*7545>>23215000
receivemsg(4,1,%40000);                                        <<*7909>>23220000
if tos<>load'message then                                      <<*7545>>23225000
   suddendeath(347);                                           <<*7545>>23230000
    push(dl);                                                           23235000
    if tos <> dlsze  then  dlsize(dlsze);                               23240000
    go l;  << process the next request >>                               23245000
    <<error recovery and cleanup>>                                      23250000
nfg:                                                                    23255000
    merror:=tos; <<error #>>                                            23260000
recover:                                                                23265000
    if savesir=-1 then savesir:=getsir(segtabsir);                      23270000
    rel'resources; <<release acquired resources>>                       23275000
    go returnlct; <<finish>>                                            23280000
    help;                                                               23285000
  end.                                                                  23290000
