$CONTROL USLINIT,MAP,CODE                                               00010000
<< loader1 - module 72 >>                                               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 LOADER UTILITIES"                                      00055000
$control segment=loader1                                                00060000
$control privileged                                            <<06102>>00065000
$thirty                                                                 00070000
begin                                                                   00075000
$page                                                                   00080000
                                                                        00085000
                                                                        00090000
<<********************************************>>               <<06102>>00095000
<<                                            >>               <<06102>>00100000
<< the loader1 module had been rewritten for  >>               <<06102>>00105000
<< the cst expansion project and integrated   >>               <<06102>>00110000
<< into mpe v.             january, 1983      >>               <<06102>>00115000
<<                                            >>               <<06102>>00120000
<<********************************************>>               <<06102>>00125000
$page                                                                   00130000
                                                                        00135000
<<----------------------------------------------------------->>         00140000
<<                                                           >>         00145000
<<                    loader intrinsics                      >>         00150000
<<                                                           >>         00155000
<<----------------------------------------------------------->>         00160000
                                                                        00165000
<<error numbers>>                                                       00170000
                                                                        00175000
equate err20 = 20,  <<illegal library search>>                          00180000
       err21 = 21,  <<unknown entry point>>                             00185000
       err22 = 22,  <<trace sybsystem not present>>                     00190000
       err23 = 23,  <<stack size too small>>                            00195000
       err24 = 24,  <<max. data > 32k>>                                 00200000
       err25 = 25,  <<data segment > max data segment>>                 00205000
       err26 = 26,  <<program loaded in opposite mode>>                 00210000
       err27 = 27,  <<sl binding error>>                                00215000
       err28 = 28,  <<invalid system sl file>>                          00220000
       err29 = 29,  <<invalid public sl file>>                          00225000
       err30 = 30,  <<invalid group sl file>>                           00230000
       err31 = 31,  <<invalid program file>>                            00235000
       err32 = 32,  <<invalid list file>>                               00240000
       err33 = 33,  <<code segment > system max.>>                      00245000
       err34 = 34,  <<program uses more than one extent>>               00250000
       err35 = 35,  <<data segment > 32k>>                              00255000
       err36 = 36,  <<data segment > system max.>>                      00260000
       err37 = 37,  <<nr. code segments > 63>>                          00265000
       err38 = 38,  <<nr. code segments > system max.>>                 00270000
       err39 = 39,  <<illegal capability>>                              00275000
       err40 = 40,  <<too many procedures loaded>>                      00280000
       err41 = 41,  <<unknown procedure name>>                          00285000
       err42 = 42,  <<invalid procedure number>>                        00290000
       err43 = 43,  <<illegal procedure unload>>                        00295000
       err44 = 44,  <<illegal sl capability>>                           00300000
       err45 = 45,  <<invalid entry point>>                             00305000
       err46 = 46,  <<illegal to allocate temp prog file>>     <<06102>>00310000
       err50 = 50,  <<unable to open system sl file>>                   00315000
       err51 = 51,  <<unable to open public sl file>>                   00320000
       err52 = 52,  <<unable to open group sl file>>                    00325000
       err53 = 53,  <<unable to open program file>>                     00330000
       err54 = 54,  <<unable to open list file>>                        00335000
       err55 = 55,  <<unable to close system sl file>>                  00340000
       err56 = 56,  <<unable to close public sl file>>                  00345000
       err57 = 57,  <<unable to close group sl file>>                   00350000
       err58 = 58,  <<unable to close program file>>                    00355000
       err59 = 59,  <<unable to close list file>>                       00360000
       err60 = 60,  <<eof or i/o error on system sl file>>              00365000
       err61 = 61,  <<eof or i/o error on public sl file>>              00370000
       err62 = 62,  <<eof or i/o error on group sl file>>               00375000
       err63 = 63,  <<eof or i/o error on program file>>                00380000
       err64 = 64,  <<eof or i/o error on list file>>                   00385000
       err65 = 65,  <<unable to obtain cst entries>>                    00390000
       err66 = 66,  <<unable to obtain process dst entry>>              00395000
       err67 = 67,  <<unable to obtain mail data segment>>              00400000
       err68 = 68,  <<unable to obtain working set>>                    00405000
       err70 = 70,  <<segment table overflow>>                          00410000
       err71 = 71,  <<unable to obtain sufficient dl storage>>          00415000
       err72 = 72,  <<attio error>>                                     00420000
       err73 = 73,  <<unable to obtain virtual memory>>                 00425000
       err74 = 74,  <<directory i/o error>>                             00430000
       err75 = 75,  <<print i/o error>>                                 00435000
       err76 = 76,  <<illegal dlsize>>                                  00440000
       err80 = 80,  <<program already allocated>>                       00445000
       err81 = 81,  <<illegal program allocation>>                      00450000
       err82 = 82,  <<program not allocated>>                           00455000
       err83 = 83,  <<illegal program deallocation>>                    00460000
       err84 = 84,  <<procedure already allocated>>                     00465000
       err85 = 85,  <<illegal procedure allocation>>                    00470000
       err86 = 86,  <<procedure not allocated>>                         00475000
       err87 = 87,  <<illegal procedure deallocation>>                  00480000
       warn88= 88,  <<lmap not available>>                              00485000
       warn89= 89,  <<load with lib=s>>                                 00490000
       warn90= 90,  <<load with lib=p>>                                 00495000
       warn91= 91,  <<load with lib=g>>                                 00500000
       err92 = 92,  <<allocate/deallocate from non-system disc <<e9061>>00505000
       err93 = 93,  <<unable to mount prog's home vol. set>>   <<06102>>00510000
       err94 = 94,  <<unable to mount sys sl's h.v.s.>>        <<06102>>00515000
       err95 = 95,  <<unable to mount private sl's h.v.s.>>    <<06102>>00520000
       err96 = 96,  <<unable to mount group sl's h.v.s.>>      <<06102>>00525000
       err97 = 97,  <<unable to load remote program>>                   00530000
       err98 = 98,  <<unable to convert old format>>                    00535000
       err99 = 99,  <<unable to obtain dst for logical map>>            00540000
       err100=100,  <<too many mapped segments>>                        00545000
       err101=101,  <<segmap too big>>                                  00550000
       err102=102,  <<unable to expand segmap>>                         00555000
       err103=103;  <<too many dynamic loads on procedure>>             00560000
$page                                                                   00565000
<<--------------------------------------------------------->>           00570000
<<                                                         >>           00575000
<< miscellaneous definitions                               >>           00580000
<<                                                         >>           00585000
<<--------------------------------------------------------->>           00590000
define asmb           = assemble#,                                      00595000
       abs            = absolute#,                                      00600000
       pdisable       = asmb(psdb)#,                                    00605000
       penable        = asmb(pseb)#,                                    00610000
       disable        = asmb(sed 0)#,                                   00615000
       enable         = asmb(sed 1)#,                                   00620000
       setbit0        = assemble(tsbc 0)#,                              00625000
       condcode       = status.(6:2)#,                                  00630000
       turnofftraps   = push(status);                                   00635000
                        tos.(2:1):=0;                                   00640000
                        set(status)#;                                   00645000
equate ccg            = 0,                                              00650000
       ccl            = 1,                                              00655000
       cce            = 2;                                              00660000
integer xreg          = x;                                              00665000
logical lxreg         = x;                                              00670000
integer status        = q-1;                                            00675000
byte bs1              = s-1,                                            00680000
     bs2              = s-2;                                            00685000
integer s0            = s-0,                                            00690000
        s1            = s-1,                                            00695000
        s2            = s-2,                                            00700000
        s3            = s-3,                                            00705000
        s4            = s-4,                                            00710000
        s5            = s-5,                                            00715000
        s6            = s-6;                                            00720000
logical ls0           = s-0;                                            00725000
double ds1            = s-1,                                            00730000
       ds2            = s-2,                                            00735000
       ds3            = s-3;                                            00740000
byte pointer bps0     = s-0,                                            00745000
             bps1     = s-1;                                            00750000
integer pointer ps0   = s-0,                                            00755000
                ps1   = s-1;                                            00760000
double pointer dps0   = s-0;                                            00765000
integer array dbarea(*) = db+0;                                         00770000
equate load'done'message = %777,                               <<*7558>>00775000
       load'message = %111;                                    <<*7558>>00780000
<<--------------------------------------------------------->>           00785000
<<                                                         >>           00790000
<< system definitions                                      >>           00795000
<<                                                         >>           00800000
<<--------------------------------------------------------->>           00805000
equate logflag        = %1167,  <<logging flag             >>           00810000
       sslkeya        = %1126,  <<system sl file key       >>           00815000
       maxdataseg     = %1107,  <<max data seg size        >>           00820000
       maxcodeseg     = %1106,  <<max # prog file code segs>>           00825000
       maxcode        = %1105,  <<max code seg size        >>           00830000
       defaultdataseg = %1110;  <<default stack size       >>  <<06280>>00835000
integer pointer dsti  = 2;      <<sysglob ptr to dst       >>           00840000
pointer pcb           = 3,      <<sysglob ptr to pcb       >>           00845000
        cstext        = %51;    <<sysglob ptr to cstx      >>           00850000
equate dstb           = 2,      <<dst ptr in low fixed mem >>           00855000
       pcbb           = 3,      <<pcb ptr in low fixed mem >>           00860000
       loadsir        = 1,      <<load process sir         >>           00865000
       attioread      = 0,      <<read code                >>           00870000
       attiowrite     = 1;      <<write code               >>           00875000
define dslen          = (3:13)#,<<dst entry length field   >>           00880000
       userpin = (curprc)/pcbsize#,                            <<06648>>00885000
                                <<current pin              >>           00890000
       pcbxp          = push(dl);                                       00895000
                        tos:=tos-ps0(-2)#;<<pcbx ptr       >>           00900000
                                                                        00905000
<<--------------------------------------------------------->>           00910000
<<                                                         >>           00915000
<< loader segment table definitions                        >>           00920000
<<                                                         >>           00925000
<<--------------------------------------------------------->>           00930000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           00935000
<< global area                                             >>           00940000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           00945000
equate segtabdst = 18,          <<lst dst #                >>           00950000
       segtabsir = 17;          <<lst sir #                >>           00955000
equate numentrytype = 9;        <<# directory entry types  >>           00960000
integer array lst(*) = db+0;    <<lst                      >>           00965000
integer array dir(@) = db+0;    <<ptr to entry directory   >>           00970000
integer dirlen       = db+1;    <<directory length         >>           00975000
integer array lct(@) = db+2;    <<ptr to loader comm. tab. >>           00980000
integer pointer entp = db+3,    <<primary entry ptr        >>           00985000
                entp1= db+4,    <<secondary entry ptr      >>           00990000
                ENTP2= DB+5,    <<    "       "    "       >>           00995000
                ENTP3= DB+6;    <<    "       "    "       >>           01000000
DOUBLE POINTER ENTDP = ENTP,    <<    "       "    "       >>           01005000
               ENTDP1= ENTP1,   <<    "       "    "       >>           01010000
               ENTDP2= ENTP2,   <<    "       "    "       >>           01015000
               ENTDP3= ENTP3;   <<    "       "    "       >>           01020000
integer array sbuf0(@)=db+7;    <<disc buffer (128 words)  >>           01025000
integer si           = db+8,    <<utility integer          >>           01030000
        sj           = db+9,    <<   "       "             >>           01035000
        sk           = db+10,   <<   "       "             >>           01040000
        sl           = db+11,   <<   "       "             >>           01045000
        sm           = db+12,   <<   "       "             >>           01050000
        sn           = db+13,   <<   "       "             >>           01055000
        so           = db+14,   <<   "       "             >>           01060000
        sp           = db+15,   <<   "       "             >>           01065000
        sq           = db+16,   <<   "       "             >>           01070000
        sr           = db+17,   <<   "       "             >>           01075000
        ss           = db+18,   <<   "       "             >>           01080000
        st           = db+19;   <<   "       "             >>           01085000
integer pointer psi  = si,      <<utility ptr              >>           01090000
                pss  = ss,      <<   "     "               >>           01095000
                pst  = st;      <<   "     "               >>           01100000
double pointer dpst  = st;      <<   "     "               >>           01105000
integer array hdfwdlink(*)=db+20,<<head link for entry type>>           01110000
              hdbkwdlink(*)=hdfwdlink+numentrytype;                     01115000
                                <<tail link for entry type >>           01120000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01125000
<<  loader communication table (lct)                       >>           01130000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01135000
equate lctptr        = 2,       <<offset to lct ptr in lst >>           01140000
       lctlength     = 22;      <<length of lct            >>           01145000
<<                >>                                                    01150000
<<incoming message>>                                                    01155000
<<                >>                                                    01160000
define mallocate     = logical(lctbuf.(0:1))#,<<allocate cmd>>          01165000
       mcommand      = lctbuf.(0:2)#, <<loader command     >>           01170000
       mlibsearch    = lctbuf.(2:2)#, <<library search     >>           01175000
       mpmode        = logical(lctbuf.(4:1))#,<<load mode  >>           01180000
       mlmap         = logical(lctbuf.(6:1))#,<<load map   >>           01185000
       mpin          = lctbuf(1)#,    <<process pin        >>           01190000
       mloaddomain   = lctbuf.(5:1)#, << load domain       >>           01195000
       mprogkey      = lctbuf(2)#,    <<program file key   >>           01200000
       mprocname     = lctbuf(3)#,    <<procedure name     >>           01205000
       wproc         = lctbuf(11)#,   <<waiting process pin>>           01210000
       usercap2      = lctbuf(12)#,   <<capability         >>           01215000
       mpvinfo       = lctbuf(21)#,   <<private vol info   >>           01220000
       mextension    = lctbuf(2)#,    <<extension #        >>           01225000
       mgroup        = lctbbuf(26)#,  <<user group         >>           01230000
       macct         = lctbbuf(34)#;  <<user account       >>           01235000
define procload      = logical(mcommand)#,<<load/allocate  >>           01240000
                                          <<procedure      >>           01245000
       allocproc     = mcommand=3#,   <<allocate procedure >>           01250000
       progload      = not procload#; <<load/allocate prog >>           01255000
<<                >>                                                    01260000
<<outgoing message>>                                                    01265000
<<                >>                                                    01270000
define lctanswer     = lctbuf(0)#,<<answer from load       >>           01275000
       lcterror      = lctbuf(1)#,<<load error             >>           01280000
       lctlistflag   = lctbuf(2)#,<<load map flag          >>           01285000
       lctlmapldev   = lctbuf(3)#,<<load map ldev          >>           01290000
       lctlmaphida   = lctbuf(4)#,<<load map hi disc addr  >>           01295000
       lctlmaploda   = lctbuf(5)#;<<load map lo disc addr  >>           01300000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01305000
<< directory entry definitions                             >>           01310000
<<  (common to all entries)                                >>           01315000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01320000
equate garbage       = 0,       <<garbage entry type #     >>           01325000
       slfile        = 1,       <<sl file entry type #     >>           01330000
       progfile      = 2,       <<program file entry type #>>           01335000
       loading       = 3,       <<program loading entry typ>>           01340000
       waiting       = 4,       <<process waiting entry typ>>           01345000
       loaded        = 5,       <<process wait completed   >>           01350000
       sharer        = 6,       <<process info entry type  >>           01355000
       extension     = 7,       <<dynamic load entry type  >>           01360000
       loadprocmaster= 8;       <<master dynamic load entry>>           01365000
equate anymode       = -1,      <<wild card for entry mode >>           01370000
       normal        = 0;       <<normal (priv.) mode      >>           01375000
define fwdlink  = entp(-3)#,    <<entry forward link       >>           01380000
       bkwdlink = entp(-2)#,    <<entry backward link      >>           01385000
       rlength  = entp(-1)#,    <<region length--header +  >>           01390000
                                <<  entry + trailing excess>>           01395000
       etype    = entp.(8:8)#;  <<entry type               >>           01400000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01405000
<<  (garbage entry - type 0)                               >>           01410000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01415000
define enwg = entp(-1)#;        <<garbage entry length     >>           01420000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01425000
<<  (sl file entry - type 1)                               >>           01430000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01435000
define efid        = entdp1#,   <<file id                  >>           01440000
       efid1       = entp(1)#,  <<file id - word 1         >>           01445000
       efid2       = entp(2)#,  <<file id - word 2         >>           01450000
       epvinfo'sl  = entp(3)#,  <<private vol info         >>           01455000
       eallocseg'sl= entp(4).(0:8)#,<<# allocated seg in sl>>           01460000
       eslseg'sl   = entp(4).(8:8)#,<<# seg list entries   >>           01465000
       <<  seg list entry definitions                      >>           01470000
       sllogsegnr  = ptemp2.(0:8)#, <<sl logical seg number>>           01475000
       systemseg   = logical(ptemp2.(14:1))#, <<flags x-bit>>           01480000
       refcount    = ptemp2(1)#,    <<log seg reference cnt>>           01485000
       phycst      = ptemp2(2)#;    <<log seg's cst #      >>           01490000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01495000
<<  (program file entry - type 2)                          >>           01500000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01505000
define epmode      = entp.(0:1)#, <<program mode           >>           01510000
       epa         = entp.(1:1)#, <<allocated flag         >>           01515000
       elib        = entp.(4:4)#, <<lib search             >>           01520000
       ecstblk     = entp(3)#,    <<cstblk index           >>           01525000
       emapdst     = entp(4)#,    <<segmap dst number      >>           01530000
       eshr        = entp(5)#,    <<prog file reference cnt>>           01535000
       eseg        = entp(6).(0:8)#,<<# segs in prog file  >>           01540000
       eslinfo'prog= entp(6).(8:8)#,<<# slinfo areas       >>           01545000
       epvinfo'prog= entp(7)#,    <<private vol info       >>           01550000
       etrace'plabel=entp1(7)#,   <<trace0' external label >>           01555000
       emapsize    = entp3#;      <<# entries in map array >>           01560000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01565000
<<  (prog file loading entry - type 3)                     >>           01570000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01575000
<< no definitions unique to this entry type                >>           01580000
<<                                                         >>           01585000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01590000
<<  (process waiting entry - type 4)                       >>           01595000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01600000
define ewaitingpin = entp2#;    <<pin of waiting process   >>           01605000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01610000
<<  (loaded entry - type 5)                                >>           01615000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01620000
<< no definitions unique to this entry type                >>           01625000
<<                                                         >>           01630000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01635000
<<  (process info entry - type 6)                          >>           01640000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01645000
define epid  = entp(1)#;        <<process id               >>           01650000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01655000
<<  (dynamic load entry - type 7)                                       01660000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01665000
define eext        = entp(2)#,     <<extension #           >>  <<06280>>01670000
       epin        = entp(1)#,     <<pin #                 >>  <<06280>>01675000
       epin'ext    = entdp1#,                                           01680000
       loadproccount=entp(3)#,     <<# loadproc's this ext#>>           01685000
       loadprocname =entp(5)#,                                 <<d7968>>01690000
       eslinfo'ext = entp(6+entp(5).(4:3)).(8:8)#;             <<06280>>01695000
                                   <<# slinfo areas        >>           01700000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01705000
<<  (master dynamic load entry - type 8)                   >>           01710000
<<+++++++++++++++++++++++++++++++++++++++++++++++++++++++++>>           01715000
define eslid'lproc = entp(2).(0:8)#, <<# slid entries      >>           01720000
       active'lprocs=entp(2).(8:8)#, <<# active loadproc's >>           01725000
       emcstls'lproc=entp3.(8:8)#;   <<# mcstlogseg entries>>           01730000
                                                                        01735000
<<--------------------------------------------------------->>           01740000
<<                                                         >>           01745000
<< program file definitions                                >>           01750000
<<                                                         >>           01755000
<<--------------------------------------------------------->>           01760000
equate progfilecode  = 1029;    <<code for program file    >>           01765000
define pzerodb       = (logical(progrec0.(2:1)))#,                      01770000
                                   <<zero db area flag     >>           01775000
       pcapability   = progrec0.(6:10)#,<<capability list  >>           01780000
       pprivmode     = progrec0.(9:1)#,<<priv mode cap.    >>           01785000
       pnrsegs       = progrec0(1)#,   <<# code segments   >>           01790000
       pglobalsize   = progrec0(2)#,   <<global area size  >>           01795000
       pglobalrecd   = progrec0(3)#,   <<global area recd# >>           01800000
       psegmentrecd  = progrec0(4)#,   <<segment list recd#>>           01805000
       pstacksize    = progrec0(5)#,   <<stack size        >>           01810000
       pdlsize       = progrec0(6)#,   <<dl size           >>           01815000
       pmaxdata      = progrec0(7)#,   <<max data size     >>           01820000
       pentryrecd    = progrec0(8)#,   <<entry pt list recd>>           01825000
       pstartingseg  = progrec0(9)#,   <<starting seg #    >>           01830000
       pstartingadr  = progrec0(10)#,  <<starting pb addr  >>           01835000
       psastlt       = progrec0(11)#,  <<stlt address      >>           01840000
       psaflut       = progrec0(12)#,  <<flut address      >>           01845000
       pexternalrecd = progrec0(13)#,  <<external list recd>>           01850000
       pstartingstt  = progrec0(14)#,  <<starting stt #    >>           01855000
       psatrapcom    = progrec0(15)#;  <<trapcom address   >>           01860000
define progextstt    = (1:1)#;  <<flag in seg desc array   >>           01865000
                                <<=1 if stt in mapped form >>           01870000
<<#########################################################>>           01875000
<<  local definitions for program file                     >>           01880000
<<#########################################################>>           01885000
integer array progrec0(*) = sbuf0;<<prog file rec 0 buffer >>           01890000
<<#########################################################>>           01895000
                                                                        01900000
<<--------------------------------------------------------->>           01905000
<<                                                         >>           01910000
<< sl entry point cache definitions                        >>           01915000
<<                                                         >>           01920000
<<--------------------------------------------------------->>           01925000
define loadcacheseg  = abs(abs(%1377)+%1072)#; <<dst #     >>           01930000
equate bucketsize    = 42,      <<size of each cache bucket>>           01935000
       cachehits     = 0,       <<hit counter pointer      >>           01940000
       cachemisses   = 2,       <<miss counter pointer     >>           01945000
       bucket0       = 4,       <<first bucket pointer     >>           01950000
       nbuckets      = 95;      <<number of buckets        >>           01955000
                                                                        01960000
<<--------------------------------------------------------->>           01965000
<<                                                         >>           01970000
<< logical mapping segmap definitions                      >>           01975000
<<                                                         >>           01980000
<<--------------------------------------------------------->>           01985000
define logicalmapping = abs(%1220)#, <<true if mapping     >>           01990000
       segtabdst'ex   = abs(%1226)#,                           <<06542>>01995000
       num'progsegs   = abs(%1223)#; <<current pin's # of  >>           02000000
                                     <<program segments    >>           02005000
                                     <<firmware is present >>           02010000
integer array segmap(*) = db+0; <<segmap array             >>           02015000
$include inclpcb5                                              <<06648>>02020000
                                                                        02025000
<<--------------------------------------------------------->>           02030000
<<                                                         >>           02035000
<<  file system definitions                                >>           02040000
<<                                                         >>           02045000
<<--------------------------------------------------------->>           02050000
equate filesyssir = 37;         <<file system sir          >>           02055000
define floadbit   = flabel(28).(2:1)#; <<file loaded bit   >>           02060000
                                                                        02065000
<<--------------------------------------------------------->>           02070000
<<                                                         >>           02075000
<< procedure declarations                                  >>           02080000
<<                                                         >>           02085000
<<--------------------------------------------------------->>           02090000
                                                                        02095000
procedure loadprocedure(error,procname,loadprocid,plabel,               02100000
                          option'nums,options);                         02105000
  byte array procname;                                                  02110000
  integer array option'nums;                                            02115000
  logical array options;                                                02120000
  integer error,loadprocid,plabel;                                      02125000
  option variable,forward;                                              02130000
                                                                        02135000
procedure adjrefcounts (amount);                                        02140000
   value amount; integer amount;                                        02145000
   option forward;                                                      02150000
procedure adjseg (cstnr);                                               02155000
   value cstnr;                                                         02160000
   integer cstnr;                                                       02165000
   option internal,forward;                                             02170000
integer procedure allocateproc (procname);                              02175000
   byte array procname;                                                 02180000
   option forward;                                                      02185000
integer procedure allocateprog (progfname);                             02190000
   byte array progfname;                                                02195000
   option forward;                                                      02200000
integer procedure altdsegsize (dstnr,delta);                            02205000
   value dstnr,delta;                                                   02210000
   integer dstnr,delta;                                                 02215000
   option external;                                                     02220000
intrinsic  ascii;                                                       02225000
procedure awake (pcbindex,oldwait,newwait);                             02230000
   value pcbindex,oldwait,newwait;                                      02235000
   integer pcbindex,oldwait,newwait;                                    02240000
   option external;                                                     02245000
double procedure chek (intrinsic,flags,parms,capmask,optvmask);         02250000
   value intrinsic,flags,parms,capmask,optvmask;                        02255000
   logical intrinsic,flags,optvmask;                                    02260000
   double parms,capmask;                                                02265000
   option variable,external;                                            02270000
                                                                        02275000
double procedure chek'noabort(intrin,flags,parms,caps,optv);            02280000
  value intrin,flags,parms,caps,optv;                                   02285000
  logical intrin,flags,optv;                                            02290000
  double parms,caps;                                                    02295000
  option variable,external;                                             02300000
                                                                        02305000
integer procedure getdataseg(memsize,vdsize);                           02310000
  value memsize,vdsize;                                                 02315000
  integer memsize,vdsize;                                               02320000
  option external;                                                      02325000
                                                                        02330000
procedure resetcritical(crit);                                          02335000
  value crit;                                                           02340000
  logical crit;                                                         02345000
  option external;                                                      02350000
                                                                        02355000
logical procedure setcritical;                                          02360000
  option external;                                                      02365000
                                                                        02370000
integer procedure convextlabeltodeltap(xlabel);                         02375000
  value xlabel;                                                         02380000
  integer xlabel;                                                       02385000
  option external;                                                      02390000
                                                                        02395000
procedure addtolocality(sllinx,segid,flags);                   <<06648>>02400000
   value sllinx,segid,flags;                                   <<06648>>02405000
   integer sllinx,flags;                                       <<06648>>02410000
   double segid;                                               <<06648>>02415000
   option external;                                            <<06648>>02420000
logical procedure setsysdb;                                             02425000
   option external;                                                     02430000
procedure resetdb(where);                                               02435000
   value where;                                                         02440000
   integer where;                                                       02445000
   option external;                                                     02450000
                                                                        02455000
procedure clearbit (bitarray,bitnumber);                                02460000
   value bitnumber;                                                     02465000
   integer array bitarray;                                              02470000
   integer bitnumber;                                                   02475000
   option internal,forward;                                             02480000
procedure  dealcstblock(eix);                                           02485000
   value  eix;                                                          02490000
   integer  eix;                                                        02495000
   option  external;                                                    02500000
integer procedure deallocateproc (procname);                            02505000
   byte array procname;                                                 02510000
   option forward;                                                      02515000
integer procedure deallocateprog (progfname);                           02520000
   byte array progfname;                                                02525000
   option forward;                                                      02530000
double procedure entrykey;                                              02535000
   option internal,forward;                                             02540000
integer procedure entrylength;                                          02545000
   option internal,forward;                                             02550000
procedure errorexit (descrip,error,parm);                               02555000
   value descrip,error,parm;                                            02560000
   integer descrip,error,parm;                                          02565000
   option external;                                                     02570000
integer procedure errorget (level);                                     02575000
   value level;                                                         02580000
   integer level;                                                       02585000
   option external;                                                     02590000
procedure erroron;                                                      02595000
   option external;                                                     02600000
procedure errorput (error,level);                                       02605000
   value error,level;                                                   02610000
   integer error,level;                                                 02615000
   option external;                                                     02620000
integer procedure exchangedb (dstnr);                                   02625000
   value dstnr; integer dstnr;                                          02630000
   option external;                                                     02635000
logical procedure  faccess(fn);                                         02640000
   value fn;                                                            02645000
   integer fn;                                                          02650000
   option external;                                                     02655000
intrinsic fcheck,fcontrol;                                              02660000
procedure fclose (filenum,disposition,seccode);                         02665000
   value filenum,disposition,seccode;                                   02670000
   integer filenum,disposition,seccode;                                 02675000
   option external;                                                     02680000
procedure fgetinfo (filenum,filename,foptions,aoptions,recsize,         02685000
      devtype,ldnum,hdaddr,filecode,recptr,eof,flimit,logcount,         02690000
      physcount,blksize,extsize,numextents,userlabel,creatorid,         02695000
      diskadr);                                                         02700000
   value filenum;                                                       02705000
   integer filenum,recsize,devtype,filecode,blksize,numextents,         02710000
      userlabel;                                                        02715000
   byte array filename,creatorid;                                       02720000
   logical foptions,aoptions,ldnum,hdaddr,extsize;                      02725000
   double recptr,eof,flimit,logcount,physcount,diskadr;                 02730000
   option variable,external;                                            02735000
logical procedure findlogsegmatch;                                      02740000
  option forward;                                                       02745000
integer procedure flabio(ldev,sector,func,flab);                        02750000
   value ldev,sector,func,flab;                                         02755000
   integer ldev,func;                                                   02760000
   double sector;                                                       02765000
   logical pointer flab;                                                02770000
   option external;                                                     02775000
procedure flock (filenum,flag);                                         02780000
   value filenum,flag;                                                  02785000
   integer filenum;                                                     02790000
   logical flag;                                                        02795000
   option external;                                                     02800000
integer procedure fopen (filedesignator,foptions,aoptions,              02805000
      recsize,device,formmsg,recmode,blockfactor,numbuffers,            02810000
      filesize,numextents,initalloc,filecode);                          02815000
   value foptions,aoptions,recsize,recmode,blockfactor,                 02820000
      numbuffers,filesize,numextents,initalloc,filecode;                02825000
   byte array filedesignator,device,formmsg;                            02830000
   logical foptions,aoptions;                                           02835000
   integer recsize,recmode,blockfactor,numbuffers,                      02840000
      numextents,initalloc,filecode;                                    02845000
   double filesize;                                                     02850000
   option variable,external;                                            02855000
integer procedure dfopen (fname,fops,aops,recsize,dev,formmsg, <<06102>>02860000
        numlabs,blkfact,numbufs,fsize,numexts,initexts,fcode); <<06102>>02865000
   value fops,aops,recsize,numlabs,blkfact,numbufs,            <<06102>>02870000
         fsize,numexts,initexts,fcode;                         <<06102>>02875000
   byte array fname,dev,formmsg;                               <<06102>>02880000
   logical fops,aops;                                          <<06102>>02885000
   integer recsize,numlabs,blkfact,numbufs,numexts,initexts,   <<06102>>02890000
           fcode;                                              <<06102>>02895000
   double fsize;                                               <<06102>>02900000
   option variable,external;                                   <<06102>>02905000
integer procedure fopenda (ldnum,diskadr,aoptions,numbuf,      <<06102>>02910000
   filecode,dntype,disp,fops,pvinfo,cominfo);                  <<06102>>02915000
   value ldnum,diskadr,aoptions,numbuf,filecode,               <<06102>>02920000
         dntype,disp,fops,pvinfo;                              <<06102>>02925000
   integer ldnum,aoptions,numbuf,filecode,dntype,disp,pvinfo,  <<06102>>02930000
           fops;                                               <<06102>>02935000
   array cominfo;                                              <<06102>>02940000
   double diskadr;                                             <<06102>>02945000
   option variable,external;                                   <<06102>>02950000
procedure fcloseda (filenum,disp,seccode);                              02955000
    value   filenum,disp,seccode;                                       02960000
    integer filenum,disp,seccode;                                       02965000
    option external;                                                    02970000
integer procedure fgetpvinfo (filenum);                                 02975000
    value filenum;  integer filenum;                                    02980000
    option external;                                                    02985000
procedure formatname (dest,source);                                     02990000
   byte array dest,source;                                              02995000
   option forward;                                                      03000000
integer procedure fread (filenum,target,tcount);                        03005000
   value filenum,tcount;                                                03010000
   integer filenum,tcount;                                              03015000
   integer array target;                                                03020000
   option external;                                                     03025000
procedure freaddir (filenum,target,tcount,recnum);                      03030000
   value filenum,tcount,recnum;                                         03035000
   integer filenum,tcount;                                              03040000
   array target;                                                        03045000
   double recnum;                                                       03050000
   option external;                                                     03055000
procedure funlock (filenum);                                            03060000
   value filenum;                                                       03065000
   integer filenum;                                                     03070000
   option external;                                                     03075000
intrinsic fwrite;                                                       03080000
integer procedure genmsg(setno,msgno,mask,a,b,c,d,e,                    03085000
      dest,reply,buff,dst,iotype);                                      03090000
   value setno,msgno,mask,a,b,c,d,e,dest,reply,buff,                    03095000
      dst,iotype;                                                       03100000
   logical setno,msgno,mask,a,b,c,d,e,dest,reply,buff,                  03105000
      dst,iotype;                                                       03110000
   option variable,external;                                            03115000
integer procedure getstack (length,maxdata);                            03120000
   value length,maxdata;                                                03125000
   integer length,maxdata;                                              03130000
   option external;                                                     03135000
logical procedure getsir (sir);                                         03140000
   value sir;                                                           03145000
   integer sir;                                                         03150000
   option external;                                                     03155000
procedure  help;                                                        03160000
   option external;                                                     03165000
procedure  impede( pcbptr );                                            03170000
   value  pcbptr;                                                       03175000
   integer  pcbptr;                                                     03180000
   option  external;                                                    03185000
procedure lcreate (length,type,pmode,library,key);                      03190000
   value length,type,pmode,library,key;                                 03195000
   integer length,type,pmode,library;                                   03200000
   double key;                                                          03205000
   option forward;                                                      03210000
procedure lcreate' (length,type,pmode,library,key);            <<06542>>03215000
   value length,type,pmode,library,key;                        <<06542>>03220000
   integer length,type,pmode,library;                          <<06542>>03225000
   double key;                                                 <<06542>>03230000
   option forward;                                             <<06542>>03235000
procedure ldelete;                                                      03240000
   option forward;                                                      03245000
procedure loadbit (key,bit,dstnr);                                      03250000
   value key,bit,dstnr;                                                 03255000
   double key;                                                          03260000
   logical bit;                                                         03265000
   integer dstnr;                                                       03270000
   option forward;                                                      03275000
logical procedure loadedslseg (slkey,segmentnr);                        03280000
   value slkey,segmentnr;                                               03285000
   double slkey;                                                        03290000
   integer segmentnr;                                                   03295000
   option forward;                                                      03300000
double procedure loader (command,pinnr,num1,num2,string,pvinfo);        03305000
   value command,pinnr,num1,num2,pvinfo;                                03310000
   integer command,pinnr,num1,num2,pvinfo;                              03315000
   byte array string;                                                   03320000
   option internal,forward;                                             03325000
integer procedure loadproc (procname,libsearch,plabel);                 03330000
   value libsearch;                                                     03335000
   byte array procname;                                                 03340000
   integer libsearch,plabel;                                            03345000
   option forward;                                                      03350000
integer procedure loadprogram (progfnum,progkey,processkey,             03355000
   command,pinnr,savesir,pvinfo);                                       03360000
   value progfnum,progkey,processkey,command,pinnr,savesir,pvinfo;      03365000
   integer progfnum,command,pinnr,savesir,pvinfo;                       03370000
   double progkey,processkey;                                           03375000
   option forward;                                                      03380000
procedure log4 (nrprogsegs,nrslsegs,maxstack,maxxdataseg,               03385000
                maxdisc,pin,cputime,type);                     <<07318>>03390000
   value nrprogsegs,nrslsegs,maxstack,maxxdataseg,maxdisc,              03395000
         pin,cputime,type;                                     <<07318>>03400000
   integer nrprogsegs,nrslsegs,maxstack,maxxdataseg,maxdisc,            03405000
           pin,type;                                           <<07318>>03410000
   double  cputime;                                            <<07318>>03415000
   option external;                                                     03420000
procedure mount (vsname,vsgroup,vsaccnt,reqtype,                        03425000
                 gen,pvinfo,some'other'pin);                            03430000
value gen,some'other'pin;                                               03435000
integer reqtype,gen,pvinfo,some'other'pin;                              03440000
byte array vsname,vsgroup,vsaccnt;                                      03445000
option external,variable;                                               03450000
                                                                        03455000
procedure dismount (vsname,vsgroup,vsaccnt,reqtype,                     03460000
                    pvinfo,some'other'pin);                             03465000
value pvinfo,some'other'pin;                                            03470000
integer reqtype,pvinfo,some'other'pin;                                  03475000
byte array vsname,vsgroup,vsaccnt;                                      03480000
option external,variable;                                               03485000
double procedure logicalcst'(plabel,pinx);                     <<06901>>03490000
  value plabel,pinx;                                                    03495000
  integer plabel,pinx;                                                  03500000
   option uncallable,forward;                                           03505000
logical procedure lsearch (key,pmode,type);                             03510000
   value key,pmode,type;                                                03515000
   double key;                                                          03520000
   integer pmode,type;                                                  03525000
   option forward;                                                      03530000
procedure lstep (proc);                                                 03535000
   procedure proc;                                                      03540000
   option forward;                                                      03545000
integer procedure physicalcst (pin,segmentnr);                          03550000
   value pin,segmentnr;                                                 03555000
   integer pin,segmentnr;                                               03560000
   option uncallable,forward;                                           03565000
procedure print (message,length,type);                                  03570000
   value length,type;                                                   03575000
   integer array message;                                               03580000
   integer length,type;                                                 03585000
   option external;                                                     03590000
procedure procfile (pin,fname);                                         03595000
   value pin;                                                           03600000
   integer pin;                                                         03605000
   byte array fname;                                                    03610000
   option uncallable,forward;                                           03615000
procedure relcodeseg (cstnr);                                           03620000
   value cstnr;                                                         03625000
   integer cstnr;                                                       03630000
   option external;                                                     03635000
procedure reldataseg (dstnr);                                           03640000
   value dstnr; integer dstnr;                                          03645000
   option external;                                                     03650000
procedure relsir (sir,flag);                                            03655000
   value sir,flag;                                                      03660000
   integer sir,flag;                                                    03665000
   option external;                                                     03670000
procedure returnentry (type,nrentries);                                 03675000
   value type,nrentries;                                                03680000
   integer type,nrentries;                                              03685000
   option external;                                                     03690000
procedure setbit (bitarray,bitnumber);                                  03695000
   value bitnumber;                                                     03700000
   integer array bitarray;                                              03705000
   integer bitnumber;                                                   03710000
   option internal,forward;                                             03715000
procedure suddendeath(e);                                               03720000
   value e;                                                             03725000
   integer e;                                                           03730000
   option external;                                                     03735000
integer procedure sysproc(a);                                           03740000
   value  a;                                                            03745000
   integer  a;                                                          03750000
   option  external;                                                    03755000
procedure sumsegs (cstnr);                                              03760000
   value cstnr;                                                         03765000
   integer cstnr;                                                       03770000
   option forward;                                                      03775000
logical procedure testbit (bitarray,bitnumber);                         03780000
   value bitnumber;                                                     03785000
   integer array bitarray;                                              03790000
   integer bitnumber;                                                   03795000
   option internal,forward;                                             03800000
procedure unload (pin);                                                 03805000
   value pin; integer pin;                                              03810000
   option privileged,uncallable,forward;                                03815000
procedure unloadproc (procid);                                          03820000
   value procid;                                                        03825000
   integer procid;                                                      03830000
   option forward;                                                      03835000
intrinsic  who;                                                         03840000
procedure clearwws;                                            <<06102>>03845000
   option external;                                            <<06102>>03850000
procedure adjustlocality(procinx,objid,reqsize,flags);         <<06742>>03855000
   value procinx,objid,reqsize,flags;                          <<06742>>03860000
   logical procinx,reqsize,flags;                              <<06742>>03865000
   double objid;                                               <<06742>>03870000
   option external;                                            <<06742>>03875000
integer procedure flush'cache(ldev,startaddr,endaddr);         <<f7594>>03880000
   value ldev,startaddr,endaddr;                               <<07316>>03885000
   integer ldev;                                               <<07316>>03890000
   double startaddr,endaddr;                                   <<07316>>03895000
   option external;                                            <<07316>>03900000
procedure sendmsg(descpin,subq,msglength,flags);               <<*7558>>03905000
   value descpin,subq,msglength,flags;                         <<*7558>>03910000
   integer descpin,subq,msglength;                             <<*7558>>03915000
   logical flags;                                              <<*7558>>03920000
   option external;                                            <<*7558>>03925000
procedure receivemsg(subq,msglength,flags);                    <<*7558>>03930000
   value subq,msglength,flags;                                 <<*7558>>03935000
   integer subq,msglength;                                     <<*7558>>03940000
   logical flags;                                              <<*7558>>03945000
   option external;                                            <<*7558>>03950000
$page                                                                   03955000
                                                                        03960000
<<------------------------------------------------------->>             03965000
<<                                                       >>             03970000
<< utility procedures                                    >>             03975000
<<                                                       >>             03980000
<<------------------------------------------------------->>             03985000
                                                                        03990000
logical procedure testbit (bitarray,bitnumber);                         03995000
   value bitnumber;                                                     04000000
   integer array bitarray;                                              04005000
   integer bitnumber;                                                   04010000
   option internal,uncallable;                                          04015000
   begin                                                                04020000
     tos := bitnumber.(0:12)+@bitarray;                                 04025000
     tos := ps0;                                                        04030000
     xreg := bitnumber.(12:4);                                          04035000
     assemble(csl 1,x);                                                 04040000
     testbit := tos                                                     04045000
   end;                                                                 04050000
procedure clearbit (bitarray,bitnumber);                                04055000
  <<clears the bit specified by bitnumber in the bit array              04060000
    specified by bitarray>>                                             04065000
  value bitnumber;                                                      04070000
  integer array bitarray;                                               04075000
  integer bitnumber;                                                    04080000
  option internal,uncallable;                                           04085000
  begin                                                                 04090000
    tos := bitnumber.(0:12)+@bitarray;                                  04095000
    tos := ps0;                                                         04100000
    xreg := bitnumber;                                                  04105000
    assemble(trbc 0,x);                                                 04110000
    ps1 := tos                                                          04115000
  end;                                                                  04120000
procedure setbit (bitarray,bitnumber);                                  04125000
  <<sets the bit specified by bitnumber in the bit array                04130000
    specified by bitarray>>                                             04135000
  value bitnumber;                                                      04140000
  integer array bitarray;                                               04145000
  integer bitnumber;                                                    04150000
  option internal,uncallable;                                           04155000
  begin                                                                 04160000
    tos := bitnumber.(0:12)+@bitarray;                                  04165000
    tos := ps0;                                                         04170000
    xreg := bitnumber;                                                  04175000
    assemble(tsbc 0,x);                                                 04180000
    ps1 := tos                                                          04185000
  end;                                                                  04190000
integer procedure nextbit(bitarray);                                    04195000
  <<return next available index from bitarray>>                         04200000
  <<if none available return 0             >>                           04205000
  integer array bitarray;                                               04210000
  option privileged,uncallable;                                <<*7861>>04215000
  begin                                                                 04220000
    integer index:=0;                                                   04225000
    <<search for available index>>                                      04230000
    while (index:=index+1) <= 255 do                                    04235000
      begin                                                             04240000
        if not testbit(bitarray,index) then                             04245000
          begin            <<found available index>>                    04250000
            <<reserve index>>                                           04255000
            setbit(bitarray,index);                                     04260000
            nextbit:=index;                                             04265000
            return;                                                     04270000
          end;                                                          04275000
      end; <<while>>                                                    04280000
    <<no available index>>                                              04285000
    nextbit:=0;                                                         04290000
  end;                                                                  04295000
procedure formatname (dest,source);                                     04300000
  <<moves the string from source to dest and truncates >>               04305000
  <<it to 15 characters.  the source string must have  >>               04310000
  <<no leading blanks and be terminated with a blank or>>               04315000
  <<cr.  the dest string has the numb of char in the 1st>>              04320000
  <<byte.  note source and dest may be same buffer      >>              04325000
   byte array dest,source;                                              04330000
   option internal,uncallable;                                          04335000
   begin                                                                04340000
     equate blank = %006440;  <<cr - blank>>                            04345000
     double strings = dest;                                             04350000
     tos := strings;                                                    04355000
     move bps0 := bps0 while ans;  <<upshift chars>>           <<06102>>04360000
     scan * until blank,1;  <<find term. char.>>                        04365000
     tos := s0-@source;  <<nr. char's>>                                 04370000
     if s0 > 15 then s0 := 15;  <<truncate>>                            04375000
     xreg := s0;  <<save nr. char's>>                                   04380000
     s2 := s2+s0;                                                       04385000
     assemble(decb,neg);                                                04390000
     move * := *,(tos);  <<move string>>                                04395000
     dest := xreg  <<nr. char's>>                                       04400000
   end;                                                                 04405000
logical procedure samename (name1,name2);                               04410000
   <<compares two names (the first byte being the # of char>>           04415000
   <<and returns true if they are the same; otherwise false>>           04420000
   integer array name1,name2;                                           04425000
   option uncallable;                                                   04430000
   begin                                                                04435000
     integer result = samename;                                         04440000
     tos := @name1&lsl(1);                                              04445000
     tos := @name2&lsl(1);                                              04450000
     assemble(inca,incb);                                               04455000
     tos := name1.(4:4);                                                04460000
     if name2.(4:4) = s0 and * = *,(tos)                                04465000
       then result:=result+1;                                           04470000
   end;                                                                 04475000
procedure setsecptrs;                                                   04480000
  <<set secondary pointers for current lst entry>>                      04485000
  option privileged,uncallable;                                         04490000
  begin                                                                 04495000
    case etype of                                                       04500000
      begin                                                             04505000
        begin  <<0>>                                                    04510000
          @entp1:=@entp2:=@entp3:=@entp;                                04515000
        end;                                                            04520000
        begin  <<1>>                                                    04525000
          @entp1:=@entp+1;                                              04530000
          @entp2:=@entp1+4;                                             04535000
          @entp3:=@entp2+16;                                            04540000
        end;                                                            04545000
        begin  <<2>>                                                    04550000
          @entp1:=@entp+1;                                              04555000
          @entp2:=@entp1+8;                                             04560000
          @entp3:=@entp2+eslinfo'prog*19;                               04565000
        end;                                                            04570000
        begin  <<3>>                                                    04575000
          @entp1:=@entp2:=@entp3:=@entp+1;                              04580000
        end;                                                            04585000
        begin  <<4>>                                                    04590000
          @entp1:=@entp+1;                                              04595000
          @entp2:=@entp3:=@entp1+2;                                     04600000
        end;                                                            04605000
        begin  <<5>>                                                    04610000
          @entp1:=@entp+1;                                              04615000
          @entp2:=@entp3:=@entp1+2;                                     04620000
        end;                                                            04625000
        begin  <<6>>                                                    04630000
          @entp1:=@entp+2;                                              04635000
          @entp2:=@entp3:=@entp+1;                                      04640000
        end;                                                            04645000
        begin  <<7>>                                                    04650000
          @entp1:=@entp+1;                                              04655000
          @entp2:=@entp1+6+entp(5).(4:3);                      <<06280>>04660000
          @entp3:=@entp2+eslinfo'ext*19;                                04665000
        end;                                                            04670000
        begin  <<8>>                                                    04675000
          @entp1:=@entp+3;                                              04680000
          @entp2:=@entp1+32;                                            04685000
          @entp3:=@entp2+eslid'lproc*2;                                 04690000
        end;                                                            04695000
      end <<cases>>;                                                    04700000
  end;                                                                  04705000
procedure unlinklstentry;                                               04710000
  <<remove current entry from type chain>>                              04715000
  option privileged,uncallable;                                         04720000
  begin                                                                 04725000
    if hdfwdlink(etype) = @entp then                                    04730000
      begin           <<first in chain>>                                04735000
        hdfwdlink(etype):=fwdlink;                                      04740000
      end else                                                          04745000
      begin           <<not first in chain>>                            04750000
        lst(bkwdlink-3):=fwdlink;                                       04755000
      end;                                                              04760000
    if hdbkwdlink(etype) = @entp then                                   04765000
      begin           <<last in chain>>                                 04770000
        hdbkwdlink(etype):=bkwdlink;                                    04775000
      end else                                                          04780000
      begin           <<not last in chain>>                             04785000
        lst(fwdlink-2):=bkwdlink;                                       04790000
      end;                                                              04795000
  end;                                                                  04800000
procedure linklstentry;                                                 04805000
  <<insert current entry into type chain>>                              04810000
  option privileged,uncallable;                                         04815000
  begin                                                                 04820000
    <<link at head of chain>>                                           04825000
    bkwdlink:=0;                                                        04830000
    fwdlink:=hdfwdlink(etype);                                          04835000
    hdfwdlink(etype):=@entp;                                            04840000
    if fwdlink = 0 then                                                 04845000
      begin        <<only entry on chain>>                              04850000
        hdbkwdlink(etype):=@entp;                                       04855000
      end else                                                          04860000
      begin         <<not only entry on chain>>                         04865000
        lst(fwdlink-2):=@entp;                                          04870000
      end;                                                              04875000
  end;                                                                  04880000
procedure buildgarbage(position,length);                                04885000
  <<convert region into garbage entry>>                                 04890000
  <<concatenate any adjacent garbage >>                                 04895000
  <<entries.  position points to 1st >>                                 04900000
  <<word of area                     >>                                 04905000
  value position,length;                                                04910000
  integer position,length;                                              04915000
  begin                                                                 04920000
    integer saveentp;                                                   04925000
    saveentp:=@entp;                                                    04930000
restart:                                                                04935000
    @entp:=hdfwdlink(garbage); <<get head of chain>>                    04940000
    if @entp = 0 then                                                   04945000
      begin                    <<empty chain>>                          04950000
linkit:                                                                 04955000
        @entp:=position +3;    <<point at area>>                        04960000
        rlength:=length;       <<area size>>                            04965000
        entp:=garbage;         <<type>>                                 04970000
        linklstentry;          <<link into chain>>                      04975000
        @entp:=saveentp;       <<restore pointer>>                      04980000
        return;                                                         04985000
      end else                                                          04990000
      begin                    <<non-empty chain>>                      04995000
        while @entp <> 0 do                                             05000000
          begin                <<work thru chain>>                      05005000
            if @entp+rlength-3 = position then                          05010000
              begin            <<found adjacent area >>                 05015000
                unlinklstentry;<<remove area from chain>>               05020000
                position:=@entp-3;<<adjust position>>                   05025000
                length:=length+rlength; <<adjust length>>               05030000
                go restart;    <<use concatenated areas>>               05035000
              end;                                                      05040000
            if position+length+3 = @entp then                           05045000
              begin            <<found adjacent area>>                  05050000
                unlinklstentry;<<remove area from chain>>               05055000
                length:=length+rlength; <<adjust length>>               05060000
                go restart;    <<use concatenated areas>>               05065000
              end;                                                      05070000
            @entp:=fwdlink;    <<next garbage entry>>                   05075000
          end <<while>>;                                                05080000
        <<all adjacent areas have been concatenated >>                  05085000
        go linkit;                                                      05090000
      end;                                                              05095000
  end;                                                                  05100000
integer procedure entrylength;                                          05105000
  <<calculates length of current entry>>                                05110000
  option privileged,uncallable;                                         05115000
  begin                                                                 05120000
    array elen(*) = pb:=     <<fixed area sizes>>                       05125000
          0,  <<garbage>>                                               05130000
          21, <<basic sl>>                                              05135000
          9,  <<basic prog file>>                                       05140000
          3,  <<loading>>                                               05145000
          5,  <<waiter>>                                                05150000
          5,  <<loaded>>                                                05155000
          4,  <<sharer>>                                                05160000
          6,  <<basic extension>>                                       05165000
          35; <<basic loadproc master>>                                 05170000
                                                                        05175000
    tos:=elen(etype);  <<get fixed area size>>                          05180000
    if s0 = garbage then                                                05185000
      begin   <<garbage entry>>                                         05190000
        del;                                                            05195000
        tos:=enwg;                                                      05200000
      end;                                                              05205000
    <<add any dynamic area to size>>                                    05210000
    case etype of                                                       05215000
      begin                                                             05220000
        <<0>> ;                                                         05225000
        <<1>> tos:=tos+eslseg'sl*3;                                     05230000
        <<2>> tos:=tos+eslinfo'prog*19+emapsize+1;                      05235000
        <<3>> ;                                                         05240000
        <<4>> ;                                                         05245000
        <<5>> ;                                                         05250000
        <<6>> ;                                                         05255000
        <<7>> tos:=tos+entp(4).(4:3)+eslinfo'ext*19                     05260000
                                     +emapsize+1;                       05265000
        <<8>> tos:=tos+(eslid'lproc+emcstls'lproc+1)*2;                 05270000
      end; <<case>>                                                     05275000
    entrylength:=tos;                                                   05280000
  end;                                                                  05285000
double procedure entrykey;                                              05290000
   <<returns the key of the current entry>>                             05295000
   option internal,uncallable;                                          05300000
   begin                                                                05305000
     if etype < sharer                                                  05310000
        then begin tos := efid1; tos := efid2 end                       05315000
        else                                                            05320000
           if etype=extension then                                      05325000
              begin                                            <<06280>>05330000
                 tos:=epin;                                    <<06280>>05335000
                 tos:=eext;                                    <<06280>>05340000
              end                                              <<06280>>05345000
           else                                                         05350000
              begin                                                     05355000
                 tos:=0;                                                05360000
                 tos:=epid;                                             05365000
              end;                                                      05370000
     entrykey := tos                                                    05375000
   end;                                                                 05380000
procedure lstep (proc);                                                 05385000
<<steps thru the logical segments array pointed >>                      05390000
<<to by pst.  the passed procedure is called for>>                      05395000
<<each referenced logical segment               >>                      05400000
   procedure proc;                                                      05405000
   option uncallable;                                                   05410000
   begin                                                                05415000
     xreg:=255;                <<log seg nr>>                           05420000
     do begin                                                           05425000
         if testbit(pst,xreg) then                                      05430000
           begin                                                        05435000
             tos := xreg;  <<cst nr.>>                                  05440000
             proc(*)  <<apply procedure>>                               05445000
           end;                                                         05450000
         xreg := xreg-1                                                 05455000
        end until <                                                     05460000
   end;                                                                 05465000
procedure trans'lst'to'xdst;                                   <<06542>>05470000
<< this procedure transfers the current extension entry >>     <<06542>>05475000
<< in lst to xdst, then delete the one in lst.          >>     <<06542>>05480000
option uncallable;                                             <<06542>>05485000
begin                                                          <<06542>>05490000
   integer savedb;                                             <<06542>>05495000
   integer source'offset,                                      <<06542>>05500000
           transfer'count;                                     <<06542>>05505000
                                                               <<06542>>05510000
   savedb:=exchangedb(segtabdst);                              <<06542>>05515000
   @entp:=hdfwdlink(extension);                                <<06542>>05520000
   if @entp = 0 then go error'out;                             <<06542>>05525000
   if fwdlink <> 0 then go error'out;                          <<06542>>05530000
   transfer'count:=rlength-3;                                  <<06542>>05535000
   source'offset:=@entp;                                       <<06542>>05540000
                                                               <<06542>>05545000
   exchangedb(segtabdst'ex);                                   <<06542>>05550000
   lcreate'(transfer'count,extension,0,0,double(0));           <<06542>>05555000
   if <> then go error'recv;                                            05560000
                                                               <<06542>>05565000
   tos:=segtabdst'ex;                                          <<06542>>05570000
   tos:=@entp;                                                 <<06542>>05575000
   tos:=segtabdst;                                             <<06542>>05580000
   tos:=source'offset;                                         <<06542>>05585000
   tos:=transfer'count;                                        <<06542>>05590000
   asmb(mds 5);                                                <<06542>>05595000
   condcode:=cce;                                              <<06542>>05600000
   go ok'out;                                                  <<06542>>05605000
                                                                        05610000
error'recv:                                                             05615000
   exchangedb(segtabdst);                                               05620000
   setsecptrs;                                                          05625000
   adjrefcounts(-1);                                                    05630000
                                                               <<06542>>05635000
error'out:                                                     <<06542>>05640000
   condcode:=ccl;                                              <<06542>>05645000
                                                               <<06542>>05650000
ok'out:                                                        <<06542>>05655000
   exchangedb(segtabdst);                                      <<06542>>05660000
   ldelete;                                                    <<06542>>05665000
   exchangedb(savedb);                                         <<06542>>05670000
end;                                                           <<06542>>05675000
procedure trans'xdst'to'lst;                                   <<06542>>05680000
<< this procedure transfers the current extension entry >>     <<06542>>05685000
<< in xdst to lst.                                      >>     <<06542>>05690000
option uncallable;                                             <<06542>>05695000
begin                                                          <<06542>>05700000
   integer savedb;                                             <<06542>>05705000
   integer source'offset,                                      <<06542>>05710000
           transfer'count;                                     <<06542>>05715000
                                                               <<06542>>05720000
   savedb:=exchangedb(segtabdst'ex);                           <<06542>>05725000
   if @entp = 0 then go error'out;                             <<06542>>05730000
   transfer'count:=rlength-3;                                  <<06542>>05735000
   source'offset:=@entp;                                       <<06542>>05740000
                                                               <<06542>>05745000
   exchangedb(segtabdst);                                      <<06542>>05750000
   lcreate(transfer'count,extension,0,0,double(0));            <<06542>>05755000
   if <> then go error'out;                                    <<06542>>05760000
                                                               <<06542>>05765000
   tos:=segtabdst;                                             <<06542>>05770000
   tos:=@entp;                                                 <<06542>>05775000
   tos:=segtabdst'ex;                                          <<06542>>05780000
   tos:=source'offset;                                         <<06542>>05785000
   tos:=transfer'count;                                        <<06542>>05790000
   asmb(mds 5);                                                <<06542>>05795000
   setsecptrs;                                                 <<06542>>05800000
   condcode:=cce;                                              <<06542>>05805000
   go ok'out;                                                  <<06542>>05810000
                                                               <<06542>>05815000
error'out:                                                     <<06542>>05820000
   condcode:=ccl;                                              <<06542>>05825000
                                                               <<06542>>05830000
ok'out:                                                        <<06542>>05835000
   exchangedb(savedb);                                         <<06542>>05840000
end;                                                           <<06542>>05845000
procedure update'xdst;                                         <<06542>>05850000
option uncallable;                                             <<06542>>05855000
begin                                                          <<06542>>05860000
   integer savedb;                                             <<06542>>05865000
                                                               <<06542>>05870000
   savedb:=exchangedb(segtabdst);                              <<06542>>05875000
   tos:=loadproccount;                                         <<06542>>05880000
   ldelete;                                                    <<06542>>05885000
   exchangedb(segtabdst'ex);                                   <<06542>>05890000
   loadproccount:=tos;                                         <<06542>>05895000
   exchangedb(savedb);                                         <<06542>>05900000
end;                                                           <<06542>>05905000
logical procedure lsearch' (key,pmode,type);                   <<06542>>05910000
   <<searches the directory for an entry having the >>                  05915000
   <<specified key, mode, and type.  if found true is>>                 05920000
   <<returned and entp ptrs are set else false returned>>               05925000
   value key,pmode,type;                                                05930000
   double key;                                                          05935000
   integer pmode,type;                                                  05940000
   option uncallable;                                                   05945000
   begin                                                                05950000
     integer result = lsearch';                                <<06542>>05955000
     @entp:=hdfwdlink(type);  <<get head link>>                         05960000
     while @entp <> 0 do                                                05965000
       begin                  <<search chained entries>>                05970000
         if (pmode = -1 or pmode = epmode) and                          05975000
            entrykey = key then                                         05980000
           begin              <<found entry>>                           05985000
             setsecptrs;      <<setup secondary pointers>>              05990000
             result:=1;       <<return true>>                           05995000
             return;                                                    06000000
           end else                                                     06005000
           begin              <<wrong entry>>                           06010000
             @entp:=fwdlink;  <<next entry>>                            06015000
           end;                                                         06020000
       end <<while>>;                                                   06025000
     result:=0;               <<return false>>                          06030000
   end;                                                                 06035000
logical procedure lsearch (key,pmode,type);                    <<06542>>06040000
   <<searches the directory for an entry having the >>         <<06542>>06045000
   <<specified key, mode, and type.  if found true is>>        <<06542>>06050000
   <<returned and entp ptrs are set else false returned>>      <<06542>>06055000
   <<if a extension entry is to be search then db is   >>      <<06542>>06060000
   <<changed to extra dst, search the entry, and make a>>      <<06542>>06065000
   <<copy of the found entry in lst. pointers in both  >>      <<06542>>06070000
   <<lst and xdst are set pointing to the entry.       >>      <<06542>>06075000
   value key,pmode,type;                                       <<06542>>06080000
   double key;                                                 <<06542>>06085000
   integer pmode,type;                                         <<06542>>06090000
   option uncallable;                                          <<06542>>06095000
   begin                                                       <<06542>>06100000
      integer savedb;                                          <<06542>>06105000
      if type = extension then                                 <<06542>>06110000
         begin                                                 <<06542>>06115000
            savedb:=exchangedb(segtabdst'ex);                  <<06542>>06120000
            if lsearch' (key,pmode,type) then                  <<06542>>06125000
               begin                                           <<06542>>06130000
                  trans'xdst'to'lst;                           <<06542>>06135000
                  if <> then lsearch:=false else lsearch:=true;<<06542>>06140000
               end                                             <<06542>>06145000
            else                                               <<06542>>06150000
               lsearch:=false;                                 <<06542>>06155000
            exchangedb(savedb);                                <<06542>>06160000
         end                                                   <<06542>>06165000
      else                                                     <<06542>>06170000
         lsearch:=lsearch'(key,pmode,type);                    <<06542>>06175000
   end;                                                        <<06542>>06180000
procedure lcreate(length,type,pmode,library,key);                       06185000
   <<creates entry of length,type,mode        >>                        06190000
   <<and id (from key). the entry pointer entp>>                        06195000
   <<is set to the new entry.  note--condition>>                        06200000
   <<code is used to indicate an error        >>                        06205000
   value length,type,pmode,library,key;                                 06210000
   integer length,type,pmode,library;                                   06215000
   double key;                                                          06220000
   option uncallable;                                                   06225000
   begin                                                                06230000
     integer key1 = key;                                                06235000
     integer key2 = key1+1;                                             06240000
     integer retry,excess;                                              06245000
     logical in'xdst := false;                                 <<06542>>06250000
     entry lcreate';                                           <<06542>>06255000
                                                               <<06542>>06260000
     go start;                                                 <<06542>>06265000
lcreate':                                                      <<06542>>06270000
     in'xdst:=true;                                            <<06542>>06275000
start:                                                         <<06542>>06280000
     retry:=-1;           <<initial value>>                             06285000
                                                                        06290000
     <<* * * find space for entry * * *>>                               06295000
                                                                        06300000
restart:                                                                06305000
     @entp:=hdfwdlink(0);  <<head of garbage chain>>                    06310000
     while @entp <> 0 do                                                06315000
       begin               <<search thru chain>>                        06320000
         if enwg >= length+3 then                                       06325000
           begin           <<found large enough entry>>                 06330000
             unlinklstentry; <<remove garbage entry >>                  06335000
             excess:=enwg-length-3; <<excess space>>                    06340000
             if excess >= 4 then                                        06345000
               begin       <<return excess>>                            06350000
                 buildgarbage(@entp+length,excess);                     06355000
               end else                                                 06360000
               begin       <<insufficient excess>>                      06365000
                 excess:=0;                                             06370000
               end;                                                     06375000
             rlength:=enwg-excess; <<region length>>                    06380000
             <<initialize entry>>                                       06385000
             entp:=0;                                                   06390000
             move entp(1):=entp,(length-1); << zero entry >>            06395000
             etype:=type;                                               06400000
             epmode:=pmode;                                             06405000
             elib:=library;                                             06410000
             setsecptrs; <<setup secondary pointers>>                   06415000
             linklstentry;<<link entry into chain>>                     06420000
             if type < sharer                                           06425000
               then efid:=key                                           06430000
               else if type=extension then                              06435000
                       epin'ext:=key                                    06440000
                    else                                                06445000
                       epid:=key2;                                      06450000
             tos:=cce;   <<return value>>                               06455000
             go getout;                                                 06460000
           end else                                                     06465000
           begin          <<garbage entry too small>>                   06470000
             @entp:=fwdlink; <<next entry>>                             06475000
           end;                                                         06480000
       end <<while>>;                                                   06485000
     <<no adequate garbage entry found>>                                06490000
     <<expand lst                     >>                                06495000
     retry:=retry+1;                                                    06500000
     if > then go nfg; <<allow one expansion>>                          06505000
     tos:=0;                                                   <<06542>>06510000
     if in'xdst then tos:=segtabdst'ex                         <<06542>>06515000
                else tos:=segtabdst;                           <<06542>>06520000
     tos:=altdsegsize(*,1024);                                 <<06542>>06525000
     if > then go nfg; <<no disc space>>                                06530000
     excess:=tos-@dir-1-dirlen; <<words added>>                         06535000
     if excess <= 0 then go nfg;<<no expansion>>                        06540000
     buildgarbage(@dir(dirlen),excess); <<new garbage>>                 06545000
     dirlen:=dirlen+excess; <<update dir length>>                       06550000
     go restart;            <<try again>>                               06555000
     help;        <<setup linkage>>                                     06560000
nfg:                                                                    06565000
     tos:=ccl;                                                          06570000
     @entp:=-1;                                                         06575000
getout:                                                                 06580000
     condcode:=tos;                                                     06585000
   end;                                                                 06590000
procedure ldelete;                                                      06595000
  <<deletes the current entry by making a garbage entry>>               06600000
  <<out of it                                          >>               06605000
  option privileged,uncallable;                                         06610000
  begin                                                                 06615000
    unlinklstentry;   <<unlink the entry>>                              06620000
    buildgarbage(@entp-3,rlength);                                      06625000
  end; <<ldelete>>                                                      06630000
integer procedure mountvolset (filenum,some'other'pin);                 06635000
    value filenum,some'other'pin;                                       06640000
    integer filenum,some'other'pin;                                     06645000
    option uncallable,variable;                                         06650000
    begin                                                               06655000
                                                                        06660000
        comment                                                         06665000
                                                                        06670000
            this function will explicitly perform a mount on            06675000
            the home volume set of the file's group and                 06680000
            account.                                                    06685000
            no error should be returned since at this point             06690000
            a successful mount would have been implicitly               06695000
            performed by the previous fopen.                            06700000
                                                                        06705000
            the procedure will return a value as a function.            06710000
            the nature of this value is determined on the               06715000
            setting of the condition code as follows:                   06720000
                                                                        06725000
            cce - operation succeeded.                                  06730000
                  if the value is non-zero a mount was                  06735000
                  performed so that the value represents the            06740000
                  pvinfo word returned by the mount procedure.          06745000
                  if the value is zero no mount was necessary.          06750000
                                                                        06755000
            ccl - a mount failure caused the operation to fail          06760000
                  in some way. the value returned is a pv               06765000
                  error number.                                         06770000
                                                                        06775000
            ccg - not returned.                                         06780000
                                                                        06785000
        *** note that db must be at stack when this procedure           06790000
        *** is called.                                                  06795000
                                                                        06800000
        ;                                                               06805000
        equate                                                          06810000
            uncondmount = 3,  <<no binding>>                            06815000
            nohvset = 28;                                               06820000
                                                                        06825000
        logical                                                         06830000
            pmap = q-4;                                                 06835000
        integer                                                         06840000
            pvinfo = mountvolset,                                       06845000
            result = mountvolset,                                       06850000
            reqtype := uncondmount,                                     06855000
            pverr  = reqtype;                                           06860000
                                                                        06865000
        array                                                           06870000
            names (0:11),                                               06875000
            vsname (*) = names (0),                                     06880000
            gname (*)  = names (4),                                     06885000
            aname (*)  = names (8);                                     06890000
                                                                        06895000
        byte array                                                      06900000
            filename (0:27),                                            06905000
            bvsname (*) = vsname,                                       06910000
            bgname (*)  = gname,                                        06915000
            baname (*)  = aname;                                        06920000
                                                                        06925000
        if (pvinfo := fgetpvinfo (filenum)) <> 0 then                   06930000
        begin <<fopen caused a logical mount>>                          06935000
            if pvinfo = -1 then                                <<06102>>06940000
               begin    << it is a remote prog >>              <<06102>>06945000
                  condcode := ccl;                             <<06102>>06950000
                  return;                                      <<06102>>06955000
               end;                                            <<06102>>06960000
            fgetinfo (filenum,filename);                                06965000
            names := "  ";                                              06970000
            move names (1) := names, (11);                              06975000
            bvsname (0) := "*";                                         06980000
            scan filename until %020056, 1;  <<space/period>>           06985000
            tos := tos+1;  <<skip past ".">>                            06990000
            move bgname := * while ans, 0;                              06995000
            delb;  <<destination addr>>                                 07000000
            tos := tos+1;  <<skip past ".">>                            07005000
            move baname := * while ans, 2;                              07010000
            condcode := cce;  <<assume success>>                        07015000
            if pmap then                                                07020000
             mount (bvsname,bgname,baname,                              07025000
                    reqtype,-1,pvinfo,some'other'pin*pcbsize)  <<07316>>07030000
            else                                                        07035000
             mount (bvsname,bgname,baname,reqtype,-1,pvinfo);           07040000
            if < then                                                   07045000
            begin <<some mount failure>>                                07050000
                result := pverr;                                        07055000
                condcode := ccl;                                        07060000
            end;                                                        07065000
        end;                                                            07070000
    end <<of mountvolset>>;                                             07075000
integer procedure dismountvolset (pvinfo,some'other'pin);               07080000
    value   pvinfo,some'other'pin;                                      07085000
    integer pvinfo,some'other'pin;                                      07090000
    option uncallable,variable;                                         07095000
    begin                                                               07100000
                                                                        07105000
        comment                                                         07110000
            this procedure will explicitly make a call to               07115000
            dismount for logically dismounting a volume set.            07120000
                                                                        07125000
            the prodecure returns a pv error number is the              07130000
            dismount fails, otherwise (successful) a zero               07135000
            is returned. the setting of the condition code              07140000
            determines the nature of the returned value.                07145000
                                                                        07150000
            cce - operation succeeded.                                  07155000
                  value returned will be zero.                          07160000
                                                                        07165000
            ccl - operation failed.                                     07170000
                  value returned will be a pv error number.             07175000
                                                                        07180000
            ccg - not returned.                                         07185000
                                                                        07190000
        *** note that db must be at stack when this procedure           07195000
        *** is called.                                                  07200000
                                                                        07205000
        ;                                                               07210000
        equate                                                          07215000
            unconddismount = 3;  <<no unbinding>>                       07220000
        logical                                                         07225000
            pmap = q-4;                                                 07230000
        integer                                                         07235000
            reqtype := unconddismount,                                  07240000
            pverr = reqtype;                                            07245000
                                                                        07250000
        if pmap then                                                    07255000
         dismount (<<vsname>>,<<vsgname>>,<<vsaname>>,                  07260000
                   reqtype,pvinfo,some'other'pin*pcbsize)      <<07316>>07265000
        else                                                            07270000
         dismount (<<vsname>>,<<vsgname>>,<<vsaname>>,                  07275000
                   reqtype,pvinfo);                                     07280000
        if <> then                                                      07285000
        begin                                                           07290000
            dismountvolset := pverr;                                    07295000
            condcode := ccl;                                            07300000
        end;                                                            07305000
    end <<of dismountvolset>>;                                          07310000
procedure initloadcache;                                                07315000
  <<initializes the load cache.  to be called at load>>                 07320000
  <<startup time and by segmenter when modifying the >>                 07325000
  <<system sl.                                       >>                 07330000
  option privileged,uncallable;                                         07335000
  begin                                                                 07340000
    integer bucketsize';                                                07345000
    long zeros:=0l0;        <<four words of zero>>                      07350000
    if loadcacheseg<>0 then                                             07355000
      begin   <<there is a cache>>                                      07360000
        bucketsize':=bucketsize+1;  <<initial value>>                   07365000
        tos:=loadcacheseg;          <<target segment>>                  07370000
        tos:=bucket0;               <<target>>                          07375000
        tos:=@bucketsize';          <<source>>                          07380000
        tos:=1;                     <<length>>                          07385000
        assemble(mtds 2);           <<move - save target>>              07390000
                                                                        07395000
        tos:=loadcacheseg;          <<source segment>>                  07400000
        tos:=bucket0;               <<source>>                          07405000
        tos:=nbuckets*bucketsize-1; <<length>>                          07410000
        assemble(mds 5);            <<propogate initial value>>         07415000
                                                                        07420000
        <<zero hit and miss counters>>                                  07425000
        tos:=loadcacheseg;          <<target segment>>                  07430000
        tos:=cachehits;             <<target>>                          07435000
        tos:=@zeros;                <<source>>                          07440000
        tos:=4;                     <<length>>                          07445000
        assemble(mtds 4);           <<move>>                            07450000
      end;                                                              07455000
  end;                                                                  07460000
procedure load (progfname,entryname,cstindex,deltap,dstindex,           07465000
   pin,flags,pcbxsize,dlsize,stacksize,maxdata,                         07470000
   globalsize,string,stringlength,capability,mapflag);         <<06102>>07475000
   <<assumes that critical has been set when called and >>              07480000
   <<that db is set to the stack of the caller>>                        07485000
   value pin,flags,pcbxsize,stringlength;                      <<06102>>07490000
   byte array progfname,entryname,string;                      <<06102>>07495000
   integer cstindex,deltap,dstindex,pin,pcbxsize,dlsize,                07500000
      stacksize,maxdata,stringlength,globalsize;               <<06102>>07505000
   integer mapflag;                                                     07510000
   logical flags,capability;                                            07515000
   option privileged,uncallable;                                        07520000
begin                                                                   07525000
  integer pcbpt;  << index of pcb entry >>                              07530000
  define pmode = flags.(12:1)#;                                         07535000
  integer p256 := 256;                                                  07540000
  integer p512 := 512;                                                  07545000
  equate systemdl = 10,  <<subsystem dl area size>>                     07550000
         xtramaxdata = 768,  <<extra maxdata>>                 <<06102>>07555000
         stackoverflow = 128;<<system stack overflow area size>>        07560000
  integer minstacksize = p512;  <<min. stack size>>                     07565000
  integer savesir := -1;                                                07570000
  double ds1 = s-1;                                                     07575000
                                                                        07580000
  <<program file parameters>>                                           07585000
                                                                        07590000
  integer progfnum := 0;  <<program file nr.>>                          07595000
  double progkey;  <<program file key>>                                 07600000
integer ldev;                                                  <<07316>>07605000
double startaddr,endaddr;                                      <<07316>>07610000
integer startaddr1=startaddr,                                  <<07316>>07615000
        startaddr2=startaddr+1;                                <<07316>>07620000
  double pentryrecd';                                                   07625000
  integer array sbuf(0:255);                                            07630000
  integer array sbuf3(*)=sbuf,                                          07635000
                sbuf4(*)=sbuf(128);                                     07640000
                                                                        07645000
  <<process parameters>>                                                07650000
                                                                        07655000
  double processkey;  <<process key>>                                   07660000
  integer array entryname' (0:7) = q;  <<entry point name>>             07665000
  byte array bentryname' (*) = entryname';                              07670000
  integer plabel;          <<entry point p-label>>                      07675000
  byte sttindex = plabel;  <<entry point stt nr.>>                      07680000
  integer cstindex';       <<entry point cst nr.>>                      07685000
  integer deltap';         <<entry point pb adr.>>                      07690000
  logical zerodb;          <<zero db and dl area?>>                     07695000
  integer globalrecd;      <<rec. nr. of global values>>                07700000
  integer globalsize';     <<process global size>>                      07705000
  integer saflut;          <<s.a. of flut>>                             07710000
  integer sastlt;          <<s.a. of stlt>>                             07715000
  integer satrapcom;  <<s.a. of trapcom'>>                              07720000
  integer dlsize';  <<process dl size>>                                 07725000
  integer stacksize';  <<process stack size>>                           07730000
  integer maxdata';  <<process max. data seg. size>>                    07735000
  integer capability';  <<process capability>>                          07740000
  integer dstindex' := 0;  <<process data seg. dst nr.>>                07745000
  integer stcount := 0; <<#words worth of passed string>>      <<06102>>07750000
  integer loadwarn :=0; <<indicates any special actions taken>><<06102>>07755000
  integer orig'dlsize,  <<local copy of original dlsize>>      <<06102>>07760000
          orig'maxdata; <<local copy of original maxdata>>     <<06102>>07765000
  integer mapflag'; <<mapping flag for cstindex'>>                      07770000
  integer segnr; <<starting seg number>>                                07775000
  integer trace'plabel;  <<trace0' external label>>                     07780000
  logical mode;                                                         07785000
  integer                                                               07790000
      pvinfo,                                                           07795000
      jsmp;                                                             07800000
  integer pointer pxglob=s-0;                                           07805000
  equate                                                                07810000
      jitword = %13,                                           <<06666>>07815000
      jitsmp = 11;                                             <<06900>>07820000
  define ia=logical(sbuf0.(8:1))#;                                      07825000
  define ba=logical(sbuf0.(7:1))#;                                      07830000
                                                                        07835000
<<warnings about default stack space parameters taken>>        <<06102>>07840000
equate dflt'stacksize =  -9,  <<default stack size warn>>      <<06102>>07845000
       dflt'dlsize    = -10,  <<default dlsize         >>      <<06102>>07850000
       dflt'maxdata   = -11,  <<default maxdata        >>      <<06102>>07855000
       dlroundedup    = -12,  <<dl up to 128 wrd mult  >>      <<06102>>07860000
       configmaxdata  = -13,  <<maxdata @ config max   >>      <<06102>>07865000
       maxdataup      = -14;  <<maxdata @ stack space  >>      <<06102>>07870000
$page                                                                   07875000
integer subroutine wordaddress (byteaddress);                  <<06102>>07880000
   value byteaddress;                                          <<06102>>07885000
   byte pointer byteaddress;                                   <<06102>>07890000
                                                               <<06102>>07895000
begin                                                          <<06102>>07900000
   tos:=wordaddress:=@byteaddress & lsr(1);                    <<06102>>07905000
   push (z);                                                   <<06102>>07910000
   if <<wordaddress>> tos > tos <<z>> then                     <<06102>>07915000
      wordaddress.(0:1) := 1;                                  <<06102>>07920000
end;                                                           <<06102>>07925000
$page                                                                   07930000
  erroron;                                                              07935000
  condcode := cce;                                                      07940000
  turnofftraps;                                                         07945000
  pcbpt := pin * pcbsize;                                               07950000
  push(dl);                                                             07955000
  mode:=pxglob(-pxglob(-1)+6);                                          07960000
  tos := @jsmp;                                                         07965000
  tos := ps1 (-ps1 (-1) + jitword);                            <<06666>>07970000
  tos := jitsmp;                                                        07975000
  tos := 1;                                                             07980000
  assemble (mfds);                                                      07985000
  del;                                                                  07990000
  formatname(bentryname',entryname);  <<entry point name>>              07995000
  if flags.(10:2) = 3 then  <<illegal libsearch?>>                      08000000
     begin                                                              08005000
     tos := err20; go getout                                            08010000
     end;                                                               08015000
  stacksize' := stacksize;                                              08020000
  dlsize' := dlsize;                                                    08025000
  maxdata' := maxdata;                                                  08030000
  orig'dlsize := dlsize;                                       <<06102>>08035000
  orig'maxdata := maxdata; <<local copy of dlsize & maxdata>>  <<06102>>08040000
  if stringlength > 0 then                                     <<06102>>08045000
    if logical(stringlength) then                              <<06102>>08050000
      stcount := stringlength & lsr(1) + 1                     <<06102>>08055000
    else                                                       <<06102>>08060000
      if logical(@string) then                                 <<06102>>08065000
        stcount := stringlength & lsr(1) + 2                   <<06102>>08070000
      else                                                     <<06102>>08075000
        stcount := stringlength & lsr(1);                      <<06102>>08080000
  processkey := double(logical(pin));                                   08085000
                                                                        08090000
  <<* * * open program file * * *>>                                     08095000
                                                                        08100000
  progfnum:=dfopen(progfname,%(2)10000000011,%(2)111110111);   <<06102>>08105000
  if < then  <<error?>>                                                 08110000
     begin                                                              08115000
     tos := err53; go getout                                            08120000
     end;                                                               08125000
  flock(progfnum,true);  <<get file exclusively>>                       08130000
  assemble(adds 6);                                            <<4493>> 08135000
  fgetinfo(progfnum,,,,,,s0,,s3,,,,,,,s4,,s5,,ds2);            <<4493>> 08140000
ldev:=s0;                                                      <<07316>>08145000
startaddr1:=s2.(8:8);                                          <<07316>>08150000
startaddr2:=s1;                                                <<07316>>08155000
endaddr:=startaddr+double(s4);                                 <<07316>>08160000
  bs2 := tos;  <<insert logical device nr.>>                            08165000
  progkey := tos;  <<prog. file key>>                                   08170000
  if tos <> progfilecode then  <<type program?>>                        08175000
     begin                                                              08180000
     tos := err31; go getout                                            08185000
     end;                                                               08190000
  pvinfo := mountvolset (progfnum,pin);                        <<06102>>08195000
  if < then     <<mount failed>>                               <<06102>>08200000
    begin                                                      <<06102>>08205000
      if pvinfo = -1 then                                      <<06102>>08210000
       begin                                                   <<06102>>08215000
          pvinfo := 0;                                         <<06102>>08220000
          tos:=err97;                                          <<06102>>08225000
          go getout;                                           <<06102>>08230000
       end;                                                    <<06102>>08235000
      pvinfo := 0;                                             <<06102>>08240000
      tos := err93;                                            <<06102>>08245000
      go getout;                                               <<06102>>08250000
    end;                                                       <<06102>>08255000
  savesir := getsir(segtabsir);  <<get segment table sir>>              08260000
  exchangedb(segtabdst);  <<set db to segment table>>                   08265000
  freaddir(progfnum,progrec0,128,0d);  <<read record 0>>                08270000
  if <> then go ioerror;  <<error?>>                                    08275000
s1 := s1+1+pexternalrecd;<<ext. s.a.+#filelabel+#userlabel>>   <<06102>>08280000
if tos > tos then   <<code not in 1st extent>>                 <<06102>>08285000
    begin                                                               08290000
    tos := err34; go abort                                              08295000
    end;                                                                08300000
                                                                        08305000
  if (ia lor ba) then                                                   08310000
    begin                                                               08315000
      if mode.(2:2)  then <<interactive>>                               08320000
        begin                                                           08325000
          <<set inteactive bit in pcb>>                        <<06102>>08330000
          lpcb(pin * pcbsize + queueinginfowordnum).           <<06648>>08335000
              interactiveflag := 1;                            <<06102>>08340000
          if not ia then                                                08345000
            begin                                                       08350000
              tos:=err39; go abort;                                     08355000
            end;                                                        08360000
        end                                                             08365000
       else <<batch>>                                                   08370000
        if not ba then                                                  08375000
          begin                                                         08380000
            tos:=err39; go abort;                                       08385000
          end;                                                          08390000
    end;                                                                08395000
  pentryrecd':=double(logical(pentryrecd));<<entry pt record>>          08400000
  <<get info on primary entry point>>                                   08405000
  sttindex:=pstartingstt;  <<stt #>>                                    08410000
  deltap' :=pstartingadr;  <<pb addr>>                                  08415000
  exchangedb(0);           <<db to stack>>                              08420000
  <<check if alternate entry point specified>>                          08425000
                                                                        08430000
  if bentryname' <> 0 then  <<entry point specified?>>                  08435000
    begin                                                               08440000
     freaddir(progfnum,sbuf4,128,pentryrecd');                          08445000
     if <> then go ioerror;  <<error?>>                                 08450000
     tos := @sbuf4&lsl(1);  <<target entry name>>                       08455000
     compname:                                                          08460000
     if bps0 = 0 then  <<end of list?>>                                 08465000
       begin                                                            08470000
        tos := err21; go abort                                          08475000
       end;                                                             08480000
     tos:=@bps0+(integer(bps0.(12:3))+3)&lsl(1);<<next name>>           08485000
     if @bps0 >= @sbuf4(128)&lsl(1) then  <<load next record?>>         08490000
       begin                                                            08495000
        move sbuf3 := sbuf4,(128);                                      08500000
        @bps1 := @bps1-p256;  <<adj. target pointer>>                   08505000
        tos := tos-p256;  <<adj. next target pointer>>                  08510000
        fread(progfnum,sbuf4,128);  <<read next record>>                08515000
        if <> then go ioerror  <<error?>>                               08520000
       end;                                                             08525000
     xreg := bentryname';  <<nr. char's>>                               08530000
     if integer(bps1.(12:4)) <> xreg then  <<nr. char's match?>>        08535000
       begin                                                            08540000
        nextentry:                                                      08545000
        delb;  <<delete target pointer>>                                08550000
        go compname  <<next name>>                                      08555000
       end;                                                             08560000
     do begin                                                           08565000
         if bentryname'(xreg) <> bps1(xreg) then go nextentry;          08570000
         xreg := xreg-1                                                 08575000
        end until =;                                                    08580000
     tos := tos&lsr(1);  <<convert to word pointer>>                    08585000
     tos := dps0(-1);  <<pb adr. and stt nr.>>                          08590000
     assemble(dxch,ddel);                                               08595000
     sttindex:=tos;        <<starting stt #>>                           08600000
     deltap' :=tos;        <<starting pb addr>>                         08605000
    end;                                                                08610000
  exchangedb(segtabdst);   <<db back to lst>>                           08615000
                                                                        08620000
  <<* * * determine data segment parameters * * *>>                     08625000
                                                                        08630000
  tos := if dlsize' = -1 <<init dlsize>>                                08635000
           then pdlsize                                                 08640000
           else dlsize';                                                08645000
  if < then  <<initial dlsize exceeds 32k?>>                            08650000
    if dlsize' = -1 then                                       <<06102>>08655000
      begin                                                    <<06102>>08660000
        tos:=err76;                                            <<06102>>08665000
        go abort;                                              <<06102>>08670000
      end                                                      <<06102>>08675000
    else                                                       <<06102>>08680000
      begin           <<bad dl from user>>                     <<06102>>08685000
        del;                                                   <<06102>>08690000
        tos:=pdlsize;                                          <<06102>>08695000
        if < then                                              <<06102>>08700000
          begin                                                <<06102>>08705000
            tos:=err76;                                        <<06102>>08710000
            go abort;                                          <<06102>>08715000
          end                                                  <<06102>>08720000
        else                                                   <<06102>>08725000
          loadwarn := dflt'dlsize;                             <<06102>>08730000
      end;                                                     <<06102>>08735000
  dlsize':=(tos+systemdl+pcbxsize+127) & lsr(7) & lsl(7)       <<06102>>08740000
            -pcbxsize;                                         <<06102>>08745000
  if < then      <<final dl bad>>                              <<06102>>08750000
    begin                                                      <<06102>>08755000
      tos:=err76;                                              <<06102>>08760000
      go abort;                                                <<06102>>08765000
    end;                                                       <<07316>>08770000
  if stacksize' = -1 then stacksize' := pstacksize;                     08775000
  if stacksize' < minstacksize then  <<stack too small?>>               08780000
    begin                                                               08785000
      <<take default stacksize from program file>>             <<06102>>08790000
      <<it is always >= 512                     >>             <<06102>>08795000
      loadwarn := dflt'stacksize;                              <<06102>>08800000
      stacksize' := pstacksize;                                <<s8608>>08805000
    end;                                                                08810000
  globalsize' := pglobalsize;                                           08815000
  if maxdata'=0 or maxdata'<-1 then                                     08820000
    begin <<illegal maxdata>>                                           08825000
      <<take default maxdata from program file>>               <<06102>>08830000
      loadwarn := dflt'maxdata;                                <<06102>>08835000
      maxdata' := pmaxdata;                                    <<07317>>08840000
    end;                                                                08845000
  if maxdata' = -1 then maxdata' := pmaxdata;                           08850000
  saflut := psaflut;  <<save s.a. of flut>>                             08855000
  sastlt := psastlt;  <<save s.a. of stlt>>                             08860000
  satrapcom := psatrapcom;  <<save s.a. of trapcom'>>                   08865000
  zerodb := pzerodb;  <<save zerodb flag>>                              08870000
  globalrecd := pglobalrecd;<<rec # of init global values>>             08875000
  capability' := pcapability;  <<save capability>>                      08880000
  tos := faccess(progfnum);                                             08885000
  tos := tos&lsr(3);  assemble( dup );                                  08890000
  tos := tos&lsr(2);  assemble( and,not );                              08895000
  capability'.(10:1) := tos;                                            08900000
                                                                        08905000
  <<* * * load program file * * *>>                                     08910000
                                                                        08915000
  tos := loadprogram (progfnum,progkey,processkey,                      08920000
                     flags.(10:6)&lsl(8),jsmp,savesir,pvinfo); <<06102>>08925000
  if < then go abort;  <<error?>>                                       08930000
  mapflag':=s0.(1:1); <<get mapping flag>>                              08935000
  tos.(1:1):=0;       <<clear flag      >>                              08940000
  tos := plabel cat s0 (8:8:8);  <<insert cst nr.>>                     08945000
  <<bit 0 0f plabel reflects mapping condition-->>                      08950000
  <<old firmware is set for physical mapping    >>                      08955000
  if not logicalmapping or mapflag' = 1                                 08960000
    then setbit0;                                                       08965000
  plabel := tos;  <<entry point p-label>>                               08970000
  tos.(0:1) := ls0.(0:1) land not pmode;<<adj priv mode bit>>           08975000
  cstindex' := tos;  <<starting cst nr. with mode bit>>                 08980000
  lsearch(progkey,pmode,progfile);                                      08985000
  spcbmapdst := emapdst;                                                08990000
  spcbpbx := ecstblk;                                                   08995000
  trace'plabel:=etrace'plabel;  <<get trace0' external label>>          09000000
                                                                        09005000
  << * * * check for valid launch data * * * >>                         09010000
                                                                        09015000
  segnr := if logicalmapping then cstindex'.(8:8)                       09020000
     else cstindex'.(10:6);                                             09025000
  if segnr > abs(cstext(ecstblk)+abs(dstb)) or                          09030000
     logical(deltap') >= abs(xreg+segnr*4)&lsl(2) then                  09035000
    begin    <<bad entry point data>>                                   09040000
      tos:=err45;                                                       09045000
      go abort;                                                         09050000
    end;                                                                09055000
  <<check if program is being traced>>                                  09060000
  if sastlt <> -1 then                                                  09065000
    begin  <<being traced>>                                             09070000
      <<use trace0' as the initial segment to execute>>                 09075000
      deltap':=convextlabeltodeltap(trace'plabel);                      09080000
      if logicalmapping                                                 09085000
        then mapflag':=trace'plabel.(0:1)                               09090000
        else mapflag':=0;                                               09095000
      cstindex':=trace'plabel.(8:8);                                    09100000
    end;                                                                09105000
                                                                        09110000
  <<* * * get dst entry and initialize data segment * * *>>             09115000
                                                                        09120000
  << insure enough stack to start the process up         >>    <<06102>>09125000
  << the stacksize < defaultdataseg can only occure by   >>    <<06102>>09130000
  << using prep inside of the segmenter or calling the   >>    <<06102>>09135000
  << segmenter directly. the ci prep command won't allow >>    <<06102>>09140000
  << such a specification.                               >>    <<06102>>09145000
                                                               <<06102>>09150000
  if stacksize' < abs(defaultdataseg) then                     <<06102>>09155000
    stacksize' := abs(defaultdataseg);                         <<06102>>09160000
                                                                        09165000
  tos := 0;  <<for result of getdataseg>>                               09170000
  tos:=double(logical(pcbxsize))+double(logical(dlsize'))+              09175000
       double(logical(globalsize'))+                                    09180000
       double(logical(stacksize'))+                                     09185000
       double(logical(stackoverflow))+                                  09190000
       double(logical(stcount));                               <<06102>>09195000
  << check if data segment size exceeds 32k wds >>                      09200000
  if ds1 > %77777d then                                                 09205000
     begin                                                              09210000
     delb;  << convert seg size to single precison >>                   09215000
     tos := err35; go abort                                             09220000
     end;                                                               09225000
  delb;  << convert segment size to single precision >>                 09230000
  tos:=(((s0+xtramaxdata+127)&lsr(7))+12)&lsl(7);<<vm space>>           09235000
  assemble(cab,cab);                                                    09240000
  xreg := absolute(maxdataseg);     << max data seg size >>             09245000
  if ls0 > lxreg then  <<data seg. exceeds sys. max.?>>                 09250000
     begin                                                              09255000
     tos := err36; go abort                                             09260000
     end;                                                               09265000
  if maxdata' = -1 then maxdata' := s0+xtramaxdata                      09270000
                   else maxdata' := maxdata'+xtramaxdata;               09275000
  if maxdata' < 0 or maxdata' > xreg then                               09280000
    begin                                                      <<06102>>09285000
      << set maxdata down to configuration maximum      >>     <<06102>>09290000
      << report warning if specified nax > conf max     >>     <<06102>>09295000
      if orig'maxdata > 0 and maxdata'-xtramaxdata > xreg      <<06102>>09300000
         and (loadwarn = 0 or loadwarn = dlroundedup) then     <<06102>>09305000
         loadwarn := configmaxdata;                            <<06102>>09310000
      maxdata' := xreg;                                        <<06102>>09315000
    end;                                                       <<06102>>09320000
  tos := maxdata';                                                      09325000
  assemble(ddup,lcmp);                                                  09330000
  if > then  <<data seg. > max. data seg.?>>                            09335000
     begin                                                              09340000
       loadwarn:=maxdataup;                                    <<06102>>09345000
       maxdata':=s1;                                           <<06102>>09350000
       s0:=maxdata';                                           <<06102>>09355000
     end;                                                               09360000
  dstindex' := getstack(*,*);  <<allocate data segment>>                09365000
  if = then                                                             09370000
    begin                                                               09375000
     exchangedb(dstindex');  <<set db to data segment>>                 09380000
     tos := pcbxsize+dlsize';  <<pointer to db+0>>                      09385000
     dbarea := 0; assemble(dzro,incb); tos := s2;                       09390000
     assemble(move 3);  <<zero pcbx and dl area>>                       09395000
     dbarea := s1;  <<insert vds in pcbx(0)>>                           09400000
     freaddir(progfnum,ps0,globalsize',                                 09405000
                           double(logical(globalrecd)));                09410000
     if <> then go ioerror;  <<error?>>                                 09415000
     ps0(-1) := saflut;  <<insert s.a. of flut>>                        09420000
     ps0 (-3) := satrapcom;  <<insert s.a. of trapcom'>>                09425000
     ps0(-6) := sastlt;  <<insert s.a. of stlt>>                        09430000
     ps0(-8) := plabel;  <<insert entry point p-label>>                 09435000
     ddel;  <<delete vds and pointer>>                                  09440000
    end                                                                 09445000
   else  <<no dst entry or no virtual memory>>                          09450000
    begin                                                               09455000
     if  >  then  tos :=  err66  else                                   09460000
     tos := err73; go abort                                             09465000
    end;                                                                09470000
                                                                        09475000
  <<* * * clean-up and return parameters * * *>>                        09480000
                                                                        09485000
  exchangedb(0);  <<reset db to stack>>                                 09490000
  if stringlength > 0 then                                     <<06102>>09495000
    begin                                                      <<06102>>09500000
      << string specified                                >>    <<06102>>09505000
      << move string to new stack. stcount has been set  >>    <<06102>>09510000
      << so that not necessary to word align the string  >>    <<06102>>09515000
      tos:= dstindex';                                         <<06102>>09520000
      tos:= pcbxsize+dlsize'+globalsize';                      <<06102>>09525000
      tos:= wordaddress(string);                               <<06102>>09530000
      tos:= stcount;                                           <<06102>>09535000
      assemble(mtds 4);                                        <<06102>>09540000
    end;                                                       <<06102>>09545000
  capability := capability';                                            09550000
  dstindex := dstindex';                                                09555000
  stacksize := stacksize';                                              09560000
  dlsize := dlsize';                                                    09565000
  maxdata := maxdata';                                                  09570000
  globalsize := globalsize';                                            09575000
  cstindex := cstindex';                                                09580000
  deltap := deltap';                                                    09585000
  mapflag:=mapflag';                                                    09590000
  tos := 0;  <<no error>>                                               09595000
  go getout;                                                            09600000
                                                                        09605000
  <<* * * error recovery * * *>>                                        09610000
                                                                        09615000
ioerror:                                                                09620000
  tos := err63;                                                         09625000
                                                                        09630000
abort:                                                                  09635000
  exchangedb(segtabdst);  <<set db to segment table>>                   09640000
  if lsearch(processkey,pmode,sharer) then  <<code loaded?>>            09645000
    begin                                                               09650000
     ldelete;  <<delete sharer entry>>                                  09655000
     lsearch(progkey,pmode,progfile);                                   09660000
     exchangedb (0);                                           <<06102>>09665000
     << need to specify another mount during this error >>     <<06102>>09670000
     << condition so that fclose can close prog file    >>     <<06102>>09675000
     mountvolset(progfnum);                                    <<06102>>09680000
     exchangedb (segtabdst);                                   <<06102>>09685000
     adjrefcounts(-1)  <<decrement reference counts>>                   09690000
    end;                                                                09695000
  exchangedb(0);  <<reset db to stack>>                                 09700000
  if pvinfo <> 0 then dismountvolset (pvinfo,pin);             <<06102>>09705000
  if dstindex' <> 0 then reldataseg(dstindex');                         09710000
                                                                        09715000
getout:                                                                 09720000
  if savesir <> -1 then relsir(segtabsir,savesir);                      09725000
  if progfnum <> 0 then  <<close prog. file?>>                          09730000
    begin                                                               09735000
     tos := errorget(1);  <<save error nr.>>                            09740000
   flush'cache(ldev,startaddr,endaddr);                        <<07316>>09745000
     fclose(progfnum,0,0);                                              09750000
     errorput(*,1)  <<restore error nr.>>                               09755000
    end;                                                                09760000
  if s0 <> 0 then condcode := ccl                              <<06102>>09765000
  else  if loadwarn <> 0 then                                  <<06102>>09770000
          begin                                                <<06102>>09775000
            del;                                               <<06102>>09780000
            condcode := ccg;                                   <<06102>>09785000
            tos:= loadwarn;                                    <<06102>>09790000
          end;                                                 <<06102>>09795000
  tos := [10/0,6/13]; assemble(xch,zero);                               09800000
  errorexit(*,*,*)                                                      09805000
end;                                                                    09810000
integer procedure loadprogram (progfnum,progkey,processkey,             09815000
                               command,pinnr,savesir,pvinfo);           09820000
   <<loads the given program file.  the starting cst number>>           09825000
   <<and mode bit is returned as the result.  note db must >>           09830000
   <<be set to the lst and the caller must have the lst sir>>           09835000
   <<this procedure uses condition code to indicate an error>>          09840000
   <<the error number is returned as the result             >>          09845000
   value progfnum,progkey,processkey,command,pinnr,savesir,pvinfo;      09850000
   integer progfnum,command,pinnr,savesir,pvinfo;                       09855000
   double progkey,processkey;                                           09860000
   option internal,uncallable;                                          09865000
  begin                                                                 09870000
   define allocate = logical(command.(0:1))#,  <<allocate?>>            09875000
          library = command.(2:2)#,  << library search >>               09880000
          pmode = command.(4:1)#,  <<normal/nopriv mode>>               09885000
          lmap = logical(command.(6:1))#;  <<lmap wanted?>>             09890000
   integer libsearch;                                                   09895000
                                                                        09900000
   subroutine lock;                                                     09905000
      begin                                                             09910000
      if not allocate then  <<normal load?>>                            09915000
         begin                                                          09920000
         tos := errorget(1);  <<save error nr.>>                        09925000
         flock(progfnum,true);                                          09930000
         errorput(*,1)  <<restore error nr.>>                           09935000
         end;                                                           09940000
      getsir(segtabsir);                                                09945000
      exchangedb(segtabdst);                                            09950000
      end;                                                              09955000
                                                                        09960000
   subroutine unlock(do'pdisable);                                      09965000
                    value do'pdisable; logical do'pdisable;             09970000
      begin                                                             09975000
      exchangedb(0);                                                    09980000
      if not allocate then funlock(progfnum);                           09985000
      if do'pdisable then pdisable;                                     09990000
      relsir(segtabsir,savesir);                                        09995000
      end;                                                              10000000
                                                                        10005000
   <<* * * create process entry * * *>>                                 10010000
                                                                        10015000
   if not allocate then  <<allocate program?>>                          10020000
      begin                                                             10025000
        lcreate(4,sharer,pmode,library,processkey);                     10030000
        if < then  <<error?>>                                           10035000
           begin                                                        10040000
           noroom:                                                      10045000
           tos := err70; go abort                                       10050000
           end;                                                         10055000
        entdp1:=progkey;  <<insert program file id >>                   10060000
      end;                                                              10065000
                                                                        10070000
   <<* * * check for loaded program file * * *>>                        10075000
tryagain:                                                               10080000
                                                                        10085000
   tos := 0;  <<for result of lsearch>>                                 10090000
   tos := progkey;                                                      10095000
   tos := pmode; assemble(tcbc 15);  <<opposite mode>>                  10100000
   if lsearch(*,*,progfile) then  <<loaded in other mode?>>             10105000
      begin                                                             10110000
      tos := err26; go abort                                            10115000
      end;                                                              10120000
   if lsearch(progkey,pmode,progfile) then<<already loaded?>>           10125000
      begin                                                             10130000
        if  allocate  then  go increment;                               10135000
        tos := @progrec0(28)&lsl(1);  <<cst re-mapping array>>          10140000
        tos := @progrec0+(pnrsegs+57)&lsr(1);<<seg desc array>>         10145000
                                          <<cst and mode>>              10150000
        tos:=bps1(pstartingseg) cat ps0(xreg) (0:0:1);                  10155000
        tos.(1:1):=entp.(12:1); <<get mapflag from entry>>              10160000
        go increment                                                    10165000
      end;                                                              10170000
                                                                        10175000
   <<* * * check for program file being loaded * * *>>                  10180000
                                                                        10185000
   tos := 0;  <<for result of lsearch>>                                 10190000
   tos := progkey;                                                      10195000
   tos := pmode; assemble(tcbc 15);  <<opposite mode>>                  10200000
   if lsearch(*,*,loading) then  <<loading in other mode?>>             10205000
      begin                                                             10210000
      tos := err26; go abort                                            10215000
      end;                                                              10220000
   if lsearch(progkey,pmode,loading) then  <<being loaded?>>            10225000
      begin                                                             10230000
        <<build waiting entry>>                                         10235000
        lcreate(5,waiting,pmode,library,progkey);                       10240000
        if < then go noroom;  <<error?>>                                10245000
        ewaitingpin := userpin;  <<pin of waiting process>>             10250000
        unlock(1);                       <<implied pdisable>>           10255000
        impede(0);                       <<implied penable>>            10260000
                                                                        10265000
        <<sleep>>                                                       10270000
                                                                        10275000
        lock;                                                           10280000
        lsearch(progkey,pmode,loaded);  <<find waiting entry>>          10285000
        tos:=entdp2; <<parameter and error no.>>                        10290000
        ldelete;                                                        10295000
        assemble(test);                                                 10300000
        if <> then  <<error?>>                                          10305000
           begin                                                        10310000
           assemble(stbx);                                              10315000
           if <> then errorput(xreg,1);<<file sys error #>>             10320000
           go abort                                                     10325000
           end;                                                         10330000
        del;                                                            10335000
        if lsearch(progkey,pmode,progfile) <<get prog. entry>>          10340000
          then go increment  <<found entry>>                            10345000
          else go tryagain;  <<program already terminated>>             10350000
      end;                                                              10355000
                                                                        10360000
   <<* * * activate load process * * *>>                                10365000
                                                                        10370000
   <<build loading entry>>   <<build loading entry>>                    10375000
   lcreate(3,loading,pmode,library,progkey);                            10380000
   if < then go noroom;  <<error?>>                                     10385000
   unlock(0);                                                           10390000
   tos := 0d;  <<for result of loader>>                                 10395000
   tos := command;                                                      10400000
   if logicalmapping                                                    10405000
     then tos.(5:1):=0 <<mapping firmware present-->>                   10410000
                       <<all program loads mapped  >>                   10415000
     else tos.(5:1):=1;<<mapping firmware not present-->>               10420000
                       <<all program loads physical map>>               10425000
   tos:=pinnr;                                                          10430000
   tos := progkey;                                                      10435000
   tos := 0;  <<don't care>>                                            10440000
   tos := pvinfo;                                                       10445000
   tos := loader (*,*,*,*,*,*);                                         10450000
   lock;                                                                10455000
   assemble(test);                                                      10460000
   if <> then  go abort;                                       <<06102>>10465000
   del;                                                                 10470000
   go aok;                                                              10475000
                                                                        10480000
   <<* * * increment the reference counts * * *>>                       10485000
                                                                        10490000
increment:                                                              10495000
   adjrefcounts(1);  <<increment ref. counts>>                          10500000
   if lmap then  <<lmap requested?>>                                    10505000
      begin                                                             10510000
        exchangedb(0);  <<reset db to stack>>                           10515000
        genmsg(9,warn88);   << lmap not available >>                    10520000
        exchangedb(segtabdst);  <<set db to segment table>>             10525000
        if < then  <<print error?>>                                     10530000
           begin                                                        10535000
           printerror:                                                  10540000
           tos := err75; go abort                                       10545000
           end                                                          10550000
      end;                                                              10555000
   if  elib <> library  then  << different libsearch >>                 10560000
      begin                                                             10565000
        libsearch := elib;  << offset to find g, p or s >>              10570000
        exchangedb(0);      << db to stack >>                           10575000
        genmsg(9,warn89+libsearch);  << program loaded with >>          10580000
                                 << lib = (s, p or g)   >>              10585000
        tos := 0;  <<return for exchangedb>>                            10590000
        tos := segtabdst;                                               10595000
        exchangedb (*); <<set db to segment table>>                     10600000
        if  <  then  go printerror;                                     10605000
      end;                                                              10610000
                                                                        10615000
aok:                                                                    10620000
   tos := cce;  <<ok condition code>>                                   10625000
   go getout;                                                           10630000
                                                                        10635000
abort:                                                                  10640000
   if lsearch(processkey,pmode,sharer) then ldelete;                    10645000
   tos := ccl;  <<error condition code>>                                10650000
                                                                        10655000
getout:                                                                 10660000
   condcode := tos;  <<store condition code>>                           10665000
   loadprogram := tos  <<parameter>>                                    10670000
  end;                                                                  10675000
double procedure loader (command,pinnr,num1,num2,string,pvinfo);        10680000
   <<load process communication procedure.               >>             10685000
   <<returns a double                                    >>             10690000
   <<result:  the 1st word (s-1) is a parm (0 if error)  >>             10695000
   <<the 2nd word (s-0) is an error number (0 if no error)>>            10700000
   value command,pinnr,num1,num2,pvinfo;                                10705000
   integer command,pinnr,num1,num2,pvinfo;                              10710000
   byte array string;                                                   10715000
   option internal,uncallable;                                          10720000
   begin                                                                10725000
   integer  i, sirf, sirf2, tf, tlf, lf;                       <<*8526>>10730000
   integer array parms (*) = command;                                   10735000
   equate maillength = 22;  <<mail buffer length>>                      10740000
   integer array mailbuf(0:81)=q; <<mail buffer>>                       10745000
   integer array list(*)=mailbuf+10;                                    10750000
   byte array listb(*) = list;                                          10755000
                                                                        10760000
   subroutine  ferror(f,d);                                             10765000
      value f,d; integer f; logical d;                                  10770000
      begin  << called on a file error >>                               10775000
        move  list := "FILE ERROR #     ON ";                           10780000
        if f=0 or f=lf then move list(10) := "LOADLIST" else            10785000
        if  f=tlf  then  move  list(10) := "LOADTEMP" else              10790000
        move  list(10) := "LOADPROC";                                   10795000
        fcheck(f,i);                                                    10800000
        ascii(i,10,listb(12));                                          10805000
        print(list,-28,0);                                              10810000
        if d then                                                       10815000
        begin << close loader process file and relsir >>                10820000
           fclose(tf,0,0);                                              10825000
           relsir(loadsir,sirf);                                        10830000
        end else fclose(lf,0,0); << close list file >>                  10835000
        go done;                                                        10840000
      end;                                                              10845000
                                                                        10850000
                                                                        10855000
                                                                        10860000
   tf := tlf := lf := -1; << null file nums >>                          10865000
   sirf := getsir(loadsir);                                             10870000
                                                                        10875000
   <<* * * initialize mail data segment * * *>>                         10880000
                                                                        10885000
   if logical(command.(1:1)) then                                       10890000
      begin                                                             10895000
         move mailbuf := parms,(3);                                     10900000
         formatname(mailbuf(3),string);                                 10905000
      end                                                               10910000
   else                                                                 10915000
      move mailbuf := parms,(4);                                        10920000
   who( ,mailbuf(11),,,mailbuf(13),mailbuf(17) );                       10925000
  mailbuf(11) := curprc;                                       <<06648>>10930000
   mailbuf (21) := pvinfo;                                              10935000
                                                               <<*8526>>10940000
   sirf2 := getsir(segtabsir);                                 <<*8526>>10945000
   <<get offset to lct in lst>>                                         10950000
   tos:=@i;               <<receive lct offset>>                        10955000
   tos:=segtabdst;        <<lst>>                                       10960000
   tos:=lctptr;              <<offset to lct ptr>>                      10965000
   tos:=1;                <<1 word>>                                    10970000
   assemble(mfds 4);                                                    10975000
   <<move mailbuf to lct in lst>>                                       10980000
   tos:=segtabdst;        <<lst>>                                       10985000
   tos:=i;                <<offset to lct>>                             10990000
   tos:=@mailbuf;         <<addr of mailbuf>>                           10995000
   tos:=maillength;       <<size of transfer>>                          11000000
   assemble(mtds 4);                                                    11005000
   relsir(segtabsir,sirf2);                                    <<*8526>>11010000
                                                               <<*8526>>11015000
                                                                        11020000
tos:=load'message;                                             <<*7558>>11025000
awake(sysproc(8),%20,0);                                       <<*7558>>11030000
sendmsg(sysproc(8)/pcbsize,4,1,%40000);                        <<*7912>>11035000
assemble(adds 1);                                              <<*7558>>11040000
receivemsg(4,1,%40000);                                        <<*7912>>11045000
if tos<>load'done'message then                                 <<*7558>>11050000
   suddendeath(347);                                           <<*7558>>11055000
                                                                        11060000
                                                                        11065000
   <<* * * extract answer of load process * * *>>                       11070000
                                                               <<*8526>>11075000
   sirf2 := getsir(segtabsir);                                 <<*8526>>11080000
   tos:=@mailbuf;         <<receive answer>>                            11085000
   tos:=segtabdst;        <<lst>>                                       11090000
   tos:=i;                <<offset to lct>>                             11095000
   tos:=6;                <<size of answer>>                            11100000
   assemble(mfds 4);                                                    11105000
   relsir(segtabsir,sirf2);                                    <<*8526>>11110000
                                                               <<*8526>>11115000
                                                                        11120000
   tos:=mailbuf(0);                                                     11125000
   tos:=mailbuf(1);                                                     11130000
   if <> then  <<error?>>                                               11135000
      begin                                                             11140000
      assemble(stbx);  <<parameter>>                                    11145000
      if <> then errorput(xreg,1);  <<file sys. error?>>                11150000
      assemble(zero,xch)  <<zero parameter>>                            11155000
      end;                                                              11160000
   loader := tos;  <<return result>>                                    11165000
   if logical(mailbuf(2)) then                                          11170000
     begin  << copy the file from the load process >>                   11175000
       tos := 0;                                                        11180000
       tos:=mailbuf(3);       <<ldev>>                                  11185000
       tos:=mailbuf(4);       <<disk>>                                  11190000
       tos:=mailbuf(5);       <<addr>>                                  11195000
       tf := fopenda(*,*);                                              11200000
       if  <>  then  ferror(tf,true);                                   11205000
       move list := "LOADTEMP ";                                        11210000
       tlf := fopen(list,%2104,4,36); << open temp file>>               11215000
       if <> then ferror(tlf,true);                                     11220000
       i := fread(tf,list,-72);                                         11225000
       if < then ferror(tf,true);                                       11230000
       while = do                                                       11235000
        begin << copy loadlist file to temp. holding file >>            11240000
           fwrite(tlf,list,-i,0);                                       11245000
           if <> then ferror(tlf,true);                                 11250000
           i := fread(tf,list,-72);                                     11255000
           if < then ferror(tf,true);                                   11260000
        end;                                                            11265000
       fcloseda (tf,0,0); <<close loader produced file>>                11270000
       relsir(loadsir,sirf);                                            11275000
       fcontrol(tlf,5,0); << rewind temp file >>                        11280000
       if <> then ferror(tlf,false);                                    11285000
       move  list := "LOADLIST  ";                                      11290000
       lf := fopen(list,%14,%301);                                      11295000
       if  <>  then  ferror(lf,false);                                  11300000
       i := fread(tlf,list,-72);                                        11305000
       if < then ferror(tlf,false);                                     11310000
       while = do                                                       11315000
        begin  << copy a line >>                                        11320000
           fwrite(lf,list,-i,0);                                        11325000
           if <> then ferror(lf,false);                                 11330000
           i := fread(tlf,list,-72);                                    11335000
           if  <  then  ferror(tlf,false);                              11340000
        end;                                                            11345000
       fclose(lf,0,0);                                                  11350000
 done:                                                                  11355000
       fclose(tlf,0,0);                                                 11360000
     end else relsir(loadsir,sirf);                                     11365000
   end;                                                                 11370000
procedure adjrefcounts (amount);                                        11375000
   <<adjusts the ref counts for the cst entries in the >>               11380000
   <<current entry by amount.  will unload any segment >>               11385000
   <<whose ref count goes to zero.  will delete the entry>>             11390000
   <<if its a program file entry and the share count has >>             11395000
   <<gone to zero                                        >>             11400000
   value amount;                                                        11405000
   integer amount;                                                      11410000
   option uncallable;                                                   11415000
   begin                                                                11420000
   integer amount' = si;  <<reference count increment>>                 11425000
   logical deleteflag := false;  << delete program entry? >>            11430000
   integer pvinfo:=0;                                                   11435000
   integer pointer slsegs = so;  <<sl cst bit map>>                     11440000
                                                                        11445000
   subroutine dismountvs;                                      <<06102>>11450000
       begin                                                   <<06102>>11455000
           tos := exchangedb (0); <<to stack>>                 <<06102>>11460000
           dismountvolset (pvinfo);                            <<06102>>11465000
           asmb (zero, xch);                                   <<06102>>11470000
           exchangedb (*);                                     <<06102>>11475000
           pvinfo := 0;                                        <<06102>>11480000
       end;                                                    <<06102>>11485000
                                                                        11490000
   subroutine unloadfile;                                               11495000
      <<clears the "LOADED" bit in the file label of the >>             11500000
      <<current entry, dismounts the file's home volume set>>           11505000
      <<if necessary, and deletes the current entry.     >>             11510000
      begin                                                             11515000
        loadbit(efid,false,segtabdst); <<clear loaded bit>>             11520000
        ldelete  <<delete entry>>                                       11525000
      end;                                                              11530000
                                                                        11535000
   if  etype = progfile  then                                           11540000
      begin                                                             11545000
        tos:=eshr;               <<old share count>>                    11550000
        assemble(dup);                                                  11555000
        eshr:=tos+amount;        <<update share count>>                 11560000
        tos:=eshr;    <<update count in cst block>>                     11565000
        disable;                                                        11570000
        xreg := cstext(ecstblk)+absolute(dstb)+2;                       11575000
        absolute(xreg):=tos;                                            11580000
        enable;                                                         11585000
        <<if progfile allocated or        >>                            11590000
        <<old count*new count <> 0        >>                            11595000
      if  epa = 1  or  tos*eshr <> 0  then                     <<06102>>11600000
      begin                                                    <<06102>>11605000
         if amount < 0 <<unload>>  and                         <<06102>>11610000
          (pvinfo := epvinfo'prog) <> 0 then dismountvs;       <<06102>>11615000
          return;                                              <<06102>>11620000
      end;                                                     <<06102>>11625000
        if  eshr = 0  then  deleteflag := true;                         11630000
      end;                                                              11635000
                                                                        11640000
   amount' := amount;                                                   11645000
   tos:=@entp;         <<save pointers>>                                11650000
   tos:=@entp1;                                                         11655000
   tos:=@entp2;                                                         11660000
   tos:=@entp3;                                                         11665000
   @pss:=@entp2+1; <<1st slid>>                                         11670000
   if etype = progfile                                                  11675000
     then sk:=eslinfo'prog                                              11680000
     else if etype = extension                                          11685000
            then sk:=eslinfo'ext                                        11690000
            else sk:=0;                                                 11695000
   <<cycle thru each sl info area>>                                     11700000
   while (sk:=sk-1) >= 0 do                                             11705000
     begin                                                              11710000
       @pst:=@pss+sk*19; <<ptr to slid>>                                11715000
       if lsearch(dpst,normal,slfile) then                              11720000
         begin              <<found sl entry>>                          11725000
           @pst:=@pst+2;    <<ptr to seg array>>                        11730000
           lstep(adjseg);   <<adjust refcount of>>                      11735000
                            <<all referenced segs>>                     11740000
           if eallocseg'sl = 0 then                                     11745000
             begin          <<sl has no allocated segs>>                11750000
               pvinfo:=epvinfo'sl;                                      11755000
               unloadfile;  <<unload sl>>                               11760000
               if pvinfo <> 0 then                             <<06102>>11765000
                  dismountvs;                                  <<06102>>11770000
             end;                                                       11775000
         end;                                                           11780000
     end; <<while>>                                                     11785000
                                                                        11790000
   @entp3:=tos;                                                         11795000
   @entp2:=tos;             <<restore ptrs to orig entry>>              11800000
   @entp1:=tos;                                                         11805000
   @entp:=tos;                                                          11810000
                                                                        11815000
   if  etype = progfile and amount < 0 <<unload>> then         <<06102>>11820000
    pvinfo := epvinfo'prog;                                    <<06102>>11825000
   if deleteflag then    << unload program file? >>                     11830000
      begin                                                             11835000
      dealcstblock(ecstblk); <<relprog cstx blk>>                       11840000
      << release segmap dst >>                                          11845000
      if emapdst <> 0 then reldataseg(emapdst);                         11850000
      unloadfile;                                                       11855000
      end;                                                              11860000
   if pvinfo <> 0 then dismountvs;                             <<06102>>11865000
                                                                        11870000
end; << adjrefcounts >>                                                 11875000
procedure adjseg(logsegnr);                                             11880000
  <<support procedure for adjrefcounts procedure>>                      11885000
  <<entp points to an sl entry   >>                                     11890000
  <<sl seg list entries are searched>>                                  11895000
  <<until correct entry is found    >>                                  11900000
  <<  -refcount is adjusted         >>                                  11905000
  <<  -if 0 then release code seg   >>                                  11910000
  <<        and free seg list entry >>                                  11915000
  value logsegnr;                                                       11920000
  integer logsegnr;                                                     11925000
  option internal,uncallable;                                           11930000
  begin                                                                 11935000
    integer amount = si;  <<reference count increment>>                 11940000
    integer temp1;                                                      11945000
    integer pointer ptemp2,ptemp3;                                      11950000
    @ptemp3:=@entp+5;     <<ptr to log seg array>>                      11955000
    temp1:=eslseg'sl;     <<# sl seg list entries>>                     11960000
    @ptemp2:=@entp+21+temp1*3; <<ptr to seg list entry>>                11965000
    <<cycle thru seglist entries until correct>>                        11970000
    <<entry is found                          >>                        11975000
    while (temp1:=temp1-1) >= 0 do                                      11980000
      begin                                                             11985000
        @ptemp2:=@ptemp2-3;     <<next entry>>                          11990000
        if sllogsegnr=logsegnr then                                     11995000
          begin                 <<found it>>                            12000000
            refcount:=refcount+amount; <<adjust>>                       12005000
            if refcount = 0 then                                        12010000
              begin             <<no usage>>                            12015000
                relcodeseg(phycst);<<release cst>>                      12020000
                eallocseg'sl:=eallocseg'sl-1;                           12025000
                             <<# allocated seg in sl>>                  12030000
                tos:=@ptemp3;   <<ptr to seg array>>                    12035000
                clearbit(*,logsegnr);                                   12040000
                             <<clear allocated bit>>                    12045000
                phycst:=0;   <<clear seglist entry>>                    12050000
                sllogsegnr:=255;<<mark it free    >>                    12055000
              end;                                                      12060000
            return;                                                     12065000
          end;                                                          12070000
      end; <<while>>                                                    12075000
    suddendeath(346);  <<entry never found>>                            12080000
   end;                                                                 12085000
procedure loadbit (key,bit,dstnr);                                      12090000
   <<sets or clears (depending on the value of bit) the >>              12095000
   <<"LOADED" bit in the file label of file "KEY".  db may>>            12100000
   <<be set to stack or lst.  note this procedure uses    >>            12105000
   <<the condition code to indicate an error>>                          12110000
   value key,bit,dstnr;                                                 12115000
   double key;                                                          12120000
   logical bit;                                                         12125000
   integer dstnr;                                                       12130000
   option uncallable;                                                   12135000
   begin                                                                12140000
   integer                                                              12145000
       savesir;    << sir value >>                                      12150000
   integer pointer                                                      12155000
       flabel;     << file label buffer >>                              12160000
   subroutine readwrite (code);                                         12165000
      <<reads or writes (depending on the value of code) >>             12170000
      <<the file label>>                                                12175000
      value code;                                                       12180000
      integer code;                                                     12185000
      begin                                                             12190000
          tos := 0d; << for flabio return and ldev # >>                 12195000
          tos := key&tasl(8)&dlsr(8);<<ldev,disc addr>>                 12200000
          tos := s5; << read/write code >>                              12205000
          tos := @flabel;                                               12210000
          tos := flabio(*,*,*,*);                                       12215000
          if tos <> 0 then go nfg;                                      12220000
      end;                                                              12225000
                                                                        12230000
   <<* * * initialize local variables * * *>>                           12235000
                                                                        12240000
   savesir := getsir(filesyssir);                                       12245000
   if dstnr <> 0 then dstnr := exchangedb(0);                           12250000
   push(s); << set flabel >>                                            12255000
   @flabel := tos + 1;                                                  12260000
   assemble(adds 128); << allocate buffer >>                            12265000
                                                                        12270000
   readwrite(attioread);  <<read file label>>                           12275000
   floadbit := bit;  <<clear/set "LOADED" bit>>                         12280000
   readwrite(attiowrite);  <<write file label>>                         12285000
   tos := cce;  <<ok condition code>>                                   12290000
   go getout;                                                           12295000
                                                                        12300000
   nfg:                                                                 12305000
   tos := ccl;  <<error condition code>>                                12310000
                                                                        12315000
   getout:                                                              12320000
   if dstnr <> 0 then exchangedb(dstnr);                                12325000
   relsir(filesyssir,savesir);  <<release file system sir>>             12330000
   condcode := tos  <<store condition code>>                            12335000
   end;                                                                 12340000
procedure unload (pin);                                                 12345000
   <<unloads the segments of the specified process >>                   12350000
   <<condition code conventions:                   >>                   12355000
   <<                                              >>                   12360000
   <<    cce   request granted                     >>                   12365000
   <<    ccl   request denied - invalid pin        >>                   12370000
   <<                                              >>                   12375000
   <<note that it is assumed that db is set to the >>                   12380000
   <<stack of the process being unloaded           >>                   12385000
   value pin;                                                           12390000
   integer pin;                                                         12395000
   option privileged,uncallable;                                        12400000
   begin                                                                12405000
     integer pcbpt;  << index of pcb entry >>                           12410000
     integer nrprogsegs=sp, <<#prog file segs for logging>>             12415000
             nrslsegs=sq;   <<#non-mpe sl segs for logging>>            12420000
     double nrsegs=nrprogsegs;                                          12425000
     integer pointer pcbxfixedp,                                        12430000
                     auxentp,                                           12435000
                     auxentp1,                                          12440000
                     auxentp2,                                          12445000
                     auxentp3;                                          12450000
     integer pcb'loaderflags,                                           12455000
             pcb'mapdst,                                                12460000
             savesir,                                                   12465000
             savedb,                                                    12470000
             mode,                                                      12475000
             active'lprocs',                                            12480000
             idx;                                                       12485000
      double cputime;                                          <<07318>>12490000
     integer array cputimearray(*)=cputime;                    <<07318>>12495000
     logical logging;                                                   12500000
     double key,                                                        12505000
            nrsegs';                                                    12510000
     integer nrprogsegs'=nrsegs',                                       12515000
             nrslsegs'=nrsegs'+1;                                       12520000
     define pcb'localsegmap = pcb'loaderflags.(14:1)#,                  12525000
            pcb'loadprocflag = pcb'loaderflags.(15:1)#,                 12530000
            log'procterm = absolute(logflag).(11:1)#,                   12535000
            log'enabled = absolute(logflag).(15:1)#;                    12540000
                                                                        12545000
subroutine sumslsegs;                                                   12550000
  <<compute the number of non-mpe sl >>                                 12555000
  <<segments referenced.             >>                                 12560000
  <<for each sl info area            >>                                 12565000
  <<  -find sl entry                 >>                                 12570000
  <<  -call lstep                    >>                                 12575000
  begin                                                                 12580000
    tos:=@entp;                                                         12585000
    tos:=@entp1;                                                        12590000
    tos:=@entp2;                                                        12595000
    tos:=@entp3;                                                        12600000
    @pss:=@entp2+1; <<1st slid>>                                        12605000
    if etype = progfile                                                 12610000
      then sk:=eslinfo'prog                                             12615000
      else if etype = extension                                         12620000
             then sk:=eslinfo'ext                                       12625000
             else sk:=0;                                                12630000
    <<cycle thru each sl info area>>                                    12635000
    while (sk:=sk-1) >= 0 do                                            12640000
      begin                                                             12645000
        @pst:=@pss+sk*19;    <<ptr to slid>>                            12650000
        if lsearch(dpst,normal,slfile) then                             12655000
          begin                 <<sl entry found>>                      12660000
            @pst:=@pst+2;       <<ptr to seg array>>                    12665000
            lstep(sumsegs);     <<count non-mpe seg>>                   12670000
          end else                                                      12675000
          begin                 <<sl entry not found>>                  12680000
            suddendeath(345);                                           12685000
          end;                                                          12690000
      end; <<while>>                                                    12695000
    @entp3:=tos;                                                        12700000
    @entp2:=tos;                <<restore ptrs to >>                    12705000
    @entp1:=tos;                <<original entry  >>                    12710000
    @entp:=tos;                                                         12715000
  end; <<sumslsegs>>                                                    12720000
                                                                        12725000
     <<initialize local variables>>                                     12730000
     pcbpt := pin * pcbsize;                                            12735000
     pcbxp; <<ptr to pcbxfixed area>>                                   12740000
     @pcbxfixedp:=tos;                                                  12745000
     pcb'loaderflags:=pcbxfixedp(6); <<loader flags>>          <<06666>>12750000
     logging:=log'procterm land log'enabled; <<logging flag>>           12755000
     pcb'mapdst := spcbmapdst;                                          12760000
     spcbmapdst := 0; <<clear pcb>>                                     12765000
     if pcb'mapdst <> 0 then                                   <<06742>>12770000
        adjustlocality(pcbpt,double(pcb'mapdst),0,1);          <<06742>>12775000
     if pcb'localsegmap = 1 then                                        12780000
       begin                                                            12785000
         <<this pin has a local segmap--release it>>                    12790000
         if pcb'mapdst <> 0 then                               <<07316>>12795000
         reldataseg(pcb'mapdst);                                        12800000
       end;                                                             12805000
     savesir:=getsir(segtabsir);                                        12810000
     savedb:=exchangedb(segtabdst);                                     12815000
     nrsegs:=0d; <<initialize logging data>>                            12820000
     <<find sharer entry for pin>>                                      12825000
     key:=double(logical(pin)); <<process pin>>                         12830000
     if lsearch(key,anymode,sharer) then                                12835000
       begin <<found entry>>                                            12840000
         <<use sharer entry to find progfile entry>>                    12845000
         key:=entdp1; <<prog key>>                                      12850000
         mode:=epmode;<<prog mode>>                                     12855000
         ldelete;     <<delete sharer entry>>                           12860000
         if lsearch(key,mode,progfile) then                             12865000
           begin <<found entry>>                                        12870000
             if logging then                                            12875000
               begin <<log info desired>>                               12880000
                 nrprogsegs:=eseg; <<#prog segs>>                       12885000
                 sumslsegs;        <<#non-mpe sl segs>>                 12890000
               end;                                                     12895000
             adjrefcounts(-1); <<dec seg ref counts>>                   12900000
           end;                                                         12905000
       end;                                                             12910000
     <<check for any loadproc'ed segments>>                             12915000
     if pcb'loadprocflag = 1 then                                       12920000
       begin                                                            12925000
         <<this pin has issued a loadproc request>>                     12930000
         <<find loadprocmaster entry>>                                  12935000
         key:=double(logical(pin));                                     12940000
         if lsearch(key,anymode,loadprocmaster) then                    12945000
           begin <<fount entry>>                                        12950000
             <<if any active extension entries>>                        12955000
             <<  .find extension entry        >>                        12960000
             <<  .adjust seg ref counts       >>                        12965000
             <<  .delete extension entry      >>                        12970000
             <<delete loadprocmaster entry    >>                        12975000
             if active'lprocs > 0 then                                  12980000
               begin                                                    12985000
                 <<active extensions must be unloaded>>                 12990000
                 @auxentp:=@entp; <<save loadprocmaster ptrs>>          12995000
                 @auxentp1:=@entp1;                                     13000000
                 @auxentp2:=@entp2;                                     13005000
                 @auxentp3:=@entp3;                                     13010000
                 active'lprocs':=active'lprocs;<<local copy>>           13015000
                 <<cycle thru possible extension indices>>              13020000
                 idx:=0;                                                13025000
                 while (idx:=idx+1) <= 255 and                          13030000
                       active'lprocs' > 0 do                            13035000
                   begin                                                13040000
                     <<check if index is being used>>                   13045000
                     if testbit(auxentp1,idx) then                      13050000
                       begin                                            13055000
                         <<this index is active>>                       13060000
                         <<find extension entry>>                       13065000
                         key:=double(logical(pin))&dlsl(16)    <<06542>>13070000
                              +double(idx);                    <<06542>>13075000
                         if lsearch(key,anymode,extension) then         13080000
                           begin                                        13085000
                             if logging then sumslsegs;                 13090000
                             adjrefcounts(-1);<<dec ref cnts>>          13095000
                             ldelete; <<delete extension >>             13100000
                             exchangedb(segtabdst'ex);         <<06542>>13105000
                             ldelete;                          <<06542>>13110000
                             exchangedb(segtabdst);            <<06542>>13115000
                             active'lprocs':=active'lprocs'-1;          13120000
                           end;                                         13125000
                       end;                                             13130000
                   end; <<while>>                                       13135000
                 @entp:=@auxentp; <<loadprocmaster ptrs>>               13140000
                 @entp1:=@auxentp1;                                     13145000
                 @entp2:=@auxentp2;                                     13150000
                 @entp3:=@auxentp3;                                     13155000
               end;                                                     13160000
             ldelete; <<delete loadprocmaster>>                         13165000
           end;                                                         13170000
       end;                                                             13175000
     nrsegs':=nrsegs; <<save logging data>>                             13180000
     relsir(segtabsir,savesir);                                         13185000
     exchangedb(savedb);                                                13190000
     if logging then begin    << set up and log it >>          <<07318>>13195000
       cputimearray(0):=pcbxfixedp(24);                        <<07318>>13200000
       cputimearray(1):=pcbxfixedp(25);                        <<07318>>13205000
       cputime:=cputime+999d;  << round up >>                  <<07318>>13210000
       if overflow then                                        <<07318>>13215000
         cputime:=2147483d                                     <<07318>>13220000
       else cputime:=cputime/1000d;                            <<07318>>13225000
       log4(nrprogsegs',nrslsegs',                             <<07318>>13230000
            pcbxfixedp(23),pcbxfixedp(26),pcbxfixedp(27),      <<07318>>13235000
            pin,cputime,4);                                    <<07318>>13240000
       end;  << logging >>                                     <<07318>>13245000
     condcode:=cce;                                                     13250000
   end;                                                                 13255000
procedure sumsegs(logsegnr);                                            13260000
  <<support procedure for unload>>                                      13265000
  <<increment nrslsegs[sq] if the logical segment>>                     13270000
  <<is not an mpe segment.                       >>                     13275000
  <<entp points to an sl entry                   >>                     13280000
  <<sl seg list entries are searched until the   >>                     13285000
  <<correct entry is found                       >>                     13290000
  <<    -mpe segment flag is tested              >>                     13295000
  value logsegnr;                                                       13300000
  integer logsegnr;                                                     13305000
  option internal,uncallable;                                           13310000
  begin                                                                 13315000
    integer temp1;                                                      13320000
    integer pointer ptemp2;                                             13325000
    integer nrslsegs = sq;  <<nr. sys. (non-mpe) sl seg's>>             13330000
    temp1:=eslseg'sl;   <<# sl seg list entries>>                       13335000
    @ptemp2:=@entp3+temp1*3;<<ptr to seg list entry>>                   13340000
    <<cycle thru seg list entries until >>                              13345000
    <<correct entry found               >>                              13350000
    while (temp1:=temp1-1) >= 0 do                                      13355000
      begin                                                             13360000
        @ptemp2:=@ptemp2-3;  <<next entry>>                             13365000
        if sllogsegnr=logsegnr then                                     13370000
          begin              <<found it>>                               13375000
            if not systemseg <<non-mpe sl seg>>                         13380000
              then nrslsegs:=nrslsegs+1;                                13385000
            return;                                                     13390000
          end;                                                          13395000
      end; <<while>>                                                    13400000
    suddendeath(344);  <<entry not found>>                              13405000
   end;                                                                 13410000
integer procedure loadproc (procname,libsearch,plabel);                 13415000
   <<loads the segment containing the named procedure >>                13420000
   <<and all segments containing externals of the     >>                13425000
   <<specified procedure.  libsearch specifies the first>>              13430000
   <<library to be searched.  the p-label (external form)>>             13435000
   <<of the procedure is returned.  also returned as the >>             13440000
   <<result is the procid number.  this number is used to>>             13445000
   <<unload the procedure.  the procedure name must be   >>             13450000
   <<formatted such that there are no leading blanks and >>             13455000
   <<it must be terminated with a blank.                 >>             13460000
   <<condition code conventions:                         >>             13465000
   <<                                                    >>             13470000
   <<    cce   request granted                           >>             13475000
   <<    ccl   request denied                            >>             13480000
   <<                                                    >>             13485000
   <<if ccl then the primary error number is returned as >>             13490000
   <<the result of the procedure; the secondary error numb>>            13495000
   <<(file sys err numb), if any, is in pcbx.  note this  >>            13500000
   <<procedure must be called with db set to the stack>>                13505000
   value libsearch;                                                     13510000
   byte array procname;                                                 13515000
   integer libsearch,plabel;                                            13520000
   begin                                                                13525000
     integer error,loadprocid;                                          13530000
     integer array option'nums(0:2),                                    13535000
                   options(0:1);                                        13540000
                                                                        13545000
     <<check parameters>>                                               13550000
     erroron;                                                           13555000
     chek([10/80,6/3],[8/0,2/1,1/0,5/3],[2/2,2/0,2/3]d);                13560000
                                                                        13565000
    <<upshift procname>>                                       <<06102>>13570000
    move procname:=procname while ans;                         <<06102>>13575000
     <<set up options to loadprocedure>>                                13580000
     option'nums(0):=1;  <<libsearch>>                                  13585000
     options(0):=libsearch;<<libsearch value>>                          13590000
     option'nums(1):=2;    <<flags>>                                    13595000
     if logicalmapping then                                             13600000
       begin               <<mapping firmware present>>                 13605000
         options(1):=0;    <<logical domain>>                           13610000
                           <<abort if unsat. externals>>                13615000
       end                                                              13620000
      else                                                              13625000
       begin               <<mapping firmware not present>>             13630000
         options(1):=1;    <<physical domain>>                          13635000
                           <<abort if unsat. externals>>                13640000
       end;                                                             13645000
     option'nums(2):=0;    <<end of list>>                              13650000
     loadprocedure(error,procname,loadprocid,plabel,                    13655000
                         option'nums,options);                          13660000
     if <> then                                                         13665000
       begin     <<error>>                                              13670000
         loadproc:=error;                                               13675000
         condcode:=ccl;                                                 13680000
       end                                                              13685000
      else                                                              13690000
       begin     <<ok >>                                                13695000
         loadproc:=loadprocid;                                          13700000
         condcode:=cce;                                                 13705000
       end;                                                             13710000
     errorexit([10/80,6/3],0,0);                                        13715000
   end;                                                                 13720000
procedure unloadproc (procid);                                          13725000
   <<unloads the segment containing the procedure specified >>          13730000
   <<by the procedure id number (procid) and all the segs   >>          13735000
   <<containing externals of the segment.                  >>           13740000
   <<condition code conventions:                           >>           13745000
   <<    cce   request granted                             >>           13750000
   <<    ccl   request denied - invalid procid             >>           13755000
   <<                                                      >>           13760000
   <<note that this procedure must be called with db set to>>           13765000
   << the stack                                            >>           13770000
   value procid;                                                        13775000
   integer procid;                                                      13780000
   begin                                                                13785000
    double key;                                                         13790000
    integer savedb,                                                     13795000
            pcbpt,                                             <<06648>>13800000
            savesir,                                                    13805000
            mcstidxtab'l'dl,                                            13810000
            procid',                                                    13815000
            idx,                                                        13820000
            idx2,                                                       13825000
            maxmcst,                                                    13830000
            seglen,                                                     13835000
            sttptr,                                                     13840000
            delta,                                                      13845000
            target,                                                     13850000
            source,                                                     13855000
            count;                                                      13860000
    logical segmap'adjust;                                              13865000
    integer array mcstidxtab'l(0:15)=q;                                 13870000
    integer pointer auxentp,                                            13875000
                    auxentp1,                                           13880000
                    auxentp2,                                           13885000
                    auxentp3;                                           13890000
                                                                        13895000
logical subroutine idx'set;                                             13900000
  <<return true if idx bit of mcstidxtab'l is set>>                     13905000
  begin                                                                 13910000
    xreg:=(idx&lsr(1)).(0:12);     <<proper word>>                      13915000
    tos:=mcstidxtab'l(xreg);       <<get proper word>>                  13920000
    xreg:=(idx&lsr(1)).(12:4);     <<proper bit>>                       13925000
    assemble(csl 1,x);             <<shift bit to bit 15>>              13930000
    s2:=tos; <<idx'set:=tos>>                                           13935000
  end;  <<idx'set>>                                                     13940000
                                                                        13945000
    erroron;                                                            13950000
    pcbpt := curprc;                                           <<06648>>13955000
    chek([10/81,6/1],[8/0,2/0,1/0,5/1]);                                13960000
    <<check validity of procid>>                                        13965000
    if not (1<=procid<=255) then go returnerror;                        13970000
    <<build key>>                                                       13975000
    tos:=userpin;                                                       13980000
    tos:=procid;                                                        13985000
    key:=tos;                                                           13990000
    procid':=procid;                                                    13995000
    segmap'adjust:=false;                                               14000000
    <<compute dl-rel addro of mcstidxtab'l>>                            14005000
    tos:=@mcstidxtab'l;                                                 14010000
    push(dl);                                                           14015000
    mcstidxtab'l'dl:=tos-tos;                                           14020000
    savesir:=getsir(segtabsir);                                         14025000
    savedb:=exchangedb(segtabdst);                                      14030000
    <<find extension entry>>                                            14035000
    if lsearch(key,anymode,extension) then                              14040000
      begin       <<found extension entry>>                             14045000
        loadproccount:=loadproccount-1;                                 14050000
        if loadproccount = 0 then                                       14055000
          begin                                                         14060000
            <<loadproc'ed procedure is no longer needed-->>             14065000
            <<try to unload procedure                    >>             14070000
            adjrefcounts(-1);<<dec counts on all ref'ed segs>>          14075000
            @auxentp:=@entp; <<save ptrs to extension entry>>           14080000
            @auxentp1:=@entp1;                                          14085000
            @auxentp2:=@entp2;                                          14090000
            @auxentp3:=@entp3;                                          14095000
            <<find loadprocmaster entry>>                               14100000
            <<adjust key>>                                              14105000
            tos:=key;                                                   14110000
            assemble(dlsr 16);                                 <<06280>>14115000
            key:=tos;                                                   14120000
            if lsearch(key,anymode,loadprocmaster) then                 14125000
              begin  <<found loadprocmaster entry>>                     14130000
                <<decrement # active loadproc's>>                       14135000
                active'lprocs:=active'lprocs-1;                         14140000
                <<free procid>>                                         14145000
                tos:=@entp1;  <<ptr to extidx table>>                   14150000
                clearbit(*,procid');                                    14155000
                <<use mcstref array to adjust refcount>>                14160000
                <<in loadprocmaster's mcstlogseg array>>                14165000
                @entp1:=@entp1+16; <<ptr to mcstidxtab>>                14170000
                sn:=auxentp3+1; <<mcstref array size>>                  14175000
                while (sn:=sn-1) > 0 do                                 14180000
                  begin                                                 14185000
                    sl:=auxentp3(sn).(8:8); <<mcstidx>>                 14190000
                    sk:=sl&lsl(1)+1;                                    14195000
                    entp3(sk):=entp3(sk)-1; <<refcount>>                14200000
                    if entp3(sk) = 0 then                               14205000
                      begin                                             14210000
                        <<this mapped cst # is no longer>>              14215000
                        <<needed--free it in mcstidxtab >>              14220000
                        entp3(sk-1):=0; <<clear entry>>                 14225000
                        tos:=@entp1; <<ptr to mcstidxtab>>              14230000
                        clearbit(*,sl);                                 14235000
                        segmap'adjust:=true; <<flag change >>           14240000
                      end;                                              14245000
                  end; <<while>>                                        14250000
                if segmap'adjust then                                   14255000
                  begin                                                 14260000
                    <<get local copy of final mcstidxtab>>              14265000
                    <<for use during segmap adjustment  >>              14270000
                    tos:=mcstidxtab'l'dl; <<target>>                    14275000
                    tos:=@entp1;          <<source>>                    14280000
                    tos:=16;              <<count>>                     14285000
                    assemble(mvbl 3);                                   14290000
                  end;                                                  14295000
              end                                                       14300000
             else                                                       14305000
              begin  <<loadprocmaster not found>>                       14310000
                suddendeath(352);                                       14315000
              end;                                                      14320000
            <<delete extension entry>>                                  14325000
            @entp:=@auxentp;  <<restore ptrs to extension>>             14330000
            @entp1:=@auxentp1;                                          14335000
            @entp2:=@auxentp2;                                          14340000
            @entp3:=@auxentp3;                                          14345000
            ldelete;                                                    14350000
            exchangedb(segtabdst'ex);                          <<06542>>14355000
            ldelete;                                           <<06542>>14360000
            exchangedb(segtabdst);                             <<06542>>14365000
          end                                                  <<06542>>14370000
        else                                                   <<06542>>14375000
          update'xdst;                                         <<06542>>14380000
        exchangedb(savedb);                                             14385000
        relsir(segtabsir,savesir);                                      14390000
      end                                                               14395000
     else                                                               14400000
      begin       <<extension entry not found>>                         14405000
        exchangedb(savedb);                                             14410000
        relsir(segtabsir,savesir);                                      14415000
        go returnerror;                                                 14420000
      end;                                                              14425000
    if segmap'adjust then                                               14430000
      begin                                                             14435000
        <<a change occurred in the mcstidxtab of the >>                 14440000
        <<loadprocmaster entry.  adjust the process's>>                 14445000
        <<segmap to agree                            >>                 14450000
        savedb := exchangedb(spcbmapdst);                      <<06648>>14455000
        maxmcst:=segmap(0).(8:8)&lsl(1);                                14460000
        seglen:=segmap(1);                                              14465000
        <<each valid mapped cst # which is no longer >>                 14470000
        <<used must be removed from the segmap--this >>                 14475000
        <<includes the mapped cst's external stt's   >>                 14480000
        idx:=0;                                                         14485000
        while (idx:=idx+2) <= maxmcst do                                14490000
          begin                                                         14495000
            <<check if mapped cst #idx is not being  >>                 14500000
            <<used now but was before unloadproc     >>                 14505000
            if not idx'set and                                          14510000
               segmap(idx) <> 0 then                                    14515000
              begin                                                     14520000
                <<this idx changed state>>                              14525000
                segmap(idx):=0; <<clear phycst>>                        14530000
                if segmap(idx+1) <> 0 then                              14535000
                  begin                                                 14540000
                    <<this idx has external stt's in segmap>>           14545000
                    <<which must be removed                >>           14550000
                    sttptr:=segmap(idx+1); <<ptr to stt's>>             14555000
                    delta:=segmap(sttptr)+1;<<# entries>>               14560000
                    target:=sttptr-segmap(sttptr);                      14565000
                    source:=sttptr+1;                                   14570000
                    count:=seglen-source;                               14575000
                    <<collapse stt's from segmap>>                      14580000
                    move segmap(target):=                               14585000
                                segmap(source),(count);                 14590000
                    seglen:=seglen-delta; <<new segmap len>>            14595000
                    segmap(idx+1):=0; <<clear sttptr>>                  14600000
                    <<adjust stt ptrs of other mapped cst's>>           14605000
                    idx2:=1;                                            14610000
                    while (idx2:=idx2+2) <= maxmcst+1 do                14615000
                      begin                                             14620000
                        if segmap(idx2) > source then                   14625000
                          segmap(idx2):=segmap(idx2)-delta;             14630000
                      end; <<while>>                                    14635000
                  end;                                                  14640000
              end;                                                      14645000
          end; <<while>>                                                14650000
        segmap(1):=seglen; <<save new length>>                          14655000
        exchangedb(savedb);                                             14660000
      end;                                                              14665000
    condcode:=cce;                                                      14670000
    errorexit([10/81,6/1],0,0);                                         14675000
    return;                                                             14680000
returnerror:                                                            14685000
    condcode:=ccl;                                                      14690000
    errorexit([10/81,6/1],0,0);                                         14695000
   end;                                                                 14700000
integer procedure allocateprog (progfname);                             14705000
   <<allocates or deallocates (depending on the entry point>>           14710000
   <<used) the specified program file. the only programs   >>           14715000
   <<that may be allocated in this fashion are those in    >>           14720000
   <<pub.sys.  only programs in the system domain may be   >>           14725000
   <<allocated.  the progam name must be formatted such that>>          14730000
   <<there are no leading blanks and it must be terminated >>           14735000
   <<with a special char.                                  >>           14740000
   <<condition code conventions:                           >>           14745000
   <<                                                      >>           14750000
   <<    cce   request granted                             >>           14755000
   <<                                                      >>           14760000
   <<                                                      >>           14765000
   <<if ccl then the primary error number is returned as   >>           14770000
   <<the result of the procedure; the secondary error number>>          14775000
   <<(file sys err numb), if any, is in the pcbx.  note this>>          14780000
   <<procedure must be called with db set to the stack>>                14785000
   byte array progfname;                                                14790000
   option uncallable;                                                   14795000
   begin                                                                14800000
   entry deallocateprog;                                                14805000
   logical flag:=false;   <<allocate/deallocate flag>>         <<06102>>14810000
   integer progfnum;                                           <<06102>>14815000
   double progkey;                                             <<06102>>14820000
   integer savesir;                                            <<06102>>14825000
   integer array progrec0(0:19)=q;                             <<06102>>14830000
   define saextlist = progrec0(13)#;                           <<06102>>14835000
                                                               <<06102>>14840000
   flag:=true;                                                 <<06102>>14845000
                                                               <<06102>>14850000
deallocateprog:                                                <<06102>>14855000
                                                                        14860000
   progfnum:=0;                                                         14865000
   progkey:=0d;                                                         14870000
   savesir:=-1;                                                         14875000
                                                                        14880000
   <<* * * open program file * * *>>                                    14885000
                                                                        14890000
   progfnum:=dfopen (progfname,%(2)10000000011,%(2)111110111); <<06102>>14895000
   if < then  <<error?>>                                                14900000
      begin                                                             14905000
      tos := err53; go abort                                            14910000
      end;                                                              14915000
   freaddir(progfnum,progrec0,20,0d);                          <<06102>>14920000
   assemble (adds 7);                                          <<06102>>14925000
   fgetinfo(progfnum,,s0,,,,s1,,s4,,,,,,,s5,,s6,,ds3);         <<06102>>14930000
   if tos.(14:2)=2 then   <<temporary file>>                   <<06102>>14935000
      begin                                                    <<06102>>14940000
      tos := err46;  go abort                                  <<06102>>14945000
      end;                                                     <<06102>>14950000
   bs2 := tos;  <<logical device nr.>>                                  14955000
   progkey := tos;  <<prog. key>>                                       14960000
   if tos <> progfilecode then  <<type program?>>                       14965000
      begin                                                             14970000
      tos := err31; go abort                                            14975000
      end;                                                              14980000
s1 := s1+1+saextlist;<<ext. s.a.+#filelabel+#userlabel>>       <<06102>>14985000
if tos > tos then   <<code not in 1st extent>>                 <<06102>>14990000
      begin                                                             14995000
      tos := err34; go abort                                            15000000
      end;                                                              15005000
   tos := fgetpvinfo (progfnum);                                        15010000
   fclose(progfnum,0,0);                                                15015000
   if tos <> 0 then                                                     15020000
   begin                                                       <<e9061>>15025000
    <<attempting to allocate/deallocate from non-sysem disc>>  <<e9061>>15030000
       tos := err92;  go abort;                                         15035000
   end;                                                                 15040000
   savesir := getsir(segtabsir);  <<get segment table sir>>             15045000
   exchangedb(segtabdst);  <<set db to segment table>>                  15050000
                                                                        15055000
   <<* * * allocate/deallocate program * * *>>                          15060000
                                                                        15065000
   if flag then  <<allocate?>>                                          15070000
      begin                                                             15075000
      tos:=loadprogram (0,progkey,0d,%100000,0,savesir,0);              15080000
      if < then go abort;  <<error?>>                                   15085000
      lsearch(progkey,normal,progfile);  <<find prog. entry>>           15090000
      if epa = 1 then  <<error?>>                                       15095000
         begin                                                          15100000
         tos := err80;                                                  15105000
         adjrefcounts(-1);                                              15110000
         go abort                                                       15115000
         end;                                                           15120000
      epa := 1;                                                         15125000
      end                                                               15130000
   else  <<deallocate>>                                                 15135000
      begin                                                             15140000
      if not lsearch(progkey,normal,progfile) or epa = 0 then           15145000
         begin                                                          15150000
         tos := err82; go abort                                         15155000
         end;                                                           15160000
      epa := 0;                                                         15165000
      adjrefcounts(-1)                                                  15170000
      end;                                                              15175000
   tos := cce;  <<ok condition code>>                                   15180000
   go getout;                                                           15185000
   help;   << dummy call to establish linking >>                        15190000
                                                                        15195000
   abort:                                                               15200000
   allocateprog := tos;  <<error nr.>>                                  15205000
   if progfnum <> 0 then fclose(progfnum,0,0);                 <<06102>>15210000
   tos := ccl;  <<error condition code>>                                15215000
                                                                        15220000
   getout:                                                              15225000
   exchangedb(0);  <<set db to stack>>                                  15230000
   if savesir <> -1 then relsir(segtabsir,savesir);                     15235000
   condcode := tos  <<store condition code>>                            15240000
   end;                                                                 15245000
integer procedure allocateproc (procname);                              15250000
   <<allocates the segment containing the named procedure  >>           15255000
   <<vs. loading the procedure.  see loadproc for details  >>           15260000
   byte array procname;                                                 15265000
   option uncallable;                                                   15270000
   begin                                                                15275000
     tos:=0d;       <<loader result>>                                   15280000
     tos:=0;        <<command>>                                         15285000
     tos.(0:2):=3;  <<allocate procedure>>                              15290000
     if logicalmapping                                                  15295000
       then tos.(5:1):=0   <<mapped domain>>                            15300000
       else tos.(5:1):=1;  <<physical domain>>                          15305000
     tos:=loader(*,0,0,0,procname,0);                                   15310000
     if s0 = 0                                                          15315000
       then condcode:=cce  <<ok>>                                       15320000
       else condcode:=ccl; <<error>>                                    15325000
     allocateproc:=tos;    <<zero or error code>>                       15330000
   end;                                                                 15335000
integer procedure deallocateproc (procname);                            15340000
   <<deallocates the segment containing the named procedure>>           15345000
   <<and the segments containing the externals of the      >>           15350000
   <<specified procedure.  see description of allocateproc >>           15355000
   <<for further details>>                                              15360000
   byte array procname;                                                 15365000
   option uncallable;                                                   15370000
   begin                                                                15375000
     double slkey;                                                      15380000
     integer savedb,savesir,saveentp,error,logseg;                      15385000
     integer pointer pseglist;                                          15390000
     integer array qname(0:7)=q;                                        15395000
     <<create q-rel version of procname>>                               15400000
     formatname(qname,procname);                                        15405000
     savesir:=getsir(segtabsir);                                        15410000
     savedb:=exchangedb(segtabdst'ex);                         <<06542>>15415000
     <<move procname to sbuf0>>                                         15420000
     sl:=8;                                                             15425000
     while (sl:=sl-1) >= 0 do sbuf0(sl):=qname(sl);                     15430000
     <<scan extension entries for--  >>                                 15435000
     <<  . pin=0                     >>                                 15440000
     <<  . ext=0                     >>                                 15445000
     <<  . lib=0                     >>                                 15450000
     <<  . same procname             >>                                 15455000
     @entp:=hdfwdlink(extension); <<head of extension list>>            15460000
     while @entp <> 0 do                                                15465000
       begin                                                            15470000
         if entp(1)=0 and       <<pin=0,ext=0>>                         15475000
            entp.(4:4)=0 and    <<lib=0>>                               15480000
            samename(sbuf0(0),loadprocname) then               <<d7968>>15485000
           begin   <<found proper extension entry>>                     15490000
             trans'xdst'to'lst;                                <<06542>>15495000
             if <> then go getouterr;                          <<06542>>15500000
             exchangedb(segtabdst);                            <<06542>>15505000
             saveentp:=@entp;   <<save ptr>>                            15510000
             setsecptrs;                                                15515000
             logseg:=entp1(1).(8:8); <<get log seg #>>                  15520000
             tos:=entp2(1);          <<get sl key>>                     15525000
             tos:=entp2(2);                                             15530000
             slkey:=tos;                                                15535000
             if lsearch(slkey,normal,slfile) then                       15540000
               begin  <<found sl entry>>                                15545000
                 si:=@entp;                                             15550000
                 sj:=logseg;                                            15555000
                 if findlogsegmatch then                                15560000
                   begin  <<found seglist entry for logseg>>            15565000
                     @pseglist:=sl;                                     15570000
                     pseglist.(12:1):=0; <<clear a bit>>                15575000
                     @entp:=saveentp; <<restore ptrs to ext>>           15580000
                     setsecptrs;      <<extension entry>>               15585000
                     adjrefcounts(-1); <<adj count>>                    15590000
                     ldelete;         <<delete ext entry>>              15595000
                     exchangedb(segtabdst'ex);                 <<06542>>15600000
                     ldelete;                                  <<06542>>15605000
                     error:=0;        <<ok code>>                       15610000
                     condcode:=cce;                                     15615000
                     go getout;                                         15620000
                   end;                                                 15625000
               end;                                                     15630000
             @entp:=saveentp;                                  <<06542>>15635000
             ldelete;                                          <<06542>>15640000
             go getouterr; <<error>>                                    15645000
           end;                                                         15650000
         <<wrong extension entry--try next>>                            15655000
         @entp:=fwdlink;                                                15660000
       end; <<while>>                                                   15665000
     <<procedure not allocated>>                                        15670000
getouterr:                                                              15675000
     condcode:=ccl;                                                     15680000
     error:=err86;                                                      15685000
getout:                                                                 15690000
     relsir(segtabsir,savesir);                                         15695000
     exchangedb(savedb);                                                15700000
     deallocateproc:=error;                                             15705000
   end;                                                                 15710000
logical procedure findphycstmatch;                                      15715000
  option uncallable,privileged;                                         15720000
  <<search seglist of sl entry for matching >>                          15725000
  <<segment number                          >>                          15730000
  <<                                        >>                          15735000
  <<input: si = pointer to head of sl entry >>                          15740000
  <<       sj = segment numb to be matched  >>                          15745000
  <<                                        >>                          15750000
  <<output: true if match found             >>                          15755000
  <<        - sk=log seg #(findphycstmatch) >>                          15760000
  <<        - sk=phy cst #(findlogsegmatch) >>                          15765000
  <<                                        >>                          15770000
  <<        - sl=ptr to seglist entry       >>                          15775000
  <<                                        >>                          15780000
  <<        false if no match found         >>                          15785000
  <<                                        >>                          15790000
  <<*note* assumes db is at the lst         >>                          15795000
  <<                                        >>                          15800000
  begin                                                                 15805000
    entry findlogsegmatch;                                              15810000
    logical phy;                                                        15815000
    integer pointer pseglist,pend;                                      15820000
    phy:=true;                                                          15825000
    go start;                                                           15830000
findlogsegmatch:                                                        15835000
    phy:=false;                                                         15840000
start:                                                                  15845000
    @pseglist:=si+21; <<ptr to first seglist>>                          15850000
    @pend:=@pseglist+psi(4).(8:8)*3; <<end seglist>>                    15855000
    while @pseglist < @pend do                                          15860000
      begin           <<search all seglist entries>>                    15865000
        if phy then                                                     15870000
          begin       <<try to match physical cst #>>                   15875000
            if sj = pseglist(2) then                                    15880000
              begin       <<cst's match>>                               15885000
                sl:=@pseglist;      <<return ptr>>                      15890000
                sk:=pseglist.(0:8); <<log seg nr>>                      15895000
                findphycstmatch:=true;                                  15900000
                return;                                                 15905000
              end;                                                      15910000
          end                                                           15915000
         else                                                           15920000
          begin       <<try to match logical seg #>>                    15925000
            if sj = pseglist.(0:8) then                                 15930000
              begin       <<seg's match>>                               15935000
                sl:=@pseglist;   <<return ptr>>                         15940000
                sk:=pseglist(2); <<phy cst #>>                          15945000
                findphycstmatch:=true;                                  15950000
                return;                                                 15955000
              end;                                                      15960000
          end;                                                          15965000
        @pseglist:=@pseglist+3;  <<next entry>>                         15970000
      end; <<while>>                                                    15975000
    findphycstmatch:=false;                                             15980000
  end; <<findphycstmatch>>                                              15985000
logical procedure scanslinfoareas(pslinfo,nslinfo,segnr,phy);           15990000
  value pslinfo,nslinfo,segnr,phy;                                      15995000
  integer nslinfo,segnr;                                                16000000
  integer pointer pslinfo;                                              16005000
  logical phy;                                                          16010000
  option privileged,uncallable;                                <<*7861>>16015000
  <<the slinfo areas are scanned looking for     >>                     16020000
  <<a match on the segnr                         >>                     16025000
  <<                                             >>                     16030000
  <<input: pslinfo = pointer to 1st sl info area >>                     16035000
  <<       nslinfo = number of sl info areas     >>                     16040000
  <<       segnr  = physical cst # being matched >>                     16045000
  <<                if phy=true                  >>                     16050000
  <<       segnr  = logical seg # being matched  >>                     16055000
  <<                if phy=false                 >>                     16060000
  <<                                             >>                     16065000
  <<output: true if match found                  >>                     16070000
  <<        if phy=true                          >>                     16075000
  <<         -sk = logical seg number            >>                     16080000
  <<         -sl = sl type                       >>                     16085000
  <<        if phy=false                         >>                     16090000
  <<         -sk = physical cst #                >>                     16095000
  <<         -sl = garbage                       >>                     16100000
  <<                                             >>                     16105000
  <<        false if no match found              >>                     16110000
  <<                                             >>                     16115000
  <<*note* assumes db is at the lst              >>                     16120000
  <<       lst entp pointers are preserved       >>                     16125000
  <<                                             >>                     16130000
  begin                                                                 16135000
    tos:=@entp;       <<save pointers>>                                 16140000
    tos:=@entp1;                                                        16145000
    tos:=@entp2;                                                        16150000
    tos:=@entp3;                                                        16155000
    while (nslinfo:=nslinfo-1) >= 0 do                                  16160000
      begin           <<search each slinfo area>>                       16165000
        tos:=0;       <<lsearch result>>                                16170000
        tos:=pslinfo(1); <<slid>>                                       16175000
        tos:=pslinfo(2); <<slid>>                                       16180000
        if lsearch(*,normal,slfile) then                                16185000
          begin       <<found sl entry>>                                16190000
            si:=@entp;   <<ptr to sl entry>>                            16195000
            sj:=segnr;  <<cst to match>>                                16200000
            if phy then                                                 16205000
              begin     <<try match on physical cst #>>                 16210000
                if findphycstmatch then                                 16215000
                  begin      <<found match>>                            16220000
                    sl:=pslinfo; <<sl type>>                            16225000
                    scanslinfoareas:=true;                              16230000
                    go to getout;                                       16235000
                  end;                                                  16240000
              end                                                       16245000
             else                                                       16250000
              begin     <<try match on log seg #>>                      16255000
                <<verify logseg was referenced >>                       16260000
                tos:=0; <<testbit result>>                              16265000
                tos:=@entp2; <<logseg array>>                  <<07316>>16270000
                if testbit(*,segnr) and                                 16275000
                   findlogsegmatch then                                 16280000
                  begin         <<found match>>                         16285000
                    scanslinfoareas:=true;                              16290000
                    go getout;                                          16295000
                  end;                                                  16300000
              end;                                                      16305000
          end;                                                          16310000
        @pslinfo:=@pslinfo+19; <<next sl info area>>                    16315000
      end; <<while>>                                                    16320000
    scanslinfoareas:=false; <<no match found>>                          16325000
getout:                                                                 16330000
    @entp3:=tos;                                                        16335000
    @entp2:=tos;    <<restore pointers>>                                16340000
    @entp1:=tos;                                                        16345000
    @entp:=tos;                                                         16350000
  end; <<scanslinfoareas>>                                              16355000
double procedure logicalcst'(seg'nr,pinx);                     <<06901>>16360000
  value seg'nr,pinx;                                                    16365000
  integer seg'nr,pinx;                                                  16370000
  <<return the segment number and segment type>>                        16375000
  <<corresponding to the plabel               >>                        16380000
  <<                                          >>                        16385000
  <<return: s-0 logical segment no.           >>                        16390000
  <<        s-1 source of segment             >>                        16395000
  <<            =0 system sl                  >>                        16400000
  <<            =1 pub sl                     >>                        16405000
  <<            =2 group sl                   >>                        16410000
  <<            =14 prog file                 >>                        16415000
  <<                                          >>                        16420000
  <<input: seg'nr = code segment             >>                         16425000
  <<                (0:1)-mapping flag       >>                         16430000
  <<                      (ignored if no mapping>>                      16435000
  <<                      (firmware          >>                         16440000
  <<                      =1 physically mapped>>                        16445000
  <<                         seg'nr.(1:15)=  >>                         16450000
  <<                         physical cst #  >>                         16455000
  <<                      =0 logically mapped>>                         16460000
  <<                         seg'nr.(8:8)=   >>                         16465000
  <<                         logical cst #   >>                         16470000
  <<       pinx  = the process index          >>                        16475000
  <<               to be used                 >>                        16480000
  <<               =0 use current process     >>                        16485000
  <<                                          >>                        16490000
  begin                                                                 16495000
    integer pcbpt = pinx;                                               16500000
    integer cstnr,nslinfo,savedst,savesir;                              16505000
    integer segmapdst,blkidx;                                           16510000
    integer pointer pslinfo;                                            16515000
    integer sltype=logicalcst', <<return>>                     <<06901>>16520000
            logseg=sltype+1;   <<values>>                               16525000
    integer pointer tentp,tentp1,tentp2,tentp3;                <<06741>>16530000
    subroutine get'lstsir'dst;                                          16535000
      <<get lst sir and dst>>                                           16540000
      begin                                                             16545000
        savesir:=getsir(segtabsir);                                     16550000
        savedst:=exchangedb(segtabdst);                                 16555000
        @tentp := @entp;                                       <<06741>>16560000
        @tentp1 := @entp1;                                     <<06741>>16565000
        @tentp2 := @entp2;                                     <<06741>>16570000
        @tentp3 := @entp3;                                     <<06741>>16575000
      end;  <<get'lstsir'dst>>                                          16580000
                                                                        16585000
    subroutine rel'lstsir'dst;                                          16590000
      <<release lst sir and dst>>                                       16595000
      begin                                                             16600000
        @entp := @tentp;                                       <<06741>>16605000
        @entp1 := @tentp1;                                     <<06741>>16610000
        @entp2 := @tentp2;                                     <<06741>>16615000
        @entp3 := @tentp3;                                     <<06741>>16620000
        exchangedb(savedst);                                            16625000
        relsir(segtabsir,savesir);                                      16630000
      end;  <<rel'lstsir'dst>>                                          16635000
                                                                        16640000
    subroutine searchsyssl;                                             16645000
      <<search sys sl for cstnr>>                                       16650000
      begin                                                             16655000
        tos:=0;                 <<lsearch result>>                      16660000
        tos:=absolute(sslkeya);  <<sys sl>>                             16665000
        tos:=absolute(xreg:=xreg+1); <<slid>>                           16670000
        if lsearch(*,normal,slfile) then                                16675000
          begin                 <<entry found>>                         16680000
            si:=@entp;          <<entry ptr>>                           16685000
            sj:=cstnr;         <<cst to match>>                         16690000
            if findphycstmatch then                                     16695000
              begin             <<found match>>                         16700000
                sltype:=0;                                              16705000
                logseg:=sk;                                             16710000
                condcode:=cce;                                          16715000
              end;                                                      16720000
          end;                                                          16725000
      end; <<searchsyssl>>                                              16730000
    subroutine searchprogentry;                                         16735000
      <<search all sl info areas in progfile entry>>                    16740000
      begin                                                             16745000
        if lsearch(double(logical(pinx/pcbsize)),anymode,      <<07316>>16750000
                                     sharer) then                       16755000
          begin                <<sharer entry found>>                   16760000
            if lsearch(efid,epmode,progfile) then                       16765000
              begin            <<progfile entry found>>                 16770000
                @pslinfo:=@entp2; <<ptr to slinfo area>>                16775000
                nslinfo:=eslinfo'prog;<<# slinfo areas>>                16780000
                tos:=0; <<scanslinfoareas result>>                      16785000
                tos:=@pslinfo;                                          16790000
                if scanslinfoareas(*,nslinfo,cstnr,true) then           16795000
                  begin          <<found match>>                        16800000
                    sltype:=sl;                                         16805000
                    logseg:=sk;                                         16810000
                    condcode:=cce;                                      16815000
                  end;                                                  16820000
              end;                                                      16825000
          end                                                           16830000
         else                                                           16835000
          begin                <<sharer entry not found>>               16840000
            <<try search of system sl>>                                 16845000
            searchsyssl;                                                16850000
          end;                                                          16855000
      end;  <<searchprogentry>>                                         16860000
    <<entry here>>                                                      16865000
    sltype:=0;          <<initial values>>                              16870000
    logseg:=0;                                                          16875000
    condcode:=ccl;                                                      16880000
    if pinx = 0 and curprc <> 0 then                           <<06648>>16885000
       pinx := curprc;                                         <<06648>>16890000
       if pinx <> 0 then                                       <<*7861>>16895000
          if pinx mod pcbsize <> 0 or pqptr = -1 then          <<*7861>>16900000
             begin                                             <<*7861>>16905000
             condcode := ccg;                                  <<*7861>>16910000
             return;                                           <<*7861>>16915000
             end;                                              <<*7861>>16920000
                                                               <<*7861>>16925000
    if logicalmapping then                                              16930000
      begin               <<mapping firmware present>>                  16935000
        if pinx = 0 then                                                16940000
          begin           <<no pin for mapping>>                        16945000
            if seg'nr < 0 then                                          16950000
              begin       <<physically mapped>>                         16955000
                cstnr:=seg'nr.(1:15);                                   16960000
                if cstnr=0 then return; <<bad cst #>>                   16965000
                get'lstsir'dst; <<get sir,dst>>                         16970000
                searchsyssl;   <<search sys sl only>>                   16975000
                rel'lstsir'dst; <<release sir,dst>>                     16980000
              end;                                                      16985000
          end else                                                      16990000
          begin           <<pin available for mapping>>                 16995000
            if seg'nr < 0 then                                          17000000
              begin       <<physically mapped>>                         17005000
                cstnr:=seg'nr.(1:15);                                   17010000
                if cstnr=0 then return; <<bad cst #>>                   17015000
                get'lstsir'dst; <<get sir,dst>>                         17020000
                searchprogentry;<<search all ref'ed sl's>>              17025000
                rel'lstsir'dst; <<release sir,dst>>                     17030000
              end else                                                  17035000
              begin       <<logically mapped>>                          17040000
                cstnr:=seg'nr.(8:8);                                    17045000
                if cstnr=0 then return; <<bad cst #>>                   17050000
                blkidx := spcbpbx; <<cstx blk>>                         17055000
                pdisable;                                      <<06528>>17060000
                tos := if blkidx <> 0 and                      <<06528>>17065000
                          abs(cstext(blkidx)+abs(dstb))        <<06528>>17070000
                          >= cstnr then 1 else 0;              <<06528>>17075000
                penable;                                       <<06528>>17080000
                if tos = 1 then                                <<06528>>17085000
                  begin  <<program segment>>                            17090000
                    sltype:=14;                                         17095000
                    logseg:=cstnr-1;                                    17100000
                    condcode:=cce;                                      17105000
                  end                                                   17110000
                 else                                                   17115000
                  begin  <<sl segment>>                                 17120000
                    <<must use segmap>>                                 17125000
                    segmapdst := spcbmapdst;                            17130000
                    if segmapdst=0 then return;<<bad cst #>>            17135000
                    savedst:=exchangedb(segmapdst);                     17140000
                    if cstnr <= segmap.(8:8) then                       17145000
                      begin  <<valid cst #>>                            17150000
                        <<get true physical cst #>>                     17155000
                        cstnr:=segmap(cstnr&lsl(1));                    17160000
                        exchangedb(savedst);                            17165000
                        if cstnr=0 then return;<<invalic cst#>>         17170000
                        get'lstsir'dst; <<get sir,dst>>                 17175000
                        searchprogentry;                                17180000
                        rel'lstsir'dst; <<release sir,dst>>             17185000
                      end else                                          17190000
                      begin              <<invalid cst>>                17195000
                        exchangedb(savedst);                            17200000
                      end;                                              17205000
                  end;                                                  17210000
              end;                                                      17215000
          end;                                                          17220000
      end else                                                          17225000
      begin               <<no mapping firmware>>                       17230000
       cstnr:=seg'nr.(8:8);                                             17235000
       if cstnr=0 then return; <<bad cst #>>                            17240000
        if cstnr > %300 then                                            17245000
          begin           <<prog seg>>                                  17250000
            sltype:=14;                                                 17255000
            logseg:=cstnr-%301;                                         17260000
            if pinx <> 0 then                                           17265000
              begin       <<pin available for checking>>                17270000
                blkidx := spcbpbx;                                      17275000
                pdisable;                                      <<06528>>17280000
                if absolute(cstext(blkidx)+                             17285000
                            absolute(dstb)) >= cstnr-%300               17290000
                  then condcode:=cce; <<valid cst #>>                   17295000
                penable;                                       <<06528>>17300000
              end;                                                      17305000
          end else                                                      17310000
          begin           <<sl seg>>                                    17315000
            if cstnr = %300 then return; <<invalid cst #>>              17320000
            get'lstsir'dst; <<get sir,dst>>                             17325000
            if pinx = 0                                                 17330000
              then searchsyssl  <<use sys sl only>>                     17335000
              else searchprogentry; <<use all ref'ed sl's>>             17340000
            rel'lstsir'dst; <<release sir,dst>>                         17345000
          end;                                                          17350000
      end;                                                              17355000
  end; <<logicalcst>>                                                   17360000
double procedure logicalcst(seg'nr);                           <<06901>>17365000
   value seg'nr;                                               <<06901>>17370000
   integer seg'nr;                                             <<06901>>17375000
   << interface routine to logicalcst' procedure >>            <<06901>>17380000
   << it has the same external spec. as in mpe iv>>            <<06901>>17385000
   << this procedure calls logicalcst' with pinx >>            <<06901>>17390000
   << =0.                                        >>            <<06901>>17395000
                                                               <<06901>>17400000
   begin                                                       <<06901>>17405000
      integer segtype = logicalcst;                            <<06901>>17410000
                                                               <<06901>>17415000
      logicalcst := logicalcst'(seg'nr,0);                     <<06901>>17420000
      if < then                                                <<06901>>17425000
         condcode := ccl                                       <<06901>>17430000
      else                                                     <<06901>>17435000
         if > then                                             <<06901>>17440000
            condcode := ccg                                    <<06901>>17445000
         else                                                  <<06901>>17450000
            begin                                              <<06901>>17455000
               condcode := cce;                                <<06901>>17460000
               if segtype = 14 then                            <<06901>>17465000
                  segtype := 3;                                <<06901>>17470000
            end;                                               <<06901>>17475000
   end;                                                        <<06901>>17480000
double procedure logicalcst''(seg'nr,pinnr);                   <<07317>>17485000
   value seg'nr,pinnr;                                         <<07317>>17490000
   integer seg'nr,pinnr;                                       <<07317>>17495000
   << interface routine to logicalcst' using pin number >>     <<07317>>17500000
                                                               <<07317>>17505000
   begin                                                       <<07317>>17510000
   logicalcst'':=logicalcst'(seg'nr,pinnr*pcbsize);            <<07317>>17515000
   push(status);                                               <<07317>>17520000
   tos:=tos.(6:2);                                             <<07317>>17525000
   condcode:=tos;                                              <<07317>>17530000
   end;                                                        <<07317>>17535000
integer procedure physicalcst(pin,segmentnr);                           17540000
  <<returns the physical cst # corresponding to the>>                   17545000
  <<given segment number in the given source file  >>                   17550000
  <<corresponding to the given pin.                >>                   17555000
  <<                                               >>                   17560000
  <<return: physical cst #                         >>                   17565000
  <<                                               >>                   17570000
  <<input:  pin <> 0 use progfile entry            >>                   17575000
  <<            =  0 use sys sl only               >>                   17580000
  <<                                               >>                   17585000
  <<        segmentnr.(0:4) = source file          >>                   17590000
  <<                          0-system sl          >>                   17595000
  <<                          1-public sl          >>                   17600000
  <<                          2-group sl           >>                   17605000
  <<                         14-program            >>                   17610000
  <<        segmentnr.(8:8) = logical seg #        >>                   17615000
  <<                                               >>                   17620000
  <<this procedure may be called in split stack    >>                   17625000
  <<                                               >>                   17630000
  value pin,segmentnr;                                                  17635000
  integer pin,segmentnr;                                                17640000
  option uncallable,privileged;                                         17645000
  begin                                                                 17650000
    double slkey;                                                       17655000
    integer saveentp,savedb,savesir;                                    17660000
    integer pointer tentp,tentp1,tentp2,tentp3;                <<06741>>17665000
    define logseg = segmentnr.(8:8)#, <<log seg #>>                     17670000
           sltype = segmentnr.(0:4)#; <<source>>                        17675000
                                                                        17680000
    logical subroutine scanslentry;                                     17685000
      <<return true if match on logseg # in sl entry>>                  17690000
      begin                                                             17695000
        scanslentry:=false;                                             17700000
        if lsearch(slkey,normal,slfile) then                            17705000
          begin   <<sl entry exists>>                                   17710000
            <<search seglist entries for match>>                        17715000
            <<on log seg #                    >>                        17720000
            si:=@entp;    <<ptr to sl entry>>                           17725000
            sj:=logseg;   <<log seg #>>                                 17730000
            if findlogsegmatch then scanslentry:=true;                  17735000
          end;                                                          17740000
      end; <<scanslentry>>                                              17745000
    logical subroutine matched;                                         17750000
      <<return true if match on logseg # using specific>>               17755000
      <<slinfoarea in progfile or extension entry      >>               17760000
      begin                                                             17765000
        if etype = progfile                                             17770000
          then sl:=eslinfo'prog                                         17775000
          else sl:=eslinfo'ext;                                         17780000
        <<find proper slinfoarea>>                                      17785000
        @entp2:=@entp2+(sl-1)*19;                                       17790000
        while (sl:=sl-1) >= 0 and                                       17795000
              entp2 <> sltype do                                        17800000
          begin                                                         17805000
            @entp2:=@entp2-19;                                          17810000
          end;                                                          17815000
        if sl >= 0 and                                                  17820000
           scanslinfoareas(entp2,1,logseg,false)                        17825000
          then matched:=true                                            17830000
          else matched:=false;                                          17835000
      end; <<matched>>                                                  17840000
    savesir:=getsir(segtabsir);                                         17845000
    savedb:=exchangedb(segtabdst);                                      17850000
    @tentp := @entp;                                           <<06741>>17855000
    @tentp1 := @entp1;                                         <<06741>>17860000
    @tentp2 := @entp2;                                         <<06741>>17865000
    @tentp3 := @entp3;                                         <<06741>>17870000
    if pin = 0 then                                                     17875000
      begin         <<examine sys sl only>>                             17880000
        tos:=abs(sslkeya); <<get sys sl key>>                           17885000
        tos:=abs(xreg:=xreg+1);                                         17890000
        slkey:=tos;                                                     17895000
        if scanslentry then                                             17900000
          begin     <<found match>>                                     17905000
            physicalcst:=sk;                                            17910000
            condcode:=cce;                                              17915000
          end                                                           17920000
         else                                                           17925000
          begin     <<no match>>                                        17930000
            physicalcst:=0;                                             17935000
            condcode:=ccg;                                              17940000
          end;                                                          17945000
      end                                                               17950000
     else                                                               17955000
      begin         <<use pin's ref'ed segments>>                       17960000
        if lsearch(double(logical(pin)),anymode,sharer) and             17965000
           lsearch(efid,epmode,progfile) then                           17970000
          begin     <<found pin's progfile entry>>                      17975000
            if sltype = 14 then                                         17980000
              begin <<source=program>>                                  17985000
                if logseg < eseg then                                   17990000
                  begin         <<valid logseg>>                        17995000
                    if logicalmapping                                   18000000
                      then physicalcst:=logseg+1                        18005000
                      else physicalcst:=logseg+%301;                    18010000
                    condcode:=cce;                                      18015000
                  end                                                   18020000
                 else                                                   18025000
                  begin         <<invalid logseg>>                      18030000
                    physicalcst:=0;                                     18035000
                    condcode:=ccg;                                      18040000
                  end;                                                  18045000
              end                                                       18050000
             else                                                       18055000
              begin <<source=sl>>                                       18060000
                <<try to find match using progfile entry>>              18065000
                if matched then                                         18070000
                  begin  <<found match>>                                18075000
                    physicalcst:=sk;                                    18080000
                    condcode:=cce;                                      18085000
                  end                                                   18090000
                 else                                                   18095000
                  begin  <<no match>>                                   18100000
                    <<try to find match using extension entry>>         18105000
                    exchangedb(segtabdst'ex);                  <<06542>>18110000
                    @entp:=hdfwdlink(extension);                        18115000
                    while @entp <> 0 do                                 18120000
                      begin                                             18125000
                        <<search each extension entry>>                 18130000
                        if epin = pin then                              18135000
                          begin  <<found extension for pin>>            18140000
                            trans'xdst'to'lst;                 <<06542>>18145000
                            if <> then                         <<06542>>18150000
                               begin                           <<06542>>18155000
                                  condcode := ccl;             <<06542>>18160000
                                  go getout;                   <<06542>>18165000
                               end;                            <<06542>>18170000
                            exchangedb(segtabdst);             <<06542>>18175000
                            saveentp:=@entp;                            18180000
                            setsecptrs;                                 18185000
                            if matched then                             18190000
                              begin <<found match>>                     18195000
                                physicalcst:=sk;                        18200000
                                condcode:=cce;                          18205000
                                @entp:=saveentp;               <<06542>>18210000
                                ldelete;                       <<06542>>18215000
                                go getout;                              18220000
                              end;                                      18225000
                            @entp:=saveentp;                            18230000
                            ldelete;                           <<06542>>18235000
                            exchangedb(segtabdst'ex);          <<06542>>18240000
                          end;                                          18245000
                        @entp:=entp(fwdlink); <<next ext>>              18250000
                      end; <<while>>                                    18255000
                    <<no match in extension entries>>                   18260000
                    physicalcst:=0;                                     18265000
                    condcode:=ccg;                                      18270000
                  end;                                                  18275000
              end;                                                      18280000
          end                                                           18285000
         else                                                           18290000
          begin     <<no progfile entry--invalid pin>>                  18295000
            physicalcst:=0;                                             18300000
            condcode:=ccl;                                              18305000
          end;                                                          18310000
      end;                                                              18315000
getout:                                                                 18320000
    @entp := @tentp;                                           <<06741>>18325000
    @entp1 := @tentp1;                                         <<06741>>18330000
    @entp2 := @tentp2;                                         <<06741>>18335000
    @entp3 := @tentp3;                                         <<06741>>18340000
    relsir(segtabsir,savesir);                                          18345000
    exchangedb(savedb);                                                 18350000
  end;                                                                  18355000
procedure procfile (pin,fname);                                         18360000
   comment:                                                             18365000
      returns program file name corresponding to "PIN".                 18370000
      "FNAME" must be at least 28 bytes long.  (this is                 18375000
      in part a carry-over from a previous implementation               18380000
      which called "FGETINFO".  it also ensures at least                18385000
      one blank after the file name for scanning purposes.)             18390000
      name is fully qualified and packed with trailing                  18395000
      blanks.  note special format for system processes.                18400000
                                                                        18405000
      db must point to stack.                                           18410000
                                                                        18415000
      output depends on condition code:                                 18420000
         cce -- no error ... "FNAME" contains program name              18425000
         ccg -- system process ... "FNAME" contains "C.I."              18430000
                or "SYS.PROC." depending on process type                18435000
         ccl -- invalid pin or file i/o error ... "FNAME"               18440000
                contains blanks                                         18445000
      ;                                                                 18450000
   value pin;                                                           18455000
   integer pin;                                                         18460000
   byte array fname;                                                    18465000
   option privileged, uncallable;                                       18470000
   begin                                                                18475000
   integer pointer pcb= 3; <<sys glob+3>>                               18480000
   define numpcbs= pcb(0) #,                                            18485000
          ptype = pcb(pin * pcbsize +                          <<06648>>18490000
                      procstatewordnum).ptypefield#;           <<07427>>18495000
                                                                        18500000
   equate flsize= 128;                                                  18505000
   integer array flab(0:flsize-1);                                      18510000
   byte array bflab(*)= flab;                                           18515000
   define flblocname=  bflab #,                                         18520000
          flbgrpname=  bflab(8) #,                                      18525000
          flbacctname= bflab(16) #;                                     18530000
   equate minpin = 1;                                          <<06102>>18535000
   integer ldev;                                                        18540000
   double discaddr;                                                     18545000
   byte daldev= discaddr; <<ldev in lst entry>>                         18550000
   integer pointer tentp,tentp1,tentp2,tentp3;                 <<06741>>18555000
                                                                        18560000
                                                                        18565000
   fname:=" ";   move fname(1):=fname,(27);                             18570000
   tos := segtabsir;                                                    18575000
   tos := getsir(segtabsir);  <<get segment table sir>>                 18580000
   tos := 0;  <<for result of exchangedb>>                              18585000
   tos := exchangedb(segtabdst);  <<set db to segment table>>           18590000
   @tentp := @entp;                                            <<06741>>18595000
   @tentp1 := @entp1;                                          <<06741>>18600000
   @tentp2 := @entp2;                                          <<06741>>18605000
   @tentp3 := @entp3;                                          <<06741>>18610000
   if lsearch(double(logical(pin)),anymode,sharer) then                 18615000
      begin                                                             18620000
discaddr:=entdp1; <<file key>>                                          18625000
      @entp := @tentp;                                         <<06741>>18630000
      @entp1 := @tentp1;                                       <<06741>>18635000
      @entp2 := @tentp2;                                       <<06741>>18640000
      @entp3 := @tentp3;                                       <<06741>>18645000
      exchangedb(*);  <<reset db>>                                      18650000
      relsir(*,*);  <<release segment table sir>>                       18655000
      ldev:=daldev;                                                     18660000
      daldev:=0;                                                        18665000
      if flabio(ldev,discaddr,0,flab)<>0 then tos:=ccl                  18670000
      else                                                              18675000
         begin                                                          18680000
         move fname:=flblocname,(8);                                    18685000
         scan fname until " ",1;                                        18690000
         move * := ".",2;                                               18695000
         move bps0:=flbgrpname,(8);                                     18700000
         scan * until " ",1;                                            18705000
         move * := ".",2;                                               18710000
         move * := flbacctname,(8);                                     18715000
                                                                        18720000
         flab:=0;   move flab(1):=flab,(flsize-1);                      18725000
         tos:=cce;                                                      18730000
         end;                                                           18735000
      end                                                               18740000
   else                                                                 18745000
      begin                                                             18750000
      @entp := @tentp;                                         <<06741>>18755000
      @entp1 := @tentp1;                                       <<06741>>18760000
      @entp2 := @tentp2;                                       <<06741>>18765000
      @entp3 := @tentp3;                                       <<06741>>18770000
      exchangedb(*);  <<reset db>>                                      18775000
      relsir(*,*);  <<release segment table sir>>                       18780000
      if not (minpin<=pin<=numpcbs) then tos:=ccl              <<06102>>18785000
      else if 2<=ptype<=3 then                                          18790000
         begin                                                          18795000
         move fname:="C.I.";                                            18800000
         tos:=ccg;                                                      18805000
         end                                                            18810000
      else if > then                                                    18815000
         begin                                                          18820000
         move fname:="SYS.PROC.";                                       18825000
         tos:=ccg;                                                      18830000
         end                                                            18835000
      else tos:=ccl;                                                    18840000
      end;                                                              18845000
   condcode := tos  <<store condition code>>                            18850000
   end;                                                                 18855000
logical procedure loadedslseg(slkey,segmentnr);                         18860000
  <<returns true if the specified logical seg>>                         18865000
  <<of the specified sl is currently loaded  >>                         18870000
  value slkey,segmentnr;                                                18875000
  double slkey;                                                         18880000
  integer segmentnr;                                                    18885000
  option uncallable;                                                    18890000
  begin                                                                 18895000
    integer savedb,savesir;                                             18900000
    loadedslseg:=false;                                                 18905000
    savesir:=getsir(segtabsir);                                         18910000
    savedb:=exchangedb(segtabdst);                                      18915000
    if lsearch(slkey,normal,slfile) then                                18920000
      begin    <<sl entry exists>>                                      18925000
        <<check seg array to determine>>                                18930000
        <<if logseg is loaded         >>                                18935000
        tos:=0;      <<testbit result>>                                 18940000
        tos:=@entp2; <<seg array>>                                      18945000
        if testbit(*,segmentnr) then loadedslseg:=true;                 18950000
      end;                                                              18955000
    relsir(segtabsir,savesir);                                          18960000
    exchangedb(savedb);                                                 18965000
  end;                                                                  18970000
procedure loadprocedure(error,procname,loadprocid,plabel,               18975000
                        option'nums,options);                           18980000
  <<this is an extension of loadproc         >>                         18985000
  <<                                         >>                         18990000
  <<inputs>>                                                            18995000
  byte array procname; <<procedure name>>                               19000000
  integer array option'nums; <<option numbers>>                         19005000
  logical array options;     <<corresponding options>>                  19010000
  <<outputs>>                                                           19015000
  integer error,             <<error return>>                           19020000
          loadprocid,        <<loadproc index>>                         19025000
          plabel;            <<procedure label>>                        19030000
  option variable,privileged,uncallable;                       <<06280>>19035000
  begin                                                                 19040000
    <<local variables>>                                                 19045000
    logical ovmask = q-4;  <<option variable mask>>                     19050000
    integer array qname(0:7)=q;                                         19055000
    integer loadprocflag',                                              19060000
            extidx',                                                    19065000
            plabel',                                                    19070000
            savesir,                                                    19075000
           pcbpt,                                              <<06648>>19080000
            savedb,                                                     19085000
            oldsegmapdst,                                               19090000
            newsegmapdst,                                               19095000
            libsearch,                                                  19100000
            loaddomain,                                                 19105000
            unsatflag,                                                  19110000
            flags,                                                      19115000
            command,                                                    19120000
            chekerr,                                                    19125000
            temp;                                                       19130000
    double stk'lims;                                                    19135000
    integer stk'lolim = stk'lims,                                       19140000
            stk'hilim = stk'lims+1;                                     19145000
    logical endoflist;                                                  19150000
    byte pointer libscan;                                               19155000
    logical savecrit;                                                   19160000
    integer pointer pcbxfixed,                                          19165000
                    auxentp,                                            19170000
                    auxentp1,                                           19175000
                    auxentp2,                                           19180000
                    auxentp3;                                           19185000
    define pcbx' = push(dl);tos:=tos-ps0(-2);@pcbxfixed:=tos#,          19190000
           loadprocflag = pcbxfixed(6).(15:1)#,                <<06666>>19195000
           segmapflag = pcbxfixed(6).(14:1)#,                  <<06666>>19200000
           firstloadproc = loadprocflag'=0#;                            19205000
    define have'options = ovmask.(14:2)=3#,                             19210000
           invalid'options = ovmask.(14:2)=1 or                         19215000
                             ovmask.(14:2)=2#;                          19220000
    define called'nonpm = status.(0:1)=0#;<<mode bit>>                  19225000
                                                                        19230000
    equate maxlibsearch = 2;                                            19235000
    equate maxopts = 3;                                                 19240000
                                                                        19245000
    equate intrin'data = [10/85,6/7],       <<intrinsic data>>          19250000
           chk'flag    = [8/0,2/0,1/0,5/6], <<chek flags>>              19255000
           chk'parm= [2/2,2/2,2/2,2/2,2/3,2/2],<<chek parms>>           19260000
           chk'opts    = [2/3];             <<chek options>>            19265000
                                                                        19270000
    equate err1 = 1, <<invalid load domain>>                            19275000
           err2 = 2, <<required parm missing>>                          19280000
           err3 = 3, <<required parm bad addr>>                         19285000
           err4 = 4; <<invalid option>>                                 19290000
                                                                        19295000
subroutine resetdbsir;                                                  19300000
  begin                                                                 19305000
    exchangedb(savedb);                                                 19310000
    relsir(segtabsir,savesir);                                          19315000
  end; <<resetdbsir>>                                                   19320000
                                                                        19325000
subroutine create'lprocmaster;                                          19330000
  <<build loadprocmaster entry>>                                        19335000
  begin                                                                 19340000
    lcreate(sm,loadprocmaster,normal,0,double(userpin));                19345000
    if < then                                                           19350000
      begin   <<no room>>                                               19355000
        resetdbsir;                                                     19360000
        error:=err70;                                                   19365000
        go returnerror;                                                 19370000
      end;                                                              19375000
    <<clear entry>>                                                     19380000
    entp(2):=0;                                                         19385000
    move entp(3):=entp(2),(sm-3);                                       19390000
  end; <<create'lprocmaster>>                                           19395000
                                                                        19400000
subroutine buildsegmap;                                                 19405000
  <<build a process local segmap>>                                      19410000
  <<if process is executing a program file        >>                    19415000
  <<  then use copy of program's segmap           >>                    19420000
  <<  else build new segmap                       >>                    19425000
  begin                                                                 19430000
    oldsegmapdst := spcbmapdst;                                <<06648>>19435000
    if oldsegmapdst = 0 then                                            19440000
      begin                 <<no current segmap>>                       19445000
        <<basic segmap must be created>>                                19450000
        <<allocate dst>>                                                19455000
        temp:=(num'progsegs+1)&lsl(1); <<minimum size>>                 19460000
        temp:=((temp+63)&lsr(6))&lsl(6);<<mod 64>>                      19465000
        newsegmapdst:=getdataseg(temp,4090);                            19470000
        if <> then                                                      19475000
          begin    <<error>>                                            19480000
            error:=err99;                                               19485000
            go returnerror;                                             19490000
          end;                                                          19495000
        <<format segmap>>                                               19500000
        savedb:=exchangedb(newsegmapdst);                               19505000
        <<clear segmap>>                                                19510000
        dbarea(0):=0;                                                   19515000
        move dbarea(1):=dbarea(0),(temp-1);                             19520000
        tos:=num'progsegs;    <<max mcstidx>>                           19525000
        dbarea(0):=tos;       <<# progsegs,maxmcstidx>>                 19530000
        dbarea(1):=(num'progsegs+1)&lsl(1); <<dbarea length>>           19535000
        temp:=0;                                                        19540000
        while (temp:=temp+1) <= num'progsegs do                         19545000
          begin                                                         19550000
            dbarea(temp&lsl(1)):=temp; <<phycst>>                       19555000
          end; <<while>>                                                19560000
        exchangedb(savedb);                                             19565000
      end                                                               19570000
     else                                                               19575000
      begin   <<segmap exists>>                                         19580000
        <<must create a pcb-local copy of segmap>>                      19585000
        temp:=(dsti(oldsegmapdst&lsl(2)).dslen-1)&lsl(2);               19590000
                         <<current segmap length>>                      19595000
        newsegmapdst:=getdataseg(temp,                                  19600000
                            ((temp+4095)&lsr(12))&lsl(12));             19605000
        if <> then                                                      19610000
          begin    <<error>>                                            19615000
            error:=err99;                                               19620000
            go returnerror;                                             19625000
          end;                                                          19630000
        <<copy segmap>>                                                 19635000
        tos:=newsegmapdst;    <<target>>                                19640000
        tos:=0;               <<offset>>                                19645000
        tos:=oldsegmapdst;    <<source>>                                19650000
        tos:=0;               <<offset>>                                19655000
        tos:=temp;            <<count>>                                 19660000
        assemble(mds 5);                                                19665000
        adjustlocality(pcbpt,double(oldsegmapdst),0,1);        <<07316>>19670000
      end;                                                              19675000
    <<update pcbxfixed and pcb>>                                        19680000
    spcbmapdst := newsegmapdst;                                <<06648>>19685000
    setsysdb;                                                           19690000
    addtolocality(sllptr,double(newsegmapdst),                 <<06648>>19695000
       %400 );                                                          19700000
    resetdb( -1 );                                                      19705000
    segmapflag:=1;                                                      19710000
  end; <<buildsegmap>>                                                  19715000
                                                                        19720000
integer subroutine wordaddr(byteaddr);                                  19725000
  <<convert byte address to word address>>                              19730000
  value byteaddr;                                                       19735000
  byte pointer byteaddr;                                                19740000
  begin                                                                 19745000
    tos:=wordaddr:=@byteaddr&lsr(1);                                    19750000
    push(z);                                                            19755000
    <<if wordaddr > z then wordaddr.(0:1):=1>>                          19760000
    if tos > tos then wordaddr.(0:1):=1;                                19765000
  end; <<wordaddr>>                                                     19770000
                                                                        19775000
subroutine figure'options;                                              19780000
  <<optional parameters present>>                                       19785000
  <<figure values passed>>                                              19790000
  begin                                                                 19795000
    <<set up default values>>                                           19800000
    libsearch:=-1;                                                      19805000
    @libscan:=-1;                                                       19810000
    loaddomain:=1;                                                      19815000
    unsatflag:=0;                                                       19820000
    flags:=-1;                                                          19825000
    endoflist:=false;                                                   19830000
    <<check values passed>>                                             19835000
    temp:=0;                                                            19840000
    while temp <= maxopts and not endoflist do                          19845000
      begin                                                             19850000
        if not (0 <= option'nums(temp) <= maxopts) then                 19855000
          begin  <<invalid option number>>                              19860000
            endoflist:=true;                                            19865000
          end                                                           19870000
         else                                                           19875000
          begin  <<valid option number>>                                19880000
            case *option'nums(temp) of                                  19885000
              begin                                                     19890000
              <<0>> endoflist:=true;                                    19895000
              <<1>> if libsearch = -1 then                              19900000
                      begin <<1st occurrence>>                          19905000
                        libsearch:=options(temp);                       19910000
                        <<check validity>>                              19915000
                        if not (0<=libsearch                            19920000
                                 <=maxlibsearch) then                   19925000
                          begin   <<illegal libsearch>>                 19930000
                            error:=err20;                               19935000
                            go returnerror2;                            19940000
                          end;                                          19945000
                      end                                               19950000
                     else                                               19955000
                      begin <<2nd occurrence>>                          19960000
                        endoflist:=true;                                19965000
                      end;                                              19970000
              <<2>> if flags = -1 then                                  19975000
                      begin <<1st occurrence>>                          19980000
                        flags:=0;                                       19985000
                        unsatflag:=options(temp).(14:1);                19990000
                        loaddomain:=options(temp).(15:1);               19995000
                        <<check valid load domain>>                     20000000
                        if logicalmapping then                          20005000
                          begin <<mapping firmware present>>            20010000
                            if loaddomain=1 and                         20015000
                               called'nonpm then                        20020000
                              begin <<invalid >>                        20025000
                                error:=err1;                            20030000
                                go returnerror2;                        20035000
                              end                                       20040000
                          end                                           20045000
                         else                                           20050000
                          begin <<no mapping firmware>>                 20055000
                            <<all loads physical>>                      20060000
                            loaddomain:=1;                              20065000
                          end;                                          20070000
                      end                                               20075000
                     else                                               20080000
                      begin <<2nd occurrence>>                          20085000
                        endoflist:=true;                                20090000
                      end;                                              20095000
              <<3>> if @libscan = -1 then                               20100000
                      begin <<1st occurrnence>>                         20105000
                        @libscan:=options(temp);                        20110000
                        <<check validity>>                              20115000
                        if not (stk'lolim<=wordaddr(libscan)            20120000
                                         <=stk'hilim) then              20125000
                          begin <<invalid addr>>                        20130000
                            error:=err3;                                20135000
                            go returnerror2;                            20140000
                          end;                                          20145000
                      end                                               20150000
                     else                                               20155000
                      begin <<2nd occurrence>>                          20160000
                        endoflist:=true;                                20165000
                      end;                                              20170000
              end; <<case>>                                             20175000
          end;                                                          20180000
        temp:=temp+1;                                                   20185000
      end; <<while>>                                                    20190000
    if option'nums(temp-1) <> 0 then                                    20195000
      begin  <<invalid option>>                                         20200000
        error:=err4;                                                    20205000
        go returnerror2;                                                20210000
      end;                                                              20215000
  end;  <<figure'options>>                                              20220000
                                                                        20225000
    <<check parameters>>                                                20230000
    erroron;                                                            20235000
    pcbpt := curprc;                                           <<06648>>20240000
    pcbx';  <<ptr to pcbx fixed area>>                                  20245000
    loadprocflag':=loadprocflag;                                        20250000
    stk'lims:=chek'noabort(intrin'data,chk'flag,                        20255000
                      double(chk'parm),,chk'opts);                      20260000
    if < then                                                           20265000
      begin   <<error from chek>>                                       20270000
        chekerr:=errorget(1).(8:8);                                     20275000
        if chekerr=3                                                    20280000
          then error:=err2  <<missing parm>>                            20285000
          else error:=err3; <<bad addr>>                                20290000
        go returnerror2;                                                20295000
      end;                                                              20300000
    if have'options then                                                20305000
      begin             <<both option var parms specified>>             20310000
        figure'options;                                                 20315000
      end                                                               20320000
     else                                                               20325000
      begin             <<both opt var parms not specified>>            20330000
        if invalid'options then                                         20335000
          begin         <<one opt vap parm specified>>                  20340000
            error:=err4;                                                20345000
            go returnerror2;                                            20350000
          end;                                                          20355000
      end;                                                              20360000
                                                                        20365000
    <<create q-rel version of procname>>                                20370000
    formatname(qname,procname);                                         20375000
                                                                        20380000
    savecrit:=setcritical;  <<protect>>                                 20385000
    savesir:=getsir(segtabsir);                                         20390000
    savedb:=exchangedb(segtabdst);                                      20395000
    if firstloadproc then                                               20400000
      begin  <<first loadprocedure call>>                               20405000
        <<must create a loadprocmaster entry for pin>>                  20410000
        <<find sharer entry and the program file entry>>                20415000
        if lsearch(double(userpin),anymode,sharer) and                  20420000
           lsearch(efid,epmode,progfile) then                           20425000
          begin <<found entries>>                                       20430000
            <<create loadprocmaster entry>>                             20435000
            sm:=35+eslinfo'prog&lsl(1)                                  20440000
                  +(emapsize+1)&lsl(1); <<entry size>>                  20445000
            @auxentp:=@entp; <<save progfile entry ptrs>>               20450000
            @auxentp1:=@entp1;                                          20455000
            @auxentp2:=@entp2;                                          20460000
            @auxentp3:=@entp3;                                          20465000
            create'lprocmaster;                                         20470000
            <<build entry>>                                             20475000
            sn:=auxentp(6).(8:8); <<#slinfo areas>>                     20480000
            entp(2).(0:8):=sn;    <<# slid>>                            20485000
            setsecptrs; <<setup secondary ptrs to entry>>               20490000
            <<move slid to loadprocmaster>>                             20495000
            sl:=0;                                                      20500000
            while (sl:=sl+1) <= sn do                                   20505000
              begin                                                     20510000
                entp2(0):=auxentp2(1); <<slid-word 0>>                  20515000
                entp2(1):=auxentp2(2); <<slid-word 1>>                  20520000
                @entp2:=@entp2+2;                                       20525000
                @auxentp2:=@auxentp2+19;                                20530000
              end;                                                      20535000
            <<create mcstlogseg array from psegmap array>>              20540000
            sn:=if logicalmapping then auxentp3<<#psegmap ent>>         20545000
                                  else 0;                               20550000
            entp3:=sn;    <<# mcstlogseg entries>>                      20555000
            @auxentp3:=@auxentp3+1;                                     20560000
            @entp3:=@entp3+2;                                           20565000
            @entp1:=@entp1+16; <<ptr to mcstidx table>>                 20570000
            sl:=0;                                                      20575000
            while (sl:=sl+1) <= sn do                                   20580000
              begin                                                     20585000
                entp3(0):=auxentp3; <<logseg,slid>>                     20590000
                entp3(1):=1;        <<ref count>>                       20595000
                <<set bit in mcstidx table>>                            20600000
                tos:=@entp1;                                            20605000
                setbit(*,sl);                                           20610000
                @entp3:=@entp3+2;                                       20615000
                @auxentp3:=@auxentp3+1;                                 20620000
              end;                                                      20625000
            setsecptrs;        <<set secondary ptrs again>>             20630000
          end                                                           20635000
         else                                                           20640000
          begin <<sharer and progfile entries not found>>               20645000
            <<create basic loadprocmaster entry>>                       20650000
            sn:=if logicalmapping then num'progsegs<<#progsegs>>        20655000
                                  else 0;                               20660000
            sm:=35+(sn+1)&lsl(1); <<entry length>>                      20665000
            create'lprocmaster;                                         20670000
            <<build entry>>                                             20675000
            setsecptrs; <<set secondary ptrs>>                          20680000
            <<create mcstlogseg array>>                                 20685000
            entp3:=sn;  << # mcstlogseg array entries>>                 20690000
            @entp3:=@entp3+2; <<ptr to first entry>>                    20695000
            @entp1:=@entp1+16;<<ptr to mcstidx tab>>                    20700000
            sl:=0;                                                      20705000
            while (sl:=sl+1) <= sn do                                   20710000
              begin                                                     20715000
                tos:=14;  <<slid>>                                      20720000
                tos.(0:8):=sl-1; <<logseg>>                             20725000
                entp3(0):=tos;                                          20730000
                entp3(1):=1;     <<ref count>>                          20735000
                <<set bit in mcstidx tab>>                              20740000
                tos:=@entp1;                                            20745000
                setbit(*,sl);                                           20750000
                @entp3:=@entp3+2;                                       20755000
              end; <<while>>                                            20760000
            setsecptrs; <<set secondary ptrs again>>                    20765000
          end;                                                          20770000
        loadprocflag':=1;  <<loadprocmaster exists>>                    20775000
      end                                                               20780000
     else                                                               20785000
      begin  <<not first call to loadprocedure>>                        20790000
        <<loadprocmaster entry exists>>                                 20795000
        if lsearch(double(userpin),normal,loadprocmaster) then          20800000
          begin  <<found entry>>                                        20805000
            <<check if procedure has been loadproc'ed>>                 20810000
            if active'lprocs <> 0 then                                  20815000
              begin <<currently active loadproc's>>                     20820000
                exchangedb(segtabdst'ex);                      <<06542>>20825000
                <<move procedure name to sbuf0>>                        20830000
                sl:=8;                                                  20835000
                while (sl:=sl-1) >= 0 do                                20840000
                  begin                                                 20845000
                    sbuf0(sl):=qname(sl);                               20850000
                  end;                                                  20855000
                <<scan each extension entry for-->>                     20860000
                <<  . same pin                   >>                     20865000
                <<  . same procedure name        >>                     20870000
                <<  . same library search        >>                     20875000
                @auxentp:=hdfwdlink(extension); <<head entry>>          20880000
                while @auxentp <> 0 do                                  20885000
                  begin  <<each extension entry>>                       20890000
                    if auxentp(1) = userpin and                         20895000
                       auxentp.(4:4) = libsearch and                    20900000
                       samename(sbuf0(0),auxentp(5)) then               20905000
                      begin  <<found extension for procedure>>          20910000
                        tos:=auxentp(3); <<loadproc count>>             20915000
                        if logical(s0) >= 65535 then                    20920000
                          begin    <<too many times>>                   20925000
                            resetdbsir;                                 20930000
                            error:=err103;                              20935000
                            go returnerror;                             20940000
                          end;                                          20945000
                        tos:=tos+1; <<increment count>>                 20950000
                        auxentp(3):=tos;                                20955000
                        extidx':=auxentp(2);<<id>>                      20960000
                        plabel':=auxentp(4);      <<plabel>>            20965000
                        resetdbsir;                                     20970000
                        resetcritical(savecrit);                        20975000
                        go finish;                                      20980000
                      end;                                              20985000
                    @auxentp:=auxentp(-3); <<next entry>>               20990000
                  end; <<while>>                                        20995000
                <<procedure has not been loadproc'ed>>                  21000000
                exchangedb(segtabdst);                         <<06542>>21005000
              end;                                                      21010000
          end                                                           21015000
         else                                                           21020000
          begin  <<did not find loadprocmaster entry>>                  21025000
            suddendeath(351);                                           21030000
          end;                                                          21035000
      end;                                                              21040000
    <<get next extension id>>                                           21045000
    tos:=0;  <<nextbit result>>                                         21050000
    tos:=@entp1; <<extidx tab>>                                         21055000
    tos:=nextbit(*);                                                    21060000
    extidx':=s0;                                                        21065000
    if tos = 0 then                                                     21070000
      begin        <<no aavailable idx>>                                21075000
        resetdbsir;                                                     21080000
        error:=err40;                                                   21085000
        go returnerror;                                                 21090000
      end;                                                              21095000
    resetdbsir;                                                         21100000
    loadprocflag:=loadprocflag'; <<set loadprocmaster flag>>            21105000
                                                                        21110000
    <<check whether process local segmap is to be created>>             21115000
    <<required if                                   >>                  21120000
    <<  .logical mapping firmware present           >>                  21125000
    <<  .procedure is being loaded into mapped domain>>                 21130000
    <<  .process local segmap does not already exist>>                  21135000
    if loaddomain = 0 and                                               21140000
       segmapflag = 0 then                                              21145000
      begin     <<segmap must be created>>                              21150000
        buildsegmap;                                                    21155000
      end;                                                              21160000
                                                                        21165000
    resetcritical(savecrit);                                            21170000
    <<send request to loader>>                                          21175000
    command:=0;                                                         21180000
    command.(0:2):=1;    <<loadproc request>>                           21185000
    command.(2:2):=libsearch; <<lib scan>>                              21190000
    command.(5:1):=loaddomain;<<mapped or non-mapped>>                  21195000
    tos:=loader(command,userpin,extidx',0,procname,0);                  21200000
    error:=tos;    <<error returned>>                                   21205000
    if error <> 0 then go returnerror2;                                 21210000
    plabel':=tos;  <<returned procedure label>>                         21215000
                                                                        21220000
finish:                                                                 21225000
    loadprocid:=extidx'; <<return loadproc id>>                         21230000
    plabel:=plabel';     <<return procedure label>>                     21235000
    condcode:=cce; <<ok code>>                                          21240000
    errorexit([10/80,6/7],0,0);                                         21245000
    return;                                                             21250000
                                                                        21255000
returnerror:                                                            21260000
    resetcritical(savecrit);                                            21265000
returnerror2:                                                           21270000
    condcode:=ccl;  <<error code>>                                      21275000
    loadprocflag:=loadprocflag'; <<set loadprocmaster flag>>            21280000
    errorexit([10/80,6/7],0,0);                                         21285000
  end;                                                                  21290000
$control segment=main                                                   21295000
end.                                                                    21300000
