$CONTROL USLINIT, CODE, MAP                                             00010000
                                                                        00015000
<<------------------------------------------------------------->>       00020000
<<                                                             >>       00025000
<<                    mpe segmenter process                    >>       00030000
<<                     segproc (moduel 02)                     >>       00035000
<<                                                             >>       00040000
<<                       version a.01.07                       >>       00045000
<<                      january 15,  1982                      >>       00050000
<<                                                             >>       00055000
<<------------------------------------------------------------->>       00060000
                                                                        00065000
$copyright "(C) COPYRIGHT HEWLETT-PACKARD COMPANY 1981.  ",  &          00070000
$          "THIS PROGRAM MAY BE USED WITH ONE COMPUTER ",    &          00075000
$          "SYSTEM AT A TIME AND SHALL NOT OTHERWISE BE ",   &          00080000
$          "RECORDED, TRANSMITTED OR STORED IN A RETRIEVAL ",&          00085000
$          "SYSTEM.  COPYING OR OTHER REPRODUCTION OF THIS ",&          00090000
$          "PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS ",       &          00095000
$          "PROHIBITED WITHOUT THE PRIOR WRITTEN CONSENT ",  &          00100000
$          "OF HEWLETT-PACKARD COMPANY."                                00105000
                                                                        00110000
$title "       MPE SEGMENTER PROCESS - JANUARY 15, 1982"                00115000
$control main = segproc                                                 00120000
$control segment = seg1                                                 00125000
                                                                        00130000
begin                                                                   00135000
$page                                                                   00140000
<<------------------------------------------------------------->>       00145000
<<                                                             >>       00150000
<< quit codes.                                                 >>       00155000
<<                                                             >>       00160000
<<------------------------------------------------------------->>       00165000
<<                                                             >>       00170000
<<    0  end of file or i/o error.                             >>       00175000
<<    1  illegal directory entry in usl file.                  >>       00180000
<<    2  illegal code header in usl file.                      >>       00185000
<<    3  insufficient dl storage.                              >>       00190000
<<    4  unable to receive mail from segmenter father process. >>       00195000
<<    5  unable to send mail to segmenter father process.      >>       00200000
<<                                                             >>       00205000
<<------------------------------------------------------------->>       00210000
                                                                        00215000
<<misc. declarations>>                                                  00220000
                                                                        00225000
equate ccg = 0,  <<"GREATER THAN" condition code>>                      00230000
       ccl = 1,  <<"LESS THAN" condition code>>                         00235000
       cce = 2;  <<"EQUAL" condition code>>                             00240000
define setbit0 = assemble(tsbc 0)#,                                     00245000
       setbit1 = assemble(tsbc 1)#,                                     00250000
       setbit15 = assemble(tsbc 15)#,                                   00255000
       testbit1 = assemble(tbc 1)#;                                     00260000
define turnofftraps = push(status); tos.(2:1) _ 0; set(status)#,        00265000
       turnontraps = push(status); tos.(2:1) _ 1; set(status)#;         00270000
byte bs0 = s-0;                                                         00275000
byte bs1 = s-1;                                                         00280000
byte bs2 = s-2;                                                         00285000
byte bs3 = s-3;                                                         00290000
integer s0 = s-0;                                                       00295000
integer s1 = s-1;                                                       00300000
integer s2 = s-2;                                                       00305000
integer s3 = s-3;                                                       00310000
integer s4 = s-4;                                                       00315000
integer s5 = s-5;                                                       00320000
integer s6 = s-6;                                                       00325000
integer s8=s-8;                                                <<00595>>00330000
logical ls0 = s-0;                                                      00335000
logical ls1 = s-1;                                                      00340000
double ds1 = s-1;                                                       00345000
double ds2 = s-2;                                                       00350000
double ds3 = s-3;                                                       00355000
double ds4 = s-4;                                                       00360000
double ds5 = s-5;                                                       00365000
double ds6 = s-6;                                                       00370000
byte pointer bps0 = s-0;                                                00375000
byte pointer bps1 = s-1;                                                00380000
byte pointer bps2 = s-2;                                                00385000
byte pointer bps3 = s-3;                                                00390000
byte pointer bps4 = s-4;                                                00395000
byte pointer bps5 = s-5;                                                00400000
integer pointer ps0 = s-0;                                              00405000
integer pointer ps1 = s-1;                                              00410000
integer pointer ps2 = s-2;                                              00415000
integer pointer ps3 = s-3;                                              00420000
logical pointer lps0 = s-0;                                             00425000
logical pointer lps1 = s-1;                                             00430000
logical pointer lps2 = s-2;                                             00435000
double pointer dps0 = s-0;                                              00440000
double pointer dps1 = s-1;                                              00445000
double pointer dps2 = s-2;                                              00450000
double pointer dps3 = s-3;                                              00455000
integer array as0 (*) = s-0;                                            00460000
integer array as1 (*) = s-1;                                            00465000
integer array as2 (*) = s-2;                                            00470000
integer array as3 (*) = s-3;                                            00475000
integer xreg = x;  <<x register>>                                       00480000
logical lxreg = x;  <<x register>>                                      00485000
integer status = q-1;  <<status word of stack marker>>                  00490000
define condcode = status.(6:2)#;  <<cond. code bits in status>>         00495000
                                                                        00500000
<<misc. constants>>                                                     00505000
                                                                        00510000
integer recsize _ 128;  <<record size>>                                 00515000
double bigd _ %17777777777d;                                            00520000
double p256d _ 256d;                                                    00525000
double p128d _ 128d;                                                    00530000
double m1d _ -1d;                                                       00535000
integer p256 = p256d+1;                                                 00540000
integer p384 _ 384;                                                     00545000
integer p512 := 512;                                           <<06093>>00550000
byte array null(0:0) _ %0;                                              00555000
integer array blankcommon (0:2) _ "4COM' ";                             00560000
integer array trapcom' (0:4) := "8TRAPCOM' ";                  <<00.bv>>00565000
logical usermode;                                                       00570000
define interactive = usermode#;  <<interactive?>>                       00575000
double usercap;  <<user's capability>>                                  00580000
logical usercap1 = usercap;  <<user's functional capabilities>>         00585000
logical usercap2 = usercap+1;  <<user's resource capabilities>>         00590000
equate enable'ctly  = 17;                                      <<00.dm>>00595000
equate disable'ctly = 16;                                      <<00.dm>>00600000
                                                                        00605000
<<configuration parameters>>                                            00610000
                                                                        00615000
integer array config(0:2);                                     <<00.dm>>00620000
integer sdbmaxcode1 = db+35, <<max. code segment size>>        <<00.dm>>00625000
        sdbdefaultstk1 = db+39, <<min. stack size>>            <<00.dm>>00630000
        sdbmaxcode2 = db+%105, <<max. code segment size>>      <<00.dm>>00635000
        sdbdefaultstk2 = db+%110; <<min. stack size>>          <<00.dm>>00640000
define  sdbmaxcode      = config(1)#,                          <<00.dm>>00645000
        sdbdefaultstack = config(2)#;                          <<00.dm>>00650000
                                                                        00655000
<<system parameters>>                                                   00660000
                                                                        00665000
equate cpcb = 4,                                                        00670000
       pcbb = 3,                                               <<00.eb>>00675000
       pcbsize1 = 11,                                          <<00.dm>>00680000
       pcbsizempe4 = 16,                                       <<06538>>00685000
       firststt = 1;                                                    00690000
define fatherpinx = config#;                                   <<06538>>00695000
integer pointer pcb = 3;                                       <<06538>>00700000
define pcbsize = pcb(1)#;                                      <<06538>>00705000
                                                                        00710000
<<misc. maps>>                                                          00715000
                                                                        00720000
byte array map10 (2:8) := 1,2,3,4,0,0,4;  <<usl type to sym. type>>     00725000
byte array map11 (1:11) := 4,2,4,2,2,2,1,6,4,6,4;  <<sym. tab. lenghts>>00730000
byte array map12 (0:8) := 3,0,1,2,1,2,0,0,2;  <<usl entry levels>>      00735000
logical bitmap1 := %(2)1111111011001111;  <<illegal ent's for sl>>      00740000
logical bitmap3 _ %(2)0000000000010110;  <<ent's with sons>>            00745000
logical bitmap4 := %(2)0000000100111101;  <<ent's with fathers>>        00750000
logical bitmap5 _ %(2)0000000001010100;  <<ent's with code>>            00755000
logical bitmap6 _ %(2)0000000011010100;  <<ent's with headers>>         00760000
logical bitmap7 := %(2)1111011011000000; << scansegment headers<<04102>>00765000
logical bitmap9 := %(2)1111101110011110; << headers for prep >>         00770000
logical bitmap10 := %(2)0000000100111100;  <<ent's with seg. names>>    00775000
logical bitmap12 := %(2)0000000100111110;  <<seg. copies needed?>>      00780000
<< status codes returned by procedures: >>                     <<04102>>00785000
                                                               <<04102>>00790000
equate                                                         <<04102>>00795000
   status'ok = 0,                 << no errors detected >>     <<04102>>00800000
   status'bad = 1;                << procedure failed >>       <<04102>>00805000
                                                               <<04781>>00810000
   equate        tempfile = 2,                                 <<04781>>00815000
                 save     = 1,                                 <<04781>>00820000
                 delete   = 4,                                 <<04781>>00825000
                 nochange = 0,                                 <<04781>>00830000
                 dup'name = 100;                               <<04781>>00835000
$page "ERROR AND WARNING MESSAGE CODES"                                 00840000
<<********************************************************************>>00845000
<<                                                                    >>00850000
<<   error and warning message codes                                  >>00855000
<<                                                                    >>00860000
<<********************************************************************>>00865000
                                                                        00870000
equate                                                                  00875000
                                                                        00880000
   << usl file messages: >>                                             00885000
                                                                        00890000
   msg'badentry          = 0,                                           00895000
   msg'badheader         = 1,                                           00900000
   msg'maxdiroverflow    = 2,                                           00905000
   msg'diroverflow       = 3,                                           00910000
   msg'infooverflow      = 4,                                           00915000
   msg'nousl             = 5,                                           00920000
   msg'baduslspec        = 6,                                           00925000
   msg'cantopenusl       = 7,                                           00930000
   msg'badusl            = 8,                                           00935000
   msg'cantcloseusl      = 9,                                           00940000
                                                                        00945000
   << sl file messages, part 1 of 2: >>                                 00950000
                                                                        00955000
   msg'cantclosesl       = 10,                                          00960000
   msg'filefull          = 11,                                          00965000
   msg'duplicateentrypt  = 12,                                          00970000
   msg'nonprocinsegment  = 13,                                          00975000
   msg'globalinsegment   = 14,                                          00980000
   msg'duplicatesegment  = 15,                                          00985000
   msg'nosl              = 16,                                          00990000
   msg'badslspec         = 17,                                          00995000
   msg'cantopensl        = 18,                                          01000000
   msg'badsl             = 19,                                          01005000
                                                                        01010000
   << rl file messages: >>                                              01015000
                                                                        01020000
   msg'badrlspec         = 20,                                          01025000
   msg'norl              = 21,                                          01030000
   msg'badrl             = 22,                                          01035000
   msg'cantcloserl       = 23,                                          01040000
   msg'noprocentry       = 28,                                          01045000
   msg'cantopenrl        = 30,                                          01050000
                                                                        01055000
   << program preparation messages, part 1 of 2: >>                     01060000
                                                                        01065000
   msg'badprogfile       = 32,                                          01070000
   msg'badcapspec        = 33,                                          01075000
   msg'multipleextents   = 34,                                          01080000
   msg'noprogtoprep      = 35,                                          01085000
   msg'cantcloseprogfile = 36,                                          01090000
   msg'cantopenprogfile  = 37,                                          01095000
   msg'datasegoverflow   = 38,                                          01100000
   msg'toomanycodesegs   = 39,                                          01105000
                                                                        01110000
   << segment preparation messages: >>                                  01115000
                                                                        01120000
   msg'codesegoverflow   = 40,                                          01125000
   msg'sttoverflow       = 41,                                          01130000
   msg'nosegentry        = 42,                                          01135000
   msg'cantaccessproc    = 43,                                          01140000
   msg'privmoderequired  = 44,                                          01145000
   msg'parmcheckerror    = 45,                                   <<+08>>01150000
   msg'fatalinprogunit   = 46,                                          01155000
   msg'warninginprogunit = 47,                                          01160000
   msg'codesegovfloposs  = 48,                                          01165000
   msg'functionsincompat = 49,                                 <<04102>>01170000
   msg'parmcounterror    = 50,                                 <<04102>>01175000
                                                                        01180000
   << program preparation messages, part 2 of 2: >>                     01185000
                                                                        01190000
   msg'noouterblock      = 60,                                          01195000
   msg'extraouterblocks  = 61,                                          01200000
   msg'extraobentries    = 62,                                          01205000
   msg'extvarnotglobal   = 63,                                          01210000
   msg'extvarincompat    = 64,                                          01215000
   msg'commonoverflow    = 66,                                          01220000
   msg'commonsizeerror   = 67,                                          01225000
   msg'nocomforblockdata = 68,                                          01230000
   msg'bdataincompatwcom = 69,                                          01235000
   msg'badstacksize      = 70,                                          01240000
   msg'baddlsize         = 71,                                          01245000
   msg'badmaxdata        = 72,                                          01250000
   msg'dupactivename     = 73,                                          01255000
   msg'cantprepsymdebug  = 74,                                 <<04102>>01260000
   msg'pfiletoosmall     = 75,                                 <<04781>>01265000
   msg'primdboverflow    = 76,                                 <<06293>>01270000
                                                                        01275000
   << miscellaneous messages: >>                                        01280000
                                                                        01285000
   msg'storageoverflow   = 80,                                          01290000
   msg'badpatch          = 81,                                          01295000
   msg'cantopenscratch   = 82,                                          01300000
   msg'cantopenlist      = 83,                                          01305000
   msg'unexpectedioerr   = 84,                                          01310000
   msg'itemdiffromclass  = 86,                                          01315000
   msg'itemnotprimaryent = 87,                                          01320000
   msg'incompatibleitem  = 88,                                          01325000
   msg'badclass          = 89,                                          01330000
   msg'cantlocateitem    = 93,                                          01335000
   msg'unexpectedeof     = 94,                                 <<04102>>01340000
   msg'badcopyfactor     = 95,                                 <<04102>>01345000
   msg'badfileaccess     = 96,                                 <<04102>>01350000
   msg'cantclosescratch  = 97,                                 <<04102>>01355000
   msg'nopmap           = 98,                                  <<04584>>01360000
   msg'reqsmcap         = 99,                                  <<04584>>01365000
                                                                        01370000
   << sl file messages, part 2 of 2: >>                                 01375000
                                                                        01380000
   msg'segmentloaded     = 110,                                         01385000
   msg'externalvarinseg  = 111,                                         01390000
   msg'commoninseg       = 112,                                         01395000
   msg'logicalunitsinseg = 113,                                         01400000
   msg'cantfreezeseg     = 114,                                <<04102>>01405000
                                                                        01410000
   << auxiliary usl file messages: >>                                   01415000
                                                                        01420000
   msg'noauxusl          = 120,                                         01425000
   msg'cantopennewusl    = 121,                                <<04102>>01430000
   msg'duplicatefilename = 122;                                <<04102>>01435000
$page "DL AREA BUFFERS AND PARAMETERS"                                  01440000
<<----------------------------------------------------------------------01445000
*                                                                      *01450000
*  dl area buffers and parameters                                      *01455000
*                                                                      *01460000
---------------------------------------------------------------------->>01465000
                                                                        01470000
equate systemdl = 10,  <<nr. words reserved dl area reserved for mpe>>  01475000
       dlincrement = 512;  <<nr. words by which dl is expanded>>        01480000
integer pointer dlarea1 _ -systemdl;  <<dl used area 1 pointer>>        01485000
integer pointer dlarea2;  <<dl used area 2 pointer>>                    01490000
integer pointer dlavail;  <<dl available area pointer>>                 01495000
$page "COMMAND INTERPRETER BUFFER"                             <<00207>>01500000
<<----------------------------------------------------------------------01505000
*                                                                      *01510000
*  command interpreter buffer                                          *01515000
*                                                                      *01520000
---------------------------------------------------------------------->>01525000
                                                                        01530000
equate maillength = 59,  <<buffer length>>                     <<00629>>01535000
       mailbnd = maillength-1,  <<buffer bound>>                        01540000
       auxmaillength = 7,  <<buffer length>>                   <<00629>>01545000
       auxmailbnd = auxmaillength-1;  <<buffer bound>>                  01550000
integer array combuf (0:mailbnd);  <<command buffer>>                   01555000
integer array auxcombuf (0:auxmailbnd) = db;  <<aux. command buffer>>   01560000
integer num0 = auxcombuf;                                               01565000
integer num1 = auxcombuf+1;                                             01570000
integer num2 = auxcombuf+2;                                             01575000
integer num3 = auxcombuf+3;                                             01580000
integer num4 = auxcombuf+4;                                             01585000
integer num5 = auxcombuf+5;                                             01590000
integer num6 = auxcombuf+6;                                    <<00629>>01595000
integer array string1 (*) = combuf(7);                         <<00629>>01600000
byte array bstring1 (*) = combuf(7);                           <<00629>>01605000
integer array string2 (*) = combuf(15);                        <<00629>>01610000
byte array bstring2 (*) = combuf(15);                          <<00629>>01615000
byte array bfname1 (*) = combuf(23);                           <<00629>>01620000
byte array bfname2 (*) = combuf(41);                           <<00629>>01625000
                                                                        01630000
integer command = num0;                                                 01635000
integer errornr = num0;                                                 01640000
integer index = num1;                                                   01645000
integer filesize = num1;                                                01650000
integer initstack = num1;                                               01655000
integer nrextents = num2;                                               01660000
integer initdl = num2;                                                  01665000
logical flags = num3;                                                   01670000
integer initmaxdata = num4;                                             01675000
integer capability = num5;                                              01680000
integer initpatch = num6;                                      <<00629>>01685000
integer array name (*) = string1;                                       01690000
byte array bname (*) = bstring1;                                        01695000
integer array segname (*) = string2;                                    01700000
byte array bsegname (*) = bstring2;                                     01705000
byte array bfilename (*) = bfname1;                                     01710000
byte array rlibfname (*) = bfname2;                                     01715000
byte array progname(*)=bfname1,                                <<04584>>01720000
           seg'procname(*)=bfname2;                            <<04584>>01725000
logical setsystem = num1,                                      <<04584>>01730000
        setuncond = num2,                                      <<04584>>01735000
        setoff    = num4;                                      <<04584>>01740000
equate noerror = -1,                                                    01745000
       softerror = 1,                                                   01750000
       harderror = 0;                                                   01755000
define allocateseg = flags.(0:1)#,  <<perm. allocate segment?>>         01760000
       coreseg = flags.(1:1)#,  <<core resident segment?>>              01765000
       systemseg = flags.(2:1)#,  <<system segment?>>                   01770000
       nosym     = flags.(9:1)#,  << prep without sym debug? >><<04102>>01775000
       fpmap = flags.(8:1)#,                                   <<04102>>01780000
       nofpmap = flags.(7:1)#,                                 <<04102>>01785000
       checksumspecified = flags.(6:1)#,                       <<04257>>01790000
       ldseg = flags.(10:1)#, <<loaded segment>>               <<00.eb>>01795000
       inhibitfileeq = flags.(11:1)#,  <<inhibit file equation?>>       01800000
       class = integer(flags.(12:2))#,  <<entry class>>                 01805000
       zerodb = flags.(14:1)#,                                          01810000
       list = flags#;                                                   01815000
equate segclass = 0,                                                    01820000
       unitclass = 1,                                                   01825000
       entryclass = 2;                                                  01830000
switch comswitch _ addrl,addsl,auxusl,buildrl,buildsl,buildusl,cease,   01835000
       copy,exit',hide,listrl,listsl,listusl,newseg,prepare,            01840000
       purgerbm,purgerl,purgesl,reveal,rl,sl,use,usl,debug',   <<00207>>01845000
       copysl,copyusl,cleansl,cleanusl',prepare,listaux,       <<04584>>01850000
       show,listpmap,setfpmap;                                 <<04584>>01855000
$page "LIST FILE BUFFERS AND PARAMETERS"                       <<00207>>01860000
<<----------------------------------------------------------------------01865000
*                                                                      *01870000
* list file buffers and parameters                                     *01875000
*                                                                      *01880000
---------------------------------------------------------------------->>01885000
                                                                        01890000
integer listfnum _ 0;  <<file nr.>>                                     01895000
byte array listdesig (0:7) _ "SEGLIST ";  <<file designator>>           01900000
integer listwidth;  <<line width>>                                      01905000
array line (0:65) _ 66("  ");  <<line buffer>>                          01910000
byte array bline (*) = line;                                            01915000
$page "SEGMENT AND PROGRAM PREPARATION ARRAYS AND PARAMENTERS" <<00207>>01920000
<<----------------------------------------------------------------------01925000
*                                                                      *01930000
*  segment and program preparation arrays and parameters               *01935000
*                                                                      *01940000
---------------------------------------------------------------------->>01945000
                                                                        01950000
<<symbol table>>                                                        01955000
                                                                        01960000
integer pointer stable;  <<symbol table pointer>>                       01965000
integer pointer symbol;  <<symbol table hash list heads>>               01970000
integer usedsymbol;  <<nr. words used for symbol entries>>              01975000
                                                                        01980000
<<symbol table entry parameters>>                                       01985000
                                                                        01990000
integer pointer symp;  <<points to first word of sym. tab. entry>>      01995000
integer pointer symp1;  <<points to word following entry name>>         02000000
integer pointer symp2;  <<secondary pointer>>                           02005000
integer symnw;  <<nr. words in sym. tab. entry>>                        02010000
integer symnc;  <<nr. char's in sym. tab. entry name>>                  02015000
integer symnamenw;  <<nr. words for sym. tab. entry name>>              02020000
integer symtype;  <<sym. tab. entry type number>>                       02025000
                     << 11111          1 >>                    <<04102>>02030000
                     << 5432109876543216 >>                    <<04102>>02035000
equate symany     = %(2)1111111111111111;                      <<04554>>02040000
equate symob      = %(2)0000000000000110;                      <<04102>>02045000
equate symproc    = %(2)0000001110011000;                      <<04102>>02050000
equate symglobal  = %(2)0000000000100000;                      <<04102>>02055000
equate symcommon  = %(2)0000000001000000;                      <<04102>>02060000
equate symrlproc  = %(2)0000111110000000;                      <<04102>>02065000
define snw = symp.(0:10)#,  <<nr. words in entry>>             <<01124>>02070000
       stype = symp.(10:6)#,  <<entry type nr.>>               <<01124>>02075000
       shl = symp(1)#,  <<hash list pointer>>                           02080000
       suncallable = (logical(symp(2).(1:1)))#,  <<uncallable?>>        02085000
       sprivileged = (logical(symp(2).(2:1)))#,  <<priv. inst.?>>       02090000
       shidden = (logical(symp(2).(3:1)))#,  <<hidden entry point?>>    02095000
       snc = symp(2).(4:4)#,  <<nr. char's in name>>                    02100000
       sname = symp(2)#,  <<entry name>>                                02105000
       splabel = symp1#,  <<proc. entry pt. p-label>>                   02110000
       ssttnr = symp1.(0:8)#,  <<proc. entry pt. stt nr.>>              02115000
       ssegnr = symp1.(8:8)#,  <<proc. entry pt. seg. nr.>>             02120000
       sgtn = symp1#,  <<glob. var. data descriptor>>                   02125000
       ssaca = symp1#,  <<s.a. of common array>>                        02130000
       sxnl = symp1#,  <<nr. p-labels for external proc.>>              02135000
       ssacode = symp1(1)#,  <<s.a. of prog. unit>>                     02140000
       sxsttnr = symp1(1)#,  <<stt nr. of p-label for proc.>>           02145000
       sgdba = symp1(1)#,  <<glob. var. prim. db address>>              02150000
       snwca = symp1(1)#,  <<nr. words in common array>>                02155000
       ssapust = symp1(2)#,  <<s.a. of pust>>                           02160000
       srlindex = symp1(2)#,  <<rl table entry index>>                  02165000
       ssasdb = symp1(3)#,  <<s.a. of sec. db array>>                   02170000
       srlcode = symp2(-2)#,  <<nr. words in rl code module>>           02175000
       srlfatal = (logical(symp2(-2).(0:1)))#,  <<fatal error?>>        02180000
       srlwarning = (logical(symp2(-2).(1:1)))#,  <<non-fatal error?>>  02185000
       srlnwc = symp2(-2).(2:14)#,  <<nr. words code module>>           02190000
       srlentry = symp2(-1)#,  <<rl code module entry address>>         02195000
       sxlplabel = symp2(-1)#,  <<last p-label for external proc.>>     02200000
       sxlsttnr = symp2(-1).(0:8)#,  <<stt nr. of last p-label>>        02205000
       sxlsegnr = symp2(-1).(8:8)#,  <<seg. nr. of last p-label>>       02210000
       sparms = symp2#,  <<proc. parm. info>>                           02215000
       sxparms = symp2#;  <<external proc. parm. info>>                 02220000
                                                                        02225000
<<patch table>>                                                         02230000
                                                                        02235000
integer pointer ptable;  <<patch table pointer>>                        02240000
integer pointer patch;  <<patch table record list heads>>               02245000
integer usedpatch _ 0;  <<nr. words in patch table>>                    02250000
                                                                        02255000
<<patch table entry parameters>>                                        02260000
                                                                        02265000
integer pointer patchp;  <<patch entry pointer>>                        02270000
double pointer patchdp = patchp;                                        02275000
                                                                        02280000
<<rl procedure table>>                                                  02285000
                                                                        02290000
integer pointer rltable;  <<rl table pointer>>                          02295000
integer pointer rlentp;  <<rl entry pointer>>                           02300000
double pointer rlentdp = rlentp;                                        02305000
integer nrrlent _ 0;  <<nr. entries in rl table>>                       02310000
                                                               <<04780>>02315000
<<rl segment entry, used to generate error msg  >>             <<04780>>02320000
<<when segment name is needed to output         >>             <<04780>>02325000
                                                               <<04780>>02330000
byte array rlseg'(0:9):=0,0,0,0    <<don't care>>              <<04780>>02335000
                        ,5,"RLSEG";                            <<04780>>02340000
integer array rlseg(*) = rlseg';                               <<04780>>02345000
                                                                        02350000
<<common data label table>>                                             02355000
                                                                        02360000
integer pointer common;  <<common hash list heads>>                     02365000
integer pointer comtab;  <<common data label table>>                    02370000
double pointer comtabd = comtab;                                        02375000
                                                                        02380000
<<common table entry parameters>>                                       02385000
                                                                        02390000
equate bnd4 = 18,  <<common data label table bound>>                    02395000
       comhash = bnd4+1;  <<hashing divisor>>                           02400000
integer pointer comp;  <<entry pointer>>                                02405000
double pointer compd = comp;  <<entry pointer>>                         02410000
integer nrcoment;  <<nr. of common table entries>>                      02415000
                                                                        02420000
<<logical unit table>>                                                  02425000
                                                                        02430000
logical pointer logicalunits;  <<logical unit bit array>>               02435000
logical luspecified;  <<logical unit specified?>>                       02440000
                                                                        02445000
<<trace parameters>>                                                    02450000
                                                                        02455000
equate nwstltpreface = 17;  <<nr. words in stlt preface>>               02460000
integer sastlt;  <<s.a. of stlt>>                                       02465000
integer nwstlt;  <<nr. words in stlt>>                                  02470000
integer obpustadr;  <<o. b. pust address>>                              02475000
integer pointer pustbuf;  <<pust buffer>>                               02480000
double pointer pustdbuf = pustbuf;                                      02485000
integer nwpustbuf;  <<nr. words in pust buffer>>                        02490000
                                                                        02495000
<<stt array>>                                                           02500000
                                                                        02505000
integer pointer stt;  <<stt for code segment>>                          02510000
integer array sttppcount(0:152); << # private procs in each seg<<02817>>02515000
                                                                        02520000
<<segment preparation parameters>>                                      02525000
                                                                        02530000
integer preperror;    << nr of errors during prep >>           <<01.dm>>02535000
logical segflags;                                                       02540000
define segprivileged = segflags.(0:1)#,  <<priv. inst. in seg.?>>       02545000
       segwarning = segflags.(1:1)#,  <<non-fatal error in segment?>>   02550000
       segprinted = segflags.(2:1)#;  <<segment name printed?>>         02555000
logical programfile;  <<preparation for program file?>>                 02560000
integer segfnum;  <<file nr. holding segment>>                          02565000
integer segrecd;  <<first rec. nr. of segment>>                         02570000
integer seglen;  <<code segment length>>                                02575000
integer symtabadr;  <<save sym. tab. entry adr.>>                       02580000
integer obadr;  <<file address of outer block entry>>                   02585000
integer obsymtabadr;  <<symbol table address of o.b. entry>>            02590000
integer cstnr;  <<next available logical cst number>>                   02595000
integer sttnr;  <<next available stt number>>                           02600000
integer sttppnr;  << next available private proc stt number >> <<02817>>02605000
integer nwpdb;  <<nr. words in primary db>>                             02610000
integer nwsdb;  <<nr. words in secondary db>>                           02615000
double  pmapnw;              << # words used by internal pmap  <<04102>>02620000
                             << records.                       <<04102>>02625000
integer obstackest;  <<o.b. stack estimate>>                            02630000
integer procstackest;  <<largest proc. stack estimate>>                 02635000
integer sdbadr;  <<s.a. of sec. db array>>                              02640000
integer formatadr;  <<s.a. of format area>>                             02645000
integer unitadr;  <<s.a. of code module in segment>>                    02650000
logical pointer dirtydata;  <<dirty data segment records>>              02655000
   logical overflowflag;                                       <<02816>>02660000
logical symdbug;             << true if preping with toolbox   <<04102>>02665000
                             <<   symbolic debug.              <<04102>>02670000
logical siseen;              << true if a toolbox si header    <<04102>>02675000
                             << was found during pass 1.       <<04102>>02680000
integer toolboxid;           << last toolbox id assigned >>    <<04102>>02685000
$page "RL LIBRARY FILE BUFFERS AND PARAMTERS"                  <<00207>>02690000
<<----------------------------------------------------------------------02695000
*                                                                      *02700000
*  rl library file buffers and parameters                              *02705000
*                                                                      *02710000
---------------------------------------------------------------------->>02715000
                                                                        02720000
integer rlibfnum _ 0;  <<file nr.>>                                     02725000
logical rlibequalrl;  <<rl library and rl file same?>>                  02730000
                                                                        02735000
<<record 0 buffer>>                                                     02740000
                                                                        02745000
integer pointer rlibrec0;  <<record 0 buffer>>                          02750000
define rliblid = rlibrec0#;  <<loader id>>                              02755000
                                                                        02760000
<<directory buffer>>                                                    02765000
                                                                        02770000
integer pointer rlibdir;  <<directory buffer>>                          02775000
                                                                        02780000
<<entry parameters>>                                                    02785000
                                                                        02790000
integer pointer rlibp;  <<points to first word of entry>>               02795000
integer pointer rlibp1;  <<secondary pointer>>                          02800000
double pointer rlibdp1 = rlibp1;                                        02805000
define rlibname = rlibp#,  <<entry point name>>                         02810000
       rlibuncallable = (logical(rlibp.(1:1)))#,  <<entry uncallable?>> 02815000
       rlibprivileged = (logical(rlibp.(2:1)))#,  <<priv. inst.?>>      02820000
       rlibinfo = rlibdp1#,  <<s.a. info block>>                        02825000
       rlibentry = rlibp1(2)#,  <<s.a. of entry point>>                 02830000
       rlibcode = rlibp1(3)#,  <<code module descriptor>>               02835000
       rlibfatal = (logical(rlibp1(3).(0:1)))#,  <<fatal error?>>       02840000
       rlibwarning = (logical(rlibp1(3).(1:1)))#,  <<non-fatal error?>> 02845000
       rlibnwc = rlibp1(3).(2:14)#,  <<nr. words in code module>>       02850000
       rlibparms = rlibp1(4)#;  <<parm. info>>                          02855000
$page "UTILITY BUFFERS AND VARIABLES"                          <<00207>>02860000
<<----------------------------------------------------------------------02865000
*                                                                      *02870000
*  utility buffers and variables                                       *02875000
*                                                                      *02880000
---------------------------------------------------------------------->>02885000
                                                                        02890000
<<utility buffers>>                                                     02895000
                                                                        02900000
integer array buf(0:255);  <<double record disc buffer>>                02905000
byte array bbuf (*) = buf;                                              02910000
double array dbuf(*) = buf;                                             02915000
integer array buf1(*) = buf(128);  <<second half of buffer>>            02920000
                                                                        02925000
<<utility variables>>                                                   02930000
                                                                        02935000
logical flag;  <<utility flag>>                                         02940000
integer i;  <<utility integer>>                                         02945000
logical ctly;  <<control y flag>>                              <<00.dm>>02950000
integer infnum;  <<file number of $stdinx>>                    <<00.dm>>02955000
                                                                        02960000
<<----------------------------------------------------------------------02965000
*                                                                      *02970000
*  the following are the buffers and state information used by the     *02975000
*  master buffering procedures.  there are two sets of buffers, one    *02980000
*  for code segments and the other is for the global area of the       *02985000
*  program file.                                                       *02990000
*                                                                      *02995000
---------------------------------------------------------------------->>03000000
                                                                        03005000
<<code buffer set>>                                                     03010000
                                                                        03015000
integer tfnum1;  <<target file nr.>>                                    03020000
integer array tbuf1(0:127);  <<target file record buffer>>              03025000
integer trecd1;  <<current target record number>>                       03030000
integer tdisp1;  <<current target record byte displacement>>            03035000
                                                                        03040000
<<data buffer set>>                                                     03045000
                                                                        03050000
integer array tbuf2(0:127);  <<target file record buffer>>              03055000
integer trecd2;  <<current target record number>>                       03060000
integer tdisp2;  <<current target record byte displacement>>            03065000
$page "MISCELLANEOUS SCRATCH FILES AND BUFFERS"                <<04102>>03070000
<< pmap scratch file >>                                        <<04102>>03075000
                                                               <<04102>>03080000
integer array pmapbuf(0:130);                                  <<04102>>03085000
define                                                         <<04102>>03090000
   pmapfilenr  = pmapbuf(128)#,                                <<04102>>03095000
   pmaprecnr   = pmapbuf(129)#,   << record in buffer >>       <<04102>>03100000
   pmapbufdisp = pmapbuf(130)#;   << next word in buffer >>    <<04102>>03105000
                                                               <<04102>>03110000
<< toolbox symbol item (si) headers scratch file >>            <<04102>>03115000
integer array sibuf(0:130);                                    <<04102>>03120000
define                                                         <<04102>>03125000
   sifilenr  = sibuf(128)#,                                    <<04102>>03130000
   sirecnr   = sibuf(129)#,       << record in buffer >>       <<04102>>03135000
   sibufdisp = sibuf(130)#;       << next word in buffer >>    <<04102>>03140000
                                                               <<04102>>03145000
<< file names used by toolbox son process creation: >>         <<04102>>03150000
                                                               <<04102>>03155000
byte    array tboxfiles(0:35)                                  <<04102>>03160000
              := "SEGTMP00  SEGTMP01  SEGSYM.PUB.SYS  ";       <<04102>>03165000
                                                               <<04102>>03170000
define                                                         <<04102>>03175000
   pmapscratch = tboxfiles#,      << name of pmap scratch file <<04102>>03180000
   siscratch   = tboxfiles(10)#,  << name of si scratch file >><<04102>>03185000
   segsym      = tboxfiles(20)#;  << name of son process prog ><<04102>>03190000
$page "INTERNAL PMAP RECORDS"                                           03195000
equate   nrpmaptype     = 3,                                   <<04102>>03200000
         segpmaplen     = 2,  << length of pmap records >>     <<04102>>03205000
         prientpmaplen  = 7,  << excluding names        >>     <<04102>>03210000
         secentpmaplen  = 3;                                   <<04102>>03215000
integer array typetable(0:nrpmaptype);                         <<04102>>03220000
define   typetablelen = typetable(0)#,                         <<04102>>03225000
         segtypelen   = typetable(1)#,                         <<04102>>03230000
         pritypelen   = typetable(2)#,                         <<04102>>03235000
         sectypelen   = typetable(3)#;                         <<04102>>03240000
integer namenw;                                                <<04102>>03245000
define ipmap'type       = pmaprecord.(0:4)#;                   <<04102>>03250000
equate pmapsegtype      = 0,                                   <<04102>>03255000
       pmapproctype     = 1,                                   <<04102>>03260000
       pmapsectype      = 2;                                   <<04102>>03265000
define ipmap'namenumch  = pmaprecord.(4:4)#,<< note:move name>><<04102>>03270000
       ipmap'name       = pmaprecord#,<<before move type     >><<04102>>03275000
       ipmap'sttlen     = pmaprecord(namenw).(0:8)#,           <<04102>>03280000
       ipmap'segnum     = pmaprecord(namenw).(8:8)#,           <<04102>>03285000
       ipmap'seglen     = pmaprecord(namenw+1)#,               <<04102>>03290000
                                                               <<04102>>03295000
       ipmap'flags      = pmaprecord(namenw)#,                 <<04102>>03300000
         ipmap'hidden   = pmaprecord(namenw).(0:1)#,           <<04102>>03305000
       ipmap'procstart  = pmaprecord(namenw+1)#,               <<04102>>03310000
       ipmap'proclen    = pmaprecord(namenw+2)#,               <<04102>>03315000
       ipmap'procentry  = pmaprecord(namenw+3)#,               <<04102>>03320000
       ipmap'tboxlink1  = pmaprecord(namenw+4)#,               <<04102>>03325000
       ipmap'tboxlink2  = pmaprecord(namenw+5)#,               <<04102>>03330000
       ipmap'tboxid     = pmaprecord(namenw+6)#,               <<04102>>03335000
                                                               <<04102>>03340000
       ipmap'secentry   = pmaprecord(namenw+1)#,               <<04102>>03345000
       ipmap'secentnum  = pmaprecord(namenw+2)#;               <<04102>>03350000
                                                                        03355000
equate  maxpmapreclen=15;                                      <<04102>>03360000
integer sysfpmap;                                              <<04584>>03365000
integer jsfpmap;                                               <<04584>>03370000
$page "USL FILE BUFFERS AND PARAMTERS"                         <<00207>>03375000
<<----------------------------------------------------------------------03380000
*                                                                      *03385000
*  usl file buffers and parameters                                     *03390000
*                                                                      *03395000
---------------------------------------------------------------------->>03400000
                                                                        03405000
equate uslfilecode = 1024,  <<usl file code>>                           03410000
       uslfileid = 1,  <<version nr.>>                                  03415000
       minusl = 5,  <<min. nr. rec's in usl file>>                      03420000
       maxusl = 32727,  <<max. nr. rec's in usl file>>                  03425000
       uslfhi = 33,  <<index of first hash list>>                       03430000
       biggesthead= 1023,  <<largest header length>>                    03435000
       bnd3 = 1151,  <<entry/header bound>>                             03440000
       maxdir = bnd3+1,  <<directory/entry buffer length>>              03445000
       maxhead = bnd3+1,  <<info/header buffer length>>                 03450000
       usldlbufs = 128+maxdir+maxhead;  <<dl buffer set length>>        03455000
                                                                        03460000
integer uslfnum _ 0;  <<file nr.>>                                      03465000
integer nuslfnum:=0; <<new usl file # for copyusl>>            <<00207>>03470000
                                                                        03475000
<<state word>>                                                          03480000
                                                                        03485000
logical uslstate := 0;                                                  03490000
define uslbufalloc = uslstate.(0:1)#,  <<dl buffers allocated?>>        03495000
       uslrec0mod = uslstate.(2:1)#,  <<record 0 modified?>>            03500000
       usldirincore = uslstate.(3:1)#,  <<directory in core?>>          03505000
       usldirmod = uslstate.(4:1)#,  <<directory modified?>>            03510000
       uslinfoincore = uslstate.(5:1)#,  <<info in core?>>              03515000
       uslinfomod = uslstate.(6:1)#,  <<info modified?>>       <<00660>>03520000
       uslclosecode = uslstate.(7:3)#; <<fclose code>>         <<00660>>03525000
integer statechanged := 0;  <<usl or auxusl state?>>                    03530000
                                                                        03535000
<<usl file record 0>>                                                   03540000
                                                                        03545000
integer pointer uslrec0;  <<usl file record 0>>                         03550000
double pointer usldrec0 = uslrec0;                                      03555000
define usllid = uslrec0#,  <<loader id>>                                03560000
       uslne = uslrec0(1)#,  <<nr. directory entries>>                  03565000
       usldl = uslrec0(2)#,  <<directory length>>                       03570000
       usltdg = uslrec0(3)#,  <<total directory garbage>>               03575000
       uslndg = uslrec0(4)#,  <<nr. directory garbage entries>>         03580000
       uslbdl = uslrec0(5)#,  <<s.a. block data list>>                  03585000
       uslipl = uslrec0(6)#,  <<s.a. interupt proc. list>>              03590000
       uslsl = uslrec0(7)#,  <<s.a. segment list>>                      03595000
       uslfl = usldrec0(4)#,  <<file length>>                           03600000
       uslfl2= uslrec0(9)#,    <<second word of file length>>  <<00207>>03605000
       uslsaad = uslrec0(10)#,  <<s.a. dir. avail. block>>              03610000
       usladl = uslrec0(11)#,  <<dir. avail. block length>>             03615000
       uslsai = usldrec0(6)#,  <<s.a. info block>>                      03620000
       uslil = usldrec0(7)#,  <<info block length>>                     03625000
       uslil2 = uslrec0(15)#,  <<second half>>                          03630000
       uslsaai = usldrec0(8)#,  <<s.a. info avail. block>>              03635000
       uslail = usldrec0(9)#,  <<info avail. block length>>             03640000
       uslail2= uslrec0(19)#,                                  <<00207>>03645000
       usltig = usldrec0(10)#,  <<total info garbage>>                  03650000
       usltig2= uslrec0(21)#,                                  <<00207>>03655000
       uslnig = uslrec0(22)#;  <<nr. info garbage entries>>             03660000
                                                                        03665000
<<usl directory/entry buffer>>                                          03670000
                                                                        03675000
integer pointer dir;  <<usl directory/entry buffer>>                    03680000
integer diradr;  <<file adr. of first word in directory buffer>>        03685000
                                                                        03690000
<<usl entry parameters>>                                                03695000
                                                                        03700000
integer entfileadr;  <<file address of current entry>>                  03705000
integer pointer entp;  <<points to first word of entry>>                03710000
integer pointer entp1;  <<points to word following entry name>>         03715000
double pointer entdp1 = entp1;                                          03720000
integer pointer entp2;  <<points to parm. info>>                        03725000
integer pointer bdp;  <<points to first word of b.d. sub-entry>>        03730000
integer entnw;  <<number of words in entry>>                            03735000
integer enttype;  <<entry type>>                                        03740000
equate uslany = -1,  <<any usl entry>>                                  03745000
       uslseg = 0,  <<any usl segment entry>>                           03750000
       uslnonseg = 1;  <<any usl non-segment entry>>                    03755000
define segmentname = (enttype = 1)#,                                    03760000
       primaryob = (enttype = 2)#,                                      03765000
       secondaryob = (enttype = 3)#,                                    03770000
       primaryproc = (enttype = 4)#,                                    03775000
       secondaryproc = (enttype = 5)#,                                  03780000
       interuptproc = (enttype = 6)#,                                   03785000
       blockdata = (enttype = 7)#,                                      03790000
       secparmproc = (enttype = 8)#;                                    03795000
integer entnc;  <<nr. char's in entry name>>                            03800000
integer entnamenw;  <<nr. words in entry name>>                         03805000
integer enthash;  <<entry name hash code>>                              03810000
integer entparmlen;  <<nr. words for parm info>>                        03815000
define edescrip = entp#,  <<descriptor word>>                           03820000
       enw = entp.(1:10)#,  <<nr. words in entry>>                      03825000
       elinks = entdp1#,  <<brother and son links>>                     03830000
       etype = entp.(11:5)#,  <<entry type nr.>>                        03835000
       ehl = entp(1)#,  <<hash link>>                                   03840000
       active = (not logical(entp(2).(0:1)))#,                          03845000
       inactive = (logical(entp(2).(0:1)))#,                            03850000
       callable' = (logical(entp(2).(1:1)))#,  <<uncallable?>>          03855000
       privledged = (logical(entp(2).(2:1)))#,  <<priv. inst.?>>        03860000
       hidden = (logical(entp(2).(3:1)))#,  <<hidden entry?>>           03865000
       eactivitybit = entp(2).(0:1)#,  <<activity bit>>                 03870000
       eit = entp(2).(1:2)#,  <<int. proc. type nr.>>                   03875000
       enc = entp(2).(4:4)#,  <<nr. char's in name>>                    03880000
       ename = entp(2)#,  <<entry name>>                                03885000
       ebl = entp1#,  <<brother link>>                                  03890000
       esl = entp1(1)#,  <<son link>>                                   03895000
       epusepa = entp1(1)#, << secondary entry point address >><<04102>>03900000
       epusa = entp1(2)#,  <<prog. unit starting adr.>>                 03905000
       esac1 = entp1(3)#,  <<s.a. of code module (first half)>>         03910000
       esac2 = entp1(4)#,  <<s.a. of code module (second half)>>        03915000
       ecode = entp1(5)#,  <<code module descriptor>>                   03920000
       fatalerror = (logical(entp1(5).(0:1)))#,  <<fatal error?>>       03925000
       warning = (logical(entp1(5).(1:1)))#,  <<non-fatal error?>>      03930000
       enwc = entp1(5).(2:14)#,  <<nr. words in code module>>           03935000
       estackest = entp1(6)#,  <<stack size estimate>>                  03940000
       etpdb = entp1(7)#,  <<total prim. db allocated>>                 03945000
       etsdb = entp1(8)#,  <<total sec. db allocated>>                  03950000
       enwpust = entp1(9)#,  <<nr. words in pust>>                      03955000
       enwsdb = entp1(10)#,  <<nr. words in sec. db array>>             03960000
       enwo = entp1(10)#,  <<nr. words in own array>>                   03965000
       enwd = entp1(10)#,  <<nr. words in data array>>                  03970000
       eparms = entp2#,  <<parameter info block>>                       03975000
       eheadnw = entheadp.(1:10)#,  <<nr. words in header>>             03980000
       eheadtype = entheadp.(11:5)#;  <<header type nr.>>               03985000
                                                                        03990000
<<header set parameters>>                                               03995000
                                                                        04000000
integer pointer entheadsetp;  <<points to first word of header set>>    04005000
integer pointer entheadp;  <<points to current descriptor word>>        04010000
double pointer entheaddp = entheadp;                                    04015000
double entheadadr;  <<file adr. (rel. sai) of current header>>          04020000
double entcodeadr;  <<file adr. (rel. sai) of code module>>             04025000
integer entnwcode;  <<nr. words in code module>>                        04030000
                                                                        04035000
<<usl info/header buffer>>                                              04040000
                                                                        04045000
integer pointer head;  <<usl info/header buffer>>                       04050000
double infoadr;  <<file adr. (rel. sai) of first word in header buffer>>04055000
                                                                        04060000
<<usl header parameters>>                                               04065000
                                                                        04070000
double headfileadr;  <<file address of current header>>                 04075000
integer headrecd;  <<first record containing current header>>           04080000
integer pointer headp;  <<points to first word of header>>              04085000
double pointer headdp = headp;                                          04090000
integer headnw;  <<number of words in header>>                          04095000
integer headtype;  <<header type number>>                               04100000
define hnw = headp.(1:10)#,  <<nr. words in header>>                    04105000
       htype = headp.(11:5)#;  <<header type nr.>>                      04110000
$page "AUXILIARY USL FILE BUFFERS AND PARAMETERS"              <<00207>>04115000
<<----------------------------------------------------------------------04120000
*                                                                      *04125000
*  auxiliary usl file buffers and parameters                           *04130000
*                                                                      *04135000
---------------------------------------------------------------------->>04140000
                                                                        04145000
<<state word>>                                                          04150000
                                                                        04155000
logical xuslstate := 0;                                                 04160000
define xuslbufalloc = xuslstate.(0:1)#,  <<dl buffers allocated?>>      04165000
       xuslrec0mod = xuslstate.(2:1)#,  <<record 0 modified?>>          04170000
       xusldirincore = xuslstate.(3:1)#,  <<directory in core?>>        04175000
       xusldirmod = xuslstate.(4:1)#,  <<directory modified?>>          04180000
       xuslinfoincore = xuslstate.(5:1)#,  <<info in core?>>            04185000
       xuslinfomod = xuslstate.(6:1)#,  <<info modified?>>     <<00660>>04190000
       xuslclosecode = xuslstate.(7:3)#; <<fclose code>>       <<00660>>04195000
                                                                        04200000
integer xuslfnum := 0;  <<file nr.>>                                    04205000
                                                                        04210000
<<record 0>>                                                            04215000
                                                                        04220000
integer pointer xuslrec0;  <<record 0 buffer>>                          04225000
double pointer xusldrec0 = xuslrec0;                                    04230000
define xusllid = xuslrec0#,  <<loader id>>                              04235000
       xuslne = xuslrec0(1)#,  <<nr. directory entries>>                04240000
       xusldl = xuslrec0(2)#,  <<directory length>>                     04245000
       xusltdg = xuslrec0(3)#,  <<total directory garbage>>             04250000
       xuslndg = xuslrec0(4)#,  <<nr. directory garbage entries>>       04255000
       xuslbdl = xuslrec0(5)#,  <<s.a. block data list>>                04260000
       xuslipl = xuslrec0(6)#,  <<s.a. interupt proc. list>>            04265000
       xuslsl = xuslrec0(7)#,  <<s.a. segment list>>                    04270000
       xuslfl = xusldrec0(4)#,  <<file length (in words)>>              04275000
       xuslsaad = xuslrec0(10)#,  <<s.a. directory avail. block>>       04280000
       xusladl = xuslrec0(11)#,  <<dir. avail. block length>>           04285000
       xuslsai = xusldrec0(6)#,  <<s.a. info block>>                    04290000
       xuslil = xusldrec0(7)#,  <<info block length>>                   04295000
       xuslil2 = xuslrec0(15)#,  <<second half>>                        04300000
       xuslsaai = xusldrec0(8)#,  <<s.a. info avail. block>>            04305000
       xuslail = xusldrec0(9)#,  <<info block avail. length>>           04310000
       xusltig = xusldrec0(10)#,  <<total info garbage>>                04315000
       xuslnig = xusldrec0(11)#;  <<nr. info garbage entries>>          04320000
                                                                        04325000
<<directory/entry buffer>>                                              04330000
                                                                        04335000
integer pointer xdir;  <<directory/entry buffer>>                       04340000
integer xdiradr;  <<file adr. of first word in buffer>>                 04345000
                                                                        04350000
<<entry patameters>>                                                    04355000
                                                                        04360000
integer pointer xentp;  <<points to first word of entry>>               04365000
integer pointer xentp1;  <<points to word following entry name>>        04370000
double pointer xentdp1 = xentp1;                                        04375000
integer pointer xentp2;  <<points to parm. info>>                       04380000
define xename = xentp(2)#,  <<entry name>>                              04385000
       xesac1 = xentp1(3)#,  <<s.a. of code module (first half)>>       04390000
       xesac2 = xentp1(4)#;  <<s.a. of code module (second half)>>      04395000
                                                                        04400000
<<info/header buffer>>                                                  04405000
                                                                        04410000
integer pointer xhead;  <<info/header buffer>>                          04415000
double xinfoadr;  <<file adr. (rel. sai) of first word in buffer>>      04420000
                                                                        04425000
<<header parameters>>                                                   04430000
                                                                        04435000
integer pointer xheadp;  <<points to first word of header>>             04440000
$page "DEFINITIONS USED BY USLCOPY"                            <<00207>>04445000
comment                                                        <<00207>>04450000
--------------------------------------------------------       <<00207>>04455000
*                                                      *       <<00207>>04460000
*     definitions for uslcopy                          *       <<00207>>04465000
*                                                      *       <<00207>>04470000
-------------------------------------------------------;       <<00207>>04475000
                                                               <<00207>>04480000
                                                               <<00207>>04485000
define newdl=   newrec0(2) #,                                  <<00666>>04490000
       newfl=   dnewrec0(4) #,                                 <<00207>>04495000
       newsaad= newrec0(10) #,                                 <<00207>>04500000
       newadl=  newrec0(11) #,                                 <<00207>>04505000
       newsai=  dnewrec0(6) #,                                 <<00207>>04510000
       newil=   dnewrec0(7) #,                                 <<00207>>04515000
       newsaai= dnewrec0(8) #,                                 <<00207>>04520000
       newail=  dnewrec0(9) #;                                 <<00207>>04525000
$page "PROGRAM FILE BUFFERS AND PARAMETERS"                    <<00207>>04530000
<<----------------------------------------------------------------------04535000
*                                                                      *04540000
*  program file buffers and parameters                                 *04545000
*                                                                      *04550000
---------------------------------------------------------------------->>04555000
                                                                        04560000
equate progfilecode = 1029,  <<program file code>>                      04565000
       maxcst = 255,  <<max. nr. of code segments>>            <<06093>>04570000
       maxcode = 16380,  <<max. code segment size>>                     04575000
       maxdata = 32758,  <<max. data segment size>>                     04580000
       defaultstack = 800,  <<default stack size>>                      04585000
       defaultdl = 0,  <<default dl size>>                              04590000
       defaultmaxdata = -1,  <<default max. data segment size>>         04595000
       progdlbufs1 = 256+95+128+512+16+7+19+512,<<dl buffer set<<06093>>04600000
       progdlbufs2 = 128+128;  <<dl buffer set>>                        04605000
                                                                        04610000
integer progfnum _ 0;  <<file nr.>>                                     04615000
                                                                        04620000
<<program file record 0>>                                               04625000
                                                                        04630000
integer pointer prog0;  <<program file record 0>>                       04635000
byte pointer pmap;  <<cst re-mapping array>>                            04640000
integer pointer pdescrip;  <<segment descriptor array>>                 04645000
define pflags = prog0#,  <<flag word>>                                  04650000
       pfatal = prog0.(0:1)#,  <<fatal error?>>                         04655000
       pwarning = prog0.(1:1)#,  <<non-fatal error?>>                   04660000
       pzerodb = prog0.(2:1)#,  <<zero db?>>                            04665000
       pmode = prog0.(3:1)#,  <<any segment privileged?>>               04670000
       pcap = prog0.(6:10)#,  <<capability bits>>                       04675000
       pns = prog0(1)#,  <<nr. segments>>                               04680000
       pgs = prog0(2)#,  <<global area size>>                           04685000
       psag = prog0(3)#,  <<rec. nr. of global area>>                   04690000
       psas = prog0(4)#,  <<rec. nr. of segment set>>                   04695000
       piss = prog0(5)#,  <<init. stack size>>                          04700000
       pidl = prog0(6)#,  <<init. dl size>>                             04705000
       pmaxd = prog0(7)#,  <<max. data segment size>>                   04710000
       psae = prog0(8)#,  <<rec. nr. of entry point list>>              04715000
       psseg = prog0(9)#,  <<starting segment nr.>>                     04720000
       psadr = prog0(10)#,  <<prim. entry pt. pb adr.>>                 04725000
       psastlt = prog0(11)#,  <<s.a. of stlt>>                          04730000
       psaflut = prog0(12)#,  <<s.a. of flut>>                          04735000
       psax = prog0(13)#,  <<rec. nr. of external list>>                04740000
       psstt = prog0(14)#;  <<prim. entry pt. stt nr.>>                 04745000
define psatrapcom = prog0 (15)#;  <<s.a. of trapcom'>>         <<00.bv>>04750000
define psapmap = prog0(16)#;     << first pmap sector >>       <<04102>>04755000
define psasym  = prog0(17)#;     << 1st sector of toolbox sis ><<04102>>04760000
define ppatch = prog0(18).(0:1)#,                              <<04257>>04765000
       pcksum = prog0(18).(1:1)#;                              <<04257>>04770000
define totalcksum = prog0(19)#;                                <<04257>>04775000
$page "SL FILE BUFFERS AND PARAMETERS"                         <<00207>>04780000
<<----------------------------------------------------------------------04785000
*                                                                      *04790000
*  sl file buffers and parameters                                      *04795000
*                                                                      *04800000
---------------------------------------------------------------------->>04805000
                                                                        04810000
equate slfilecode = 1031,  <<sl file code>>                             04815000
       slfileid = 3,  <<sl version nr.>>                                04820000
       minsl = 4,  <<min. nr. rec's in sl file>>                        04825000
       maxsl = 32767,  <<max. nr. rec's in sl file>>                    04830000
       minslel = 3,  <<min. nr. rec's in sl extent>>                    04835000
       sldlbufs1 = 128+128+128+128+128+16+16+16,  <<dl buffer set>>     04840000
       sldlbufs2 = 95+128+256;  <<dl buffer set length>>                04845000
                                                                        04850000
integer splfnum _ 0;  <<file nr.>>                                      04855000
double slkey;  <<sl file key>>                                          04860000
logical realsl;  <<real sl file or scratch?>>                           04865000
integer scratchfnum _ 0;  <<file nr.>>                                  04870000
integer osplfnum:=0; <<old sl file number>>                    <<00465>>04875000
                                                                        04880000
<<state word>>                                                          04885000
                                                                        04890000
logical slstate := 0;                                                   04895000
define slbufalloc = slstate.(0:1)#,  <<dl buffers allocated?>>          04900000
       slnew = slstate.(1:1)#,  <<new sl?>>                             04905000
       slrec0mod = slstate.(2:1)#;  <<records 0,1 modified?>>           04910000
                                                                        04915000
<<records 0,1 buffers>>                                                 04920000
                                                                        04925000
integer pointer splrec0;  <<sl file record 0>>                          04930000
integer pointer splrec1;  <<sl file record 1>>                          04935000
define spllid = splrec0#,  <<loader id>>                                04940000
       splfl = splrec0(1)#,  <<file length (in records)>>               04945000
       splel = splrec0(2)#,  <<extent length>>                          04950000
       spllasttoolboxid = splrec0(3)#,                         <<04102>>04955000
       splns = splrec0(4)#,  <<nr. segments in file>>                   04960000
       splfrtl = splrec0(7)#,  <<s.a. of free ref. tab. entry list>>    04965000
       splnrt = splrec0(9)#,  <<nr. ref. tab. entries allocated>>       04970000
       slns = splrec0(11)#;  <<nr. sections>>                           04975000
equate splfhi = 33;  <<index of first hash bucket head>>                04980000
                                                                        04985000
<<storage bit map buffer>>                                              04990000
                                                                        04995000
integer pointer slmap;  <<section bit map buffer>>                      05000000
integer slmaprecd;  <<rec. nr. of map in buffer>>                       05005000
logical slmapmodified;  <<map modified?>>                               05010000
                                                                        05015000
<<directory buffer>>                                                    05020000
                                                                        05025000
integer pointer spldir;  <<directory buffer>>                           05030000
double pointer splddir = spldir;                                        05035000
integer splrecd;  <<rec. nr. in directory buffer>>                      05040000
integer splprevrecd;  <<rec. nr. that points to current record>>        05045000
integer slnextrecd;  <<rec. nr. pointed to by current record>>          05050000
integer slrecdused;  <<nr. words of record used for entries>>           05055000
integer bucketindex;  <<record 0 index of hash list>>                   05060000
logical libentrymodified;  <<directory entry modified>>                 05065000
                                                                        05070000
<<entry parameters>>                                                    05075000
                                                                        05080000
integer pointer splp;  <<points to first word of entry>>                05085000
integer pointer splp1;  <<points to word following entry name>>         05090000
define sluncallable = (logical(splp.(1:1)))#,  <<entry uncallable?>>    05095000
       slnc = splp.(4:4)#,  <<nr. char's in name>>                      05100000
       slname = splp#,  <<entry point name>>                            05105000
       slplabel = splp1#,  <<entry point p-label>>                      05110000
       slsttnr = splp1.(0:8)#,  <<stt nr. of entry point>>              05115000
       slsegnr = splp1.(8:8)#,  <<seg. nr. of entry point>>             05120000
       slparms = splp1(1)#,  <<parm. info of entry point>>              05125000
       slpcheck = splp1(1).(0:2)#;  <<parm. checking level>>            05130000
integer splnw;  <<nr. words in entry>>                                  05135000
integer splnc;  <<nr. char's in entry name>>                            05140000
integer splnamenw;  <<nr. words for entry name>>                        05145000
                                                                        05150000
<<reference table buffer>>                                              05155000
                                                                        05160000
integer pointer rtbuf;  <<reference table buffer>>                      05165000
integer rtrecd;  <<current reference table record>>                     05170000
                                                                        05175000
<<reference table entry parameters>>                                    05180000
                                                                        05185000
integer pointer rtp;  <<ref. tab. entry pointer>>                       05190000
define slprivileged = logical(rtp.(0:1))#,  <<priv. inst. in seg.?>>    05195000
       slrsl = rtp.(2:14)#,  <<segment length>>                         05200000
       slrsa = rtp(1)#,  <<s.a. of segment>>                            05205000
       slrnr = rtp(2)#,  <<nr. rec's for seg. and ext. list>>           05210000
       slrflags = rtp(3)#,  <<segment flags>>                           05215000
       slrdeletedbit = rtp(3).(0:1)#,  <<seg. deleted bit>>             05220000
       deletedseg = logical(rtp(3).(0:1))#,  <<segment deleted?>>       05225000
       slrsatisbit = rtp(3).(1:1)#,  <<ext. satisfied bit>>             05230000
       satisfiedseg = logical(rtp(3).(1:1))#,  <<satisfied seg.?>>      05235000
       slrallocbit = rtp(3).(4:1)#,  <<perm. allocated bit>>            05240000
       slallocated = logical(rtp(3).(4:1))#,  <<perm. alloc. seg.?>>    05245000
       slrcorebit = rtp(3).(5:1)#,  <<core resident bit>>               05250000
       slresident = logical(rtp(3).(5:1))#,  <<core res. seg.?>>        05255000
       slsystem = logical(rtp(3).(6:1))#,  <<system segment?>>          05260000
       slrnrentpts = rtp(3).(9:7)#,  <<nr. entry points>>               05265000
       slrpmaprec = rtp(4)#,      << address of pmap area >>   <<04102>>05270000
       slrsirec   = rtp(5)#,      << address of si area >>     <<04102>>05275000
       slrpatch = rtp(6).(0:1)#,                               <<04257>>05280000
       slrcksum = rtp(6).(1:1)#,                               <<04257>>05285000
       slrsilen = rtp(7)#,                                     <<06537>>05290000
       slrsegname= rtp(8)#,  <<segment name>>                           05295000
       slrrefedsegs = rtp(16)#;  <<ref. seg. bit map>>                  05300000
logical rtmodified;  <<reference table entry modified?>>                05305000
                                                                        05310000
<<stt buffer>>                                                          05315000
                                                                        05320000
integer pointer sttp;  <<pl entry pointer>>                             05325000
integer slsttrecd;  <<rec. nr. of stt, etc.>>                           05330000
integer slsttnw;  <<stt, etc. length>>                                  05335000
logical slsttmodified;  <<stt, etc. modified?>>                         05340000
                                                                        05345000
<<stt map buffer>>                                                      05350000
                                                                        05355000
byte pointer slsttmap;  <<stt map array>>                               05360000
                                                                        05365000
<<external entry parameters>>                                           05370000
                                                                        05375000
integer pointer slxp;  <<entry pointer>>                                05380000
integer pointer slxp1;  <<secondary entry pointer>>                     05385000
define slxsatisbit = slxp.(0:1)#,  <<external satisfied bit>>           05390000
       slsatisextn = logical(slxp.(0:1))#,  <<external satisfied?>>     05395000
       slxname = slxp#,  <<external name>>                              05400000
       slxplabel = slxp1#,  <<external p-label>>                        05405000
       slxsttnr = slxp1.(0:8)#,  <<external stt nr.>>                   05410000
       slxsegnr = slxp1.(8:8)#,  <<external seg. nr.>>                  05415000
       slxparms = slxp1(1)#,  <<external parm. info>>                   05420000
       slxpcheck = slxp1(1).(0:2)#;  <<parm. check level>>              05425000
integer slxnc;  <<nr. char's in name>>                                  05430000
integer slxnw;  <<nr. words in entry>>                                  05435000
                                                                        05440000
<<segment binding parameters>>                                          05445000
                                                                        05450000
logical segsadded;  <<segments added?>>                                 05455000
logical pointer addedsegs;  <<added segment nr's>>                      05460000
logical segsdeleted;  <<segments deleted?>>                             05465000
logical pointer deletedsegs;  <<deleted segment nr's>>                  05470000
logical segsmodified;  <<segments modified?>>                           05475000
logical pointer modifiedsegs;  <<modified segment nr's>>                05480000
                                                                        05485000
$page "RL FILE BUFFERS AND PARAMTERS"                          <<00207>>05490000
<<----------------------------------------------------------------------05495000
*                                                                      *05500000
*  rl file buffers and parameters                                      *05505000
*                                                                      *05510000
---------------------------------------------------------------------->>05515000
                                                                        05520000
equate rlfilecode = 1028,  <<rl file code>>                             05525000
       rlfileid = 3,  <<version nr.>>                                   05530000
       minrl = 4,  <<min. nr. rec's in rl file>>                        05535000
       maxrl = 32767,  <<max. nr. rec's in rl file>>                    05540000
       rlfhi = 33,  <<record 0 index of first hash list>>               05545000
       rlproctablen = 64,  <<procedure table length>>                   05550000
       rldlbufs1 = 128+128+128+rlproctablen,  <<dl buffer set length>>  05555000
       rldlbufs2 = 256;  <<dl buffer set length>>                       05560000
                                                                        05565000
integer rlfnum _ 0;  <<file nr.>>                                       05570000
                                                                        05575000
<<state word>>                                                          05580000
                                                                        05585000
logical rlstate := 0;                                                   05590000
define rlbufalloc = rlstate.(0:1)#,  <<dl buffers allocated?>>          05595000
       rlnew = rlstate.(1:1)#,  <<new rl?>>                             05600000
       rlrec0mod = rlstate.(2:1)#;  <<record 0 modified?>>              05605000
                                                                        05610000
<<record 0 buffer>>                                                     05615000
                                                                        05620000
integer pointer rlrec0;  <<rl file record 0>>                           05625000
double pointer rldrec0 = rlrec0;                                        05630000
define rllid = rlrec0#,  <<loader id>>                                  05635000
       rlfl = rlrec0(1)#,  <<file length (in records)>>                 05640000
       rlns = rlrec0(2)#,  <<nr. sections>>                             05645000
       rlsaxl = rldrec0(2)#;  <<s.a. of external list>>                 05650000
                                                                        05655000
<<storage bit map buffer>>                                              05660000
                                                                        05665000
integer pointer rlmap;  <<section bit map buffer>>                      05670000
integer rlmaprecd;  <<rec. nr. of map in buffer>>                       05675000
logical rlmapmodified;  <<map modified?>>                               05680000
                                                                        05685000
<<directory buffer>>                                                    05690000
                                                                        05695000
integer pointer rldir;  <<directory buffer>>                            05700000
double pointer rlddir = rldir;                                          05705000
define rldirlink = rldir#,  <<next rec. nr.>>                           05710000
       rldirused = rldir(1)#;  <<nr. words used>>                       05715000
integer rlrecd;  <<rec. nr. in buffer>>                                 05720000
integer rlprevrecd;  <<rec. nr. that points to current rec.>>           05725000
integer rlnextrecd;  <<rec. nr. pointed to by current rec.>>            05730000
integer rlbucket;  <<record 0 index of current hash list>>              05735000
logical rlentrymodified;  <<buffer modified flag>>                      05740000
                                                                        05745000
<<entry parameters>>                                                    05750000
                                                                        05755000
integer pointer rlp;  <<points to first word of entry>>                 05760000
integer pointer rlp1;  <<points to word following name>>                05765000
double pointer rldp1 = rlp1;                                            05770000
define rlname = rlp#,  <<entry point name>>                             05775000
       rlprimary = (not logical(rlp.(0:1)))#,  <<primary entry point?>> 05780000
       rlsecondary = (logical(rlp.(0:1)))#,  <<secondary entry point?>> 05785000
       rluncallable = (logical(rlp.(1:1)))#,  <<uncallable entry?>>     05790000
       rlprivileged = (logical(rlp.(2:1)))#,  <<priv. inst. in code?>>  05795000
       rlinfo = rldp1#,  <<s.a. info block>>                            05800000
       rlsa = rlp1(2)#,  <<s.a. of entry point>>                        05805000
       rlcode = rlp1(3)#,  <<code module descriptor>>                   05810000
       rlfatal = (logical(rlp1(3).(0:1)))#,  <<fatal error in code?>>   05815000
       rlwarning = (logical(rlp1(3).(1:1)))#,  <<non-fatal error?>>     05820000
       rlnwc = rlp1(3).(2:14)#,  <<nr. words in code module>>           05825000
       rlparms = rlp1(4)#;  <<parm. info>>                              05830000
integer array rlarray(0:7);                                             05835000
define rlnc=rlarray(0)#, <<nr.char's in name>>                          05840000
       rlnamenw=rlarray(1)#, <<nr. word in name>>                       05845000
       rlnw=rlarray(2)#; <<nr. word in entry>>                          05850000
<<external buffer>>                                                     05855000
                                                                        05860000
integer pointer rlextnbuf;  <<external buffer>>                         05865000
define rlextnrecd = rlarray(3)#; <<first rec. nr. in buf>>              05870000
logical rlextnmod;  <<entry modified?>>                                 05875000
define nrrlextnrecds = rlarray(4)#;<<rec. capacity of buf>>             05880000
double rlheadadr;  <<file adr. of current header>>                      05885000
define rlheadnw=rlarray(5)#; <<nr. word in cur header>>                 05890000
                                                                        05895000
<<external entry parameters>>                                           05900000
                                                                        05905000
integer pointer rlxp;  <<entry pointer>>                                05910000
double pointer rlxdp = rlxp;  <<entry pointer>>                         05915000
integer pointer rlxp1;  <<secondary entry pointer>>                     05920000
define rlxlink = rlxdp#,  <<s.a. of next header set>>                   05925000
       rlxtpdb = rlxp(2)#,  <<nr. words of primary db>>                 05930000
       rlxtsdb = rlxp(3)#,  <<nr. words of secondary db>>               05935000
       rlxnwsdb = rlxp(4)#,  <<nr. words in sec. db array>>             05940000
       rlxnwpust = rlxp(5)#;  <<nr. words in pust>>                     05945000
define rlxcode = rlxp(-5)#,  <<code module descriptor>>                 05950000
       rlxinfo = rlxdp(-2)#,  <<s.a. of info block>>                    05955000
       rlxsa = rlxp(-2)#,  <<s.a. of entry point>>                      05960000
       rlxname = rlxp#,  <<external name>>                              05965000
       rlxsatisfiedbit = rlxp.(0:1)#,  <<satisfied bit>>                05970000
       rlxsatisfied = logical(rlxp.(0:1))#,  <<external satisfied?>>    05975000
       rlxnc = rlxp.(4:4)#,  <<nr. char's in name>>                     05980000
       rlxparms = rlxp1#;  <<parm info of external>>                    05985000
                                                                        05990000
<<procedure binding parameters>>                                        05995000
                                                                        06000000
integer pointer rlproctab;  <<procedure table>>                         06005000
define  nrprocsadded = rlarray(6)#, <<nr. proc. added>>                 06010000
        nrprocsdeleted = rlarray(7)#; << deleted >>                     06015000
logical cleanuprldir;  <<undeleted entry points remaining?>>            06020000
$page "PROCEDURE DECLARATIONS"                                 <<00207>>06025000
<<----------------------------------------------------------------------06030000
*                                                                      *06035000
*  procedure declarations                                              *06040000
*                                                                      *06045000
---------------------------------------------------------------------->>06050000
                                                                        06055000
intrinsic activate;                                            <<04102>>06060000
intrinsic createprocess;                                       <<04102>>06065000
intrinsic kill;                                                <<04102>>06070000
integer procedure addedproc (infoadr);                                  06075000
   value infoadr;                                                       06080000
   double infoadr;                                                      06085000
   option forward;                                                      06090000
procedure addentry (size);                                              06095000
   value size;                                                          06100000
   integer size;                                                        06105000
   option forward;                                                      06110000
procedure addhashlist;                                                  06115000
   option forward;                                                      06120000
procedure addheader (size);                                             06125000
   value size;                                                          06130000
   integer size;                                                        06135000
   option forward;                                                      06140000
procedure addtodirectory (size);                                        06145000
   value size;                                                          06150000
   integer size;                                                        06155000
   option forward;                                                      06160000
procedure addtoinfo (size);                                             06165000
   value size;                                                          06170000
   integer size;                                                        06175000
   option forward;                                                      06180000
integer procedure adjustuslf (fnum,nrrecs);                             06185000
   value fnum,nrrecs;                                                   06190000
   integer fnum,nrrecs;                                                 06195000
   option external;                                                     06200000
procedure allocatecommon;                                               06205000
   option forward;                                                      06210000
procedure applyblockdatas;                                              06215000
   option forward;                                                      06220000
procedure appendstt(coderecd);                                 <<04257>>06225000
   value coderecd;                                             <<04257>>06230000
   integer coderecd;                                           <<04257>>06235000
   option forward;                                                      06240000
intrinsic ascii;                                                        06245000
procedure awake (pcbindex,oldwait,newwait);                             06250000
   value pcbindex,oldwait,newwait;                                      06255000
   integer pcbindex,oldwait,newwait;                                    06260000
   option external;                                                     06265000
procedure bindsegs;                                                     06270000
   option forward;                                                      06275000
procedure blankline;                                                    06280000
   option forward;                                                      06285000
logical procedure blockdatareset;                                       06290000
   option forward;                                                      06295000
procedure bufferdatabytes (dbadr,buf,length,times);                     06300000
   value dbadr,length,times;                                            06305000
   logical dbadr,length;                                                06310000
   byte array buf;                                                      06315000
   integer times;                                                       06320000
   option forward;                                                      06325000
procedure bufferdatawords (dbadr,buf,length,times);                     06330000
   value dbadr,length,times;                                            06335000
   logical dbadr,length;                                                06340000
   integer array buf;                                                   06345000
   integer times;                                                       06350000
   option forward;                                                      06355000
logical procedure calendar;                                    <<00629>>06360000
   option external;                                            <<00629>>06365000
procedure changestate;                                                  06370000
   option forward;                                                      06375000
procedure cleanuplibbuf;                                                06380000
   option forward;                                                      06385000
procedure cleanuprlbuf;                                                 06390000
   option forward;                                                      06395000
procedure cleanuprlextnbuf;                                             06400000
   option forward;                                                      06405000
procedure cleanuprtbuf;                                                 06410000
   option forward;                                                      06415000
integer procedure cleanusl(uslfnum,filename);                  <<00207>>06420000
  value uslfnum;                                               <<00207>>06425000
  integer uslfnum;                                             <<00207>>06430000
  byte array filename;                                         <<00207>>06435000
  option external;                                             <<00207>>06440000
procedure clearbit (bitarray,bitnumber);                                06445000
   value bitnumber;                                                     06450000
   integer array bitarray; integer bitnumber;                           06455000
   option forward;                                                      06460000
procedure clearline;                                                    06465000
   option forward;                                                      06470000
double procedure clock;                                        <<00629>>06475000
   option external;                                            <<00629>>06480000
procedure closerl;                                                      06485000
   option forward;                                                      06490000
procedure closesl;                                                      06495000
   option forward;                                                      06500000
procedure closeusl;                                                     06505000
   option forward;                                                      06510000
integer procedure composeflut;                                          06515000
   option forward;                                                      06520000
procedure composestlt;                                                  06525000
   option forward;                                                      06530000
procedure copyfamily;                                                   06535000
   option forward;                                                      06540000
procedure corebuf1 (buffer,length);                                     06545000
   value length;                                                        06550000
   integer array buffer;                                                06555000
   integer length;                                                      06560000
   option forward;                                                      06565000
logical procedure correctclass;                                         06570000
   option forward;                                                      06575000
procedure createcoment (dlabel,type);                                   06580000
   value dlabel,type;                                                   06585000
   logical dlabel,type;                                                 06590000
   option forward;                                                      06595000
procedure createpatchent (type,adr);                                    06600000
   value type,adr;                                                      06605000
   integer type,adr;                                                    06610000
   option forward;                                                      06615000
procedure createsegentry (name);                                        06620000
   integer array name;                                                  06625000
   option forward;                                                      06630000
procedure createsyment (type,name,parms);                               06635000
   value type;                                                          06640000
   integer type; byte array name; integer array parms;                  06645000
   option forward;                                                      06650000
procedure debug;                                                        06655000
   option external;                                                     06660000
integer procedure deletedproc (infoadr);                                06665000
   value infoadr;                                                       06670000
   double infoadr;                                                      06675000
   option forward;                                                      06680000
procedure deletelibentry;                                               06685000
   option forward;                                                      06690000
procedure deleterlentry;                                                06695000
   option forward;                                                      06700000
double procedure delta(x,f);                                   <<00207>>06705000
   value x,f;                                                  <<00207>>06710000
   double x,f;                                                 <<00207>>06715000
   option forward;                                             <<00207>>06720000
integer procedure dlsize (nrwords);                                     06725000
   value nrwords;                                                       06730000
   integer nrwords;                                                     06735000
   option external;                                                     06740000
procedure dntoa (num,base,ba);                                          06745000
   value num,base;                                                      06750000
   double num;                                                          06755000
   integer base;                                                        06760000
   byte array ba;                                                       06765000
   option forward;                                                      06770000
procedure ejectpage;                                                    06775000
   option forward;                                                      06780000
procedure emitplabel;                                                   06785000
   option forward;                                                      06790000
procedure entrypoint (saentry);                                         06795000
   value saentry;                                                       06800000
   integer saentry;                                                     06805000
   option forward;                                                      06810000
procedure error (num);                                                  06815000
   value num; integer num;                                              06820000
   option forward;                                                      06825000
procedure errori(num, nparm);                                  <<00207>>06830000
   value num, nparm;                                           <<00207>>06835000
   integer num, nparm;                                         <<00207>>06840000
   option forward;                                             <<00207>>06845000
procedure errorn (num,nparm);                                           06850000
   value num,nparm;                                                     06855000
   integer num; double nparm;                                           06860000
   option forward;                                                      06865000
procedure errors (num,sparm);                                           06870000
   value num;                                                           06875000
   integer num;                                                         06880000
   byte array sparm;                                                    06885000
   option forward;                                                      06890000
procedure expandsyment (pntr,nrwords);                                  06895000
   value pntr,nrwords;                                                  06900000
   integer pointer pntr; integer nrwords;                               06905000
   option forward;                                                      06910000
procedure fcheck (filenum,errorcode,tlog,blknum,numrecs);               06915000
   value filenum;                                                       06920000
   integer filenum,errorcode,tlog,numrecs;                              06925000
   double blknum;                                                       06930000
   option variable,external;                                            06935000
procedure fclose (filenum,disposition,seccode);                         06940000
   value filenum,disposition,seccode;                                   06945000
   integer filenum,disposition,seccode;                                 06950000
   option external;                                                     06955000
procedure fcontrol (filenum,control,parm);                              06960000
   value filenum,control;                                               06965000
   integer filenum,control;                                             06970000
   logical parm;                                                        06975000
   option external;                                                     06980000
integer procedure feof (filenum);                                       06985000
   value filenum;                                                       06990000
   integer filenum;                                                     06995000
   option forward;                                                      07000000
procedure ferror (filenum);                                             07005000
   value filenum;                                                       07010000
   integer filenum;                                                     07015000
   option forward;                                                      07020000
procedure fgetinfo (filenum,filename,foptions,aoptions,recsize,         07025000
      devtype,ldnum,hdaddr,filecode,recptr,eof,flimit,logcount,         07030000
      physcount,blksize,extsize,numextents,userlabel,creatorid,         07035000
      diskadr);                                                         07040000
   value filenum;                                                       07045000
   integer filenum,recsize,devtype,filecode,blksize,numextents,         07050000
      userlabel;                                                        07055000
   byte array filename,creatorid;                                       07060000
   logical foptions,aoptions,ldnum,hdaddr,extsize;                      07065000
   double recptr,eof,flimit,logcount,physcount,diskadr;                 07070000
   option variable,external;                                            07075000
procedure finddirspace (hashcode,length);                               07080000
   value hashcode,length;                                               07085000
   integer hashcode,length;                                             07090000
   option forward;                                                      07095000
procedure findrldirspace (hashcode,nrwords);                            07100000
   value hashcode,nrwords;                                              07105000
   integer hashcode,nrwords;                                            07110000
   option forward;                                                      07115000
double procedure findrlspace (nrwords,recflag);                         07120000
   value nrwords,recflag;                                               07125000
   integer nrwords;                                                     07130000
   logical recflag;                                                     07135000
   option forward;                                                      07140000
integer procedure findslspace (nrrecs);                                 07145000
   value nrrecs;                                                        07150000
   integer nrrecs;                                                      07155000
   option forward;                                                      07160000
procedure fixuprl;                                                      07165000
   option forward;                                                      07170000
procedure fixupsl (refix);                                              07175000
   value refix;                                                         07180000
   logical refix;                                                       07185000
   option forward;                                                      07190000
procedure flock (filenum,flag);                                         07195000
   value filenum,flag;                                                  07200000
   integer filenum;                                                     07205000
   logical flag;                                                        07210000
   option external;                                                     07215000
integer procedure fopen (filedesignator,foptions,aoptions,recsize,      07220000
      device,formmsg,recmode,blockfactor,numbuffers,filesize,           07225000
      numextents,initalloc,filecode);                                   07230000
   value foptions,aoptions,recsize,recmode,blockfactor,numbuffers,      07235000
      filesize,numextents,initalloc,filecode;                           07240000
   byte array filedesignator,device,formmsg;                            07245000
   logical foptions,aoptions;                                           07250000
   integer recsize,recmode,blockfactor,numbuffers,numextents,           07255000
      initalloc,filecode;                                               07260000
   double filesize;                                                     07265000
   option variable,external;                                            07270000
procedure fpoint (filenum,recnum);                                      07275000
   value filenum,recnum;                                                07280000
   integer filenum;                                                     07285000
   double recnum;                                                       07290000
   option external;                                                     07295000
procedure freaddir (filenum,target,tcount,recnum);                      07300000
   value filenum,tcount,recnum;                                         07305000
   integer filenum,tcount;                                              07310000
   array target;                                                        07315000
   double recnum;                                                       07320000
   option external;                                                     07325000
procedure freaddir' (filenum,target,recnum);                            07330000
   value filenum,recnum;                                                07335000
   integer filenum,recnum;                                              07340000
   integer array target;                                                07345000
   option forward;                                                      07350000
procedure freadmr''(filenum,target,count,recnum);                       07355000
   value filenum,count,recnum;                                          07360000
   integer filenum,count,recnum;                                        07365000
   integer array target;                                                07370000
   option forward;                                                      07375000
procedure frename(filenum, newfilereference);                  <<00207>>07380000
   value filenum; integer filenum;                             <<00207>>07385000
   byte array newfilereference;                                <<00207>>07390000
   option external;                                            <<00207>>07395000
procedure funlock (filenum);                                            07400000
   value filenum;                                                       07405000
   integer filenum;                                                     07410000
   option external;                                                     07415000
procedure fwrite (filenum,target,tcount,control);                       07420000
   value filenum,tcount,control;                                        07425000
   integer filenum,tcount;                                              07430000
   array target;                                                        07435000
   logical control;                                                     07440000
   option external;                                                     07445000
procedure fwritedir (filenum,target,tcount,recnum);                     07450000
   value filenum,tcount,recnum;                                         07455000
   integer filenum,tcount;                                              07460000
   array target;                                                        07465000
   double recnum;                                                       07470000
   option external;                                                     07475000
procedure fwritedir' (filenum,target,recnum);                           07480000
   value filenum,recnum;                                                07485000
   integer filenum,recnum;                                              07490000
   integer array target;                                                07495000
   option forward;                                                      07500000
procedure fwritemr''(filenum,target,count,recnum);                      07505000
   value filenum,count,recnum;                                          07510000
   integer filenum,count,recnum;                                        07515000
   integer array target;                                                07520000
   option forward;                                                      07525000
procedure getbrother;                                                   07530000
   option forward;                                                      07535000
procedure getdir;                                                       07540000
   option forward;                                                      07545000
procedure getentry (fileadr);                                           07550000
   value fileadr;                                                       07555000
   integer fileadr;                                                     07560000
   option forward;                                                      07565000
logical procedure getfamily (fatheradr);                                07570000
   value fatheradr;                                                     07575000
   integer fatheradr;                                                   07580000
   option forward;                                                      07585000
procedure getfather;                                                    07590000
   option forward;                                                      07595000
procedure getheader (codeflag,fileadr);                                 07600000
   value codeflag,fileadr;                                              07605000
   logical codeflag;                                                    07610000
   double fileadr;                                                      07615000
   option forward;                                                      07620000
procedure getinfo;                                                      07625000
   option forward;                                                      07630000
integer procedure getjcw;                                               07635000
   option external;                                                     07640000
logical procedure getnextdescrip;                                       07645000
   option forward;                                                      07650000
logical procedure getnextheader (codeflag,bitmap);                      07655000
   value codeflag,bitmap;                                               07660000
   logical codeflag,bitmap;                                             07665000
   option forward;                                                      07670000
logical procedure getnextlibentry;                                      07675000
   option forward;                                                      07680000
logical procedure getnextlibrecd;                                       07685000
   option forward;                                                      07690000
logical procedure getnextrlentry;                                       07695000
   option forward;                                                      07700000
logical procedure getnextrlextn;                                        07705000
   option forward;                                                      07710000
logical procedure getnextrlheader;                                      07715000
   option forward;                                                      07720000
logical procedure getnextrlrecd;                                        07725000
   option forward;                                                      07730000
logical procedure getnextslextn;                                        07735000
   option forward;                                                      07740000
procedure getprivmode;                                                  07745000
   option external;                                                     07750000
procedure getrecddisp (fileadr,recd,disp);                              07755000
   value fileadr;                                                       07760000
   double fileadr; integer recd,disp;                                   07765000
   option forward;                                                      07770000
procedure getreftabentry (entrynr);                                     07775000
   value entrynr;                                                       07780000
   integer entrynr;                                                     07785000
   option forward;                                                      07790000
procedure getrlmap (sectionnr);                                         07795000
   value sectionnr;                                                     07800000
   integer sectionnr;                                                   07805000
   option forward;                                                      07810000
procedure getsegentry;                                                  07815000
   option forward;                                                      07820000
procedure getslmap (sectionnr);                                         07825000
   value sectionnr;                                                     07830000
   integer sectionnr;                                                   07835000
   option forward;                                                      07840000
procedure getson;                                                       07845000
   option forward;                                                      07850000
procedure getusermode;                                                  07855000
   option external;                                                     07860000
procedure initloadcache;                                       <<00807>>07865000
   option external;                                            <<00807>>07870000
integer procedure hash (name);                                          07875000
   byte array name;                                                     07880000
   option forward;                                                      07885000
procedure header1p (rlflag);                                            07890000
   value rlflag;                                                        07895000
   logical rlflag;                                                      07900000
   option forward;                                                      07905000
procedure header2p;                                                     07910000
   option forward;                                                      07915000
procedure header3p;                                                     07920000
   option forward;                                                      07925000
procedure header4p;                                                     07930000
   option forward;                                                      07935000
procedure header7p;                                                     07940000
   option forward;                                                      07945000
procedure header9p;                                                     07950000
   option forward;                                                      07955000
procedure header11p;                                                    07960000
   option forward;                                                      07965000
procedure header9s;                                                     07970000
   option forward;                                                      07975000
procedure header10s;                                                    07980000
   option forward;                                                      07985000
integer procedure inituslf (uslfnum,rec0);                     <<c+.06>>07990000
    value uslfnum; integer uslfnum;                            <<c+.06>>07995000
    integer array rec0;                                        <<c+.06>>08000000
    option external;                                           <<c+.06>>08005000
procedure insertrl;                                                     08010000
   option forward;                                                      08015000
procedure insertsl;                                                     08020000
   option forward;                                                      08025000
procedure listrl';                                                      08030000
   option forward;                                                      08035000
procedure listsl';                                                      08040000
   option forward;                                                      08045000
procedure listusl';                                                     08050000
   option forward;                                                      08055000
logical procedure loadedslseg (slkey,segnr);                            08060000
   value slkey,segnr;                                                   08065000
   double slkey;                                                        08070000
   integer segnr;                                                       08075000
   option external;                                                     08080000
procedure loadslstt;                                                    08085000
   option forward;                                                      08090000
procedure lockseg(en,test,pinx);                               <<00.eb>>08095000
   value en,test,pinx;                                         <<00.eb>>08100000
   integer en,pinx;                                            <<00.eb>>08105000
   logical test;                                               <<00.eb>>08110000
   option external;                                            <<00.eb>>08115000
procedure makepatches;                                                  08120000
   option forward;                                                      08125000
procedure makeroomindl (nrwords);                                       08130000
   value nrwords;                                                       08135000
   integer nrwords;                                                     08140000
   option forward;                                                      08145000
procedure masterbuf (tfnum,sfnum,tbuf,trecd,tdisp,                      08150000
                     flag,adr,buffer,length);                           08155000
   value tfnum,sfnum,flag,adr,length;                                   08160000
   integer tfnum,sfnum,trecd,tdisp,length;                              08165000
   integer array tbuf,buffer;                                           08170000
   double adr;                                                          08175000
   logical flag;                                                        08180000
   option forward;                                                      08185000
integer procedure message (nr,buf);                                     08190000
   value nr;                                                            08195000
   integer nr;                                                          08200000
   byte array buf;                                                      08205000
   option forward;                                                      08210000
integer procedure min2(a,b);                                            08215000
   value a,b;                                                           08220000
   integer a,b;                                                         08225000
   option forward;                                                      08230000
integer procedure min3(a,b,c);                                          08235000
   value a,b,c;                                                         08240000
   integer a,b,c;                                                       08245000
   option forward;                                                      08250000
procedure moveinfo (nrrecords);                                         08255000
   value nrrecords;                                                     08260000
   integer nrrecords;                                                   08265000
   option forward;                                                      08270000
procedure ntoa (num,base,ba);                                           08275000
   value num,base;                                                      08280000
   integer num,base;                                                    08285000
   byte array ba;                                                       08290000
   option forward;                                                      08295000
procedure oldfile( name, errnum);                              <<00648>>08300000
   value errnum;                                               <<00648>>08305000
   byte array name;                                            <<00648>>08310000
   integer errnum;                                             <<00648>>08315000
   option forward;                                             <<00648>>08320000
procedure openrl (newfile);                                             08325000
   value newfile; logical newfile;                                      08330000
   option forward;                                                      08335000
procedure opensl (newfile);                                             08340000
   value newfile; logical newfile;                                      08345000
   option forward;                                                      08350000
procedure openusl (newfile);                                            08355000
   value newfile; logical newfile;                                      08360000
   option forward;                                                      08365000
procedure parmcheck (formalp,actualp,parms);                   <<00595>>08370000
   integer array formalp,actualp,parms;                        <<00595>>08375000
   option forward;                                                      08380000
integer procedure parmlen (parms);                                      08385000
   integer array parms;                                                 08390000
   option forward;                                                      08395000
integer procedure physicalcst(pin,segmentnr);                  <<00.eb>>08400000
   value pin,segmentnr;                                        <<00.eb>>08405000
   integer pin,segmentnr;                                      <<00.eb>>08410000
   option external;                                            <<00.eb>>08415000
procedure prepareprogram;                                               08420000
   option forward;                                                      08425000
procedure preparerl (coderecd);                                         08430000
   value coderecd;                                                      08435000
   integer coderecd;                                                    08440000
   option forward;                                                      08445000
procedure preparesegment (segadr,codefnum,coderecd);                    08450000
   value segadr,codefnum,coderecd;                                      08455000
   integer segadr,codefnum,coderecd;                                    08460000
   option forward;                                                      08465000
procedure print (message,length,control);                               08470000
   value length,control;                                                08475000
   array message;                                                       08480000
   integer length,control;                                              08485000
   option external;                                                     08490000
procedure printerror (error,nerror,serror1,serror2);           <<00595>>08495000
   value error,nerror;                                                  08500000
   integer error;                                                       08505000
   double nerror;                                                       08510000
   byte array serror1,serror2;                                 <<00595>>08515000
   option forward;                                                      08520000
procedure printfilerror(error,nerror,serror1,serror2);         <<00595>>08525000
   value error,nerror;                                                  08530000
   integer error;                                                       08535000
   double nerror;                                                       08540000
   byte array serror1,serror2;                                 <<00595>>08545000
   option forward;                                                      08550000
procedure printline;                                                    08555000
   option forward;                                                      08560000
procedure printwarning (error,nerror,serror1,serror2);         <<00595>>08565000
   value error,nerror;                                                  08570000
   integer error;                                                       08575000
   double nerror;                                                       08580000
   byte array serror1,serror2;                                 <<00595>>08585000
   option forward;                                                      08590000
double procedure proctime;                                              08595000
   option external;                                                     08600000
procedure putdir;                                                       08605000
   option forward;                                                      08610000
procedure putinfo;                                                      08615000
   option forward;                                                      08620000
procedure quit (num);                                                   08625000
   value num;                                                           08630000
   integer num;                                                         08635000
   option external;                                                     08640000
logical procedure receivemail (pin,buffer,waitflag);                    08645000
   value pin,waitflag;                                                  08650000
   logical pin,waitflag;                                                08655000
   integer array buffer;                                                08660000
   option external;                                                     08665000
procedure removefamily (fatheradr);                                     08670000
   value fatheradr;                                                     08675000
   integer fatheradr;                                                   08680000
   option forward;                                                      08685000
procedure removerl;                                                     08690000
   option forward;                                                      08695000
procedure removesl;                                                     08700000
   option forward;                                                      08705000
procedure repairrecord (fnum,fileadr,newword);                          08710000
   value fnum,fileadr,newword;                                          08715000
   integer fnum,newword; double fileadr;                                08720000
   option forward;                                                      08725000
procedure repairrecord' (fnum,recd,disp,newword);                       08730000
   value fnum,recd,disp,newword;                                        08735000
   integer fnum,recd,disp,newword;                                      08740000
   option forward;                                                      08745000
procedure resetcontrol;                                        <<00.dm>>08750000
   option external;                                            <<00.dm>>08755000
procedure resetdb (parm);                                               08760000
   value parm;                                                          08765000
   integer parm;                                                        08770000
   option external;                                                     08775000
procedure returnrlspace (adr,nrwords);                                  08780000
   value adr,nrwords;                                                   08785000
   double adr;                                                          08790000
   integer nrwords;                                                     08795000
   option forward;                                                      08800000
procedure returnslspace (recd,nrrecs);                                  08805000
   value recd,nrrecs;                                                   08810000
   integer recd,nrrecs;                                                 08815000
   option forward;                                                      08820000
procedure rlentryparms;                                                 08825000
   option forward;                                                      08830000
procedure saverlmap;                                                    08835000
   option forward;                                                      08840000
procedure saveslmap;                                                    08845000
   option forward;                                                      08850000
procedure scanrl;                                                       08855000
   option forward;                                                      08860000
procedure scansegment (segadr);                                         08865000
   value segadr;                                                        08870000
   integer segadr;                                                      08875000
   option forward;                                                      08880000
logical procedure searchcommon (dlabel,type);                           08885000
   value dlabel,type;                                                   08890000
   logical dlabel,type;                                                 08895000
   option forward;                                                      08900000
logical procedure searchrl (name);                                      08905000
   integer array name;                                                  08910000
   option forward;                                                      08915000
logical procedure searchrltab (infoadr);                                08920000
   value infoadr;                                                       08925000
   double infoadr;                                                      08930000
   option forward;                                                      08935000
integer procedure searchsegname (name);                                 08940000
   byte array name;                                                     08945000
   option forward;                                                      08950000
logical procedure searchspl (name);                                     08955000
   integer array name;                                                  08960000
   option forward;                                                      08965000
logical procedure searchsym (name,type);                                08970000
   value type;                                                          08975000
   integer array name; logical type;                                    08980000
   option forward;                                                      08985000
logical procedure searchusl (name,index,type,mode');           <<03026>>08990000
   value index,type,mode';                                     <<03026>>08995000
   logical mode';                                              <<03026>>09000000
   integer array name; integer index,type;                              09005000
   option forward,variable;                                    <<03026>>09010000
logical procedure sendmail (pin,count,buffer,waitflag);                 09015000
   value pin,count,waitflag;                                            09020000
   logical pin,count,waitflag;                                          09025000
   integer array buffer;                                                09030000
   option external;                                                     09035000
procedure setactivity (adflag);                                         09040000
   value adflag;                                                        09045000
   logical adflag;                                                      09050000
   option forward;                                                      09055000
procedure setbit (bitarray,bitnumber);                                  09060000
   value bitnumber;                                                     09065000
   integer array bitarray; integer bitnumber;                           09070000
   option forward;                                                      09075000
procedure setjcw (parm);                                                09080000
   value parm;                                                          09085000
   integer parm;                                                        09090000
   option external;                                                     09095000
integer procedure setsysdb;                                             09100000
   option external;                                                     09105000
procedure setuplibbuf;                                                  09110000
   option forward;                                                      09115000
procedure setuprlbuf;                                                   09120000
   option forward;                                                      09125000
procedure setuprlextnbuf (extnadr);                                     09130000
   value extnadr;                                                       09135000
   double extnadr;                                                      09140000
   option forward;                                                      09145000
procedure setuprlheaders (adr);                                         09150000
   value adr;                                                           09155000
   double adr;                                                          09160000
   option forward;                                                      09165000
procedure splentryparms;                                                09170000
   option forward;                                                      09175000
integer procedure stacksize (nrwords);                                  09180000
   value nrwords;                                                       09185000
   integer nrwords;                                                     09190000
   option external;                                                     09195000
procedure storeslstt;                                                   09200000
   option forward;                                                      09205000
integer procedure sumbits (bitarray);                                   09210000
   integer array bitarray;                                              09215000
   option forward;                                                      09220000
procedure symentparms;                                                  09225000
   option forward;                                                      09230000
procedure systemdebug;                                                  09235000
   option external;                                                     09240000
procedure terminate;                                                    09245000
   option external;                                                     09250000
logical procedure testbit (bitarray,bitnumber);                         09255000
   value bitnumber;                                                     09260000
   integer array bitarray; integer bitnumber;                           09265000
   option forward;                                                      09270000
integer procedure thiscpu;                                     <<00.dm>>09275000
   option external;                                            <<00.dm>>09280000
double procedure timer;                                                 09285000
   option external;                                                     09290000
procedure transclosure;                                                 09295000
   option forward;                                                      09300000
procedure unlinkfamily (fatheradr);                                     09305000
   value fatheradr;                                                     09310000
   integer fatheradr;                                                   09315000
   option forward;                                                      09320000
procedure uslcopy;                                             <<00207>>09325000
   option forward;                                             <<00207>>09330000
procedure uslentryparms;                                                09335000
   option forward;                                                      09340000
procedure warn (num);                                                   09345000
   value num;                                                           09350000
   integer num;                                                         09355000
   option forward;                                                      09360000
procedure warns (num,sparm);                                            09365000
   value num;                                                           09370000
   integer num;                                                         09375000
   byte array sparm;                                                    09380000
   option forward;                                                      09385000
procedure who (mode,capability,lattr,usern,groupn,acctn,homen,termn);   09390000
   logical mode,termn;                                                  09395000
   double capability,lattr;                                             09400000
   byte array usern,groupn,acctn,homen;                                 09405000
   option variable,external;                                            09410000
procedure xcontrap( plabel, oldplabel);                        <<00.dm>>09415000
   value plabel;                                               <<00.dm>>09420000
   integer plabel, oldplabel;                                  <<00.dm>>09425000
   option external;                                            <<00.dm>>09430000
procedure pmapcbinit(fnum,pmapcb,status);                      <<04584>>09435000
   value fnum;                                                 <<04584>>09440000
   integer fnum,status;                                        <<04584>>09445000
   integer array pmapcb;                                       <<04584>>09450000
   option external;                                            <<04584>>09455000
procedure pmapfindsegnum(segnum,pmapcb,status);                <<04584>>09460000
   value segnum;                                               <<04584>>09465000
   integer segnum,status;                                      <<04584>>09470000
   integer array pmapcb;                                       <<04584>>09475000
   option external;                                            <<04584>>09480000
logical procedure getipmaprec(buf,ptr,scan',pmapcb,status);    <<04584>>09485000
   value scan';                                                <<04584>>09490000
   integer scan',status;                                       <<04584>>09495000
   integer array buf,pmapcb;                                   <<04584>>09500000
   integer pointer ptr;                                        <<04584>>09505000
   option external;                                            <<04584>>09510000
procedure buildnameblock(block,blocklen,string,strlen,sta);    <<04584>>09515000
   value blocklen,strlen;                                      <<04584>>09520000
   integer blocklen,strlen,sta;                                <<04584>>09525000
   byte array block,string;                                    <<04584>>09530000
   option variable,external;                                   <<04584>>09535000
logical procedure namesmatch(name1,name2);                     <<04584>>09540000
   byte array name1,name2;                                     <<04584>>09545000
   option external;                                            <<04584>>09550000
$page "GENERAL PURPOSE PROCEDURES  -  FERROR"                  <<00207>>09555000
$ control segment = seg3                                                09560000
procedure ferror (filenum);                                             09565000
   <<this procedure checks the file system error and prints a message>> 09570000
   value filenum;                                                       09575000
   integer filenum;                                                     09580000
   begin                                                                09585000
   byte array filetype (0:15);                                          09590000
   tos _ 84;  <<eof error nr.>>                                         09595000
   tos _ 0d; fcheck(filenum,s0);  <<file sys. error nr.>>               09600000
   tos _ 0;  <<for result of message>>                                  09605000
   if filenum = uslfnum then                                            09610000
      begin                                                             09615000
      tos := 200;                                                       09620000
      if logical(statechanged) then tos := tos+1;  <<aux. usl?>>        09625000
      go l1                                                             09630000
      end;                                                              09635000
   if filenum = xuslfnum then                                           09640000
      begin                                                             09645000
      tos := 201;                                                       09650000
      if logical(statechanged) then tos := tos-1;  <<usl file?>>        09655000
      go l1                                                             09660000
      end;                                                              09665000
   if filenum = splfnum then begin tos _ 202; go l1 end;                09670000
   if filenum = rlfnum then begin tos _ 203; go l1 end;                 09675000
   if filenum = rlibfnum then begin tos _ 204; go l1 end;               09680000
   if filenum = progfnum then begin tos _ 205; go l1 end;               09685000
   if filenum = listfnum then begin tos _ 206; go l1 end;               09690000
   if filenum=osplfnum then begin tos:=208; go l1 end;         <<00465>>09695000
   if filenum=nuslfnum then begin tos:=209; go l1 end;         <<00207>>09700000
   tos _ 207;  <<scratch file>>                                         09705000
   l1:                                                                  09710000
   filetype _ message(*,filetype(1));                                   09715000
   printfilerror(*,*,filetype,null);                           <<00595>>09720000
   <<********************************************************>><<01.dm>>09725000
   << preserve any information in core that may be destroyed >><<01.dm>>09730000
   << by aborting.  note: we will not try to save the info   >><<01.dm>>09735000
   << of the file that got the error since this could but us >><<01.dm>>09740000
   << into an endless loop.                                  >><<01.dm>>09745000
   <<********************************************************>><<01.dm>>09750000
   if filenum <> splfnum then closesl;                         <<01.dm>>09755000
   if filenum <> rlfnum then closerl;                          <<01.dm>>09760000
   if filenum <> uslfnum then                                  <<01.dm>>09765000
      begin                                                    <<01.dm>>09770000
      if logical(statechanged) then changestate; <<orig>>      <<01.dm>>09775000
      closeusl;                                                <<01.dm>>09780000
      end;                                                     <<01.dm>>09785000
   quit(0)                                                              09790000
   end;                                                                 09795000
$page "GENERAL PURPOSE PROCEDURES  -  FEOF"                    <<00207>>09800000
$ control segment = seg3                                                09805000
integer procedure feof (filenum);                                       09810000
   <<returns the end-of-file record number for the specified file>>     09815000
   value filenum;                                                       09820000
   integer filenum;                                                     09825000
   begin                                                                09830000
   tos _ 0d;                                                            09835000
   fgetinfo(filenum,,,,,,,,,,ds1);  <<get eof>>                         09840000
   feof _ tos                                                           09845000
   end;                                                                 09850000
$page "GENERAL PURPOSE PROCEDURES  -  FREADDIR'"               <<00207>>09855000
$ control segment = seg3                                                09860000
procedure freaddir' (filenum,target,recnum);                            09865000
   <<interface to freaddir: adds the record size of 128 words and       09870000
     converts the record number to double>>                             09875000
   value filenum,recnum;                                                09880000
   integer filenum,recnum; integer array target;                        09885000
   begin                                                                09890000
   freaddir(filenum,target,128,double(logical(recnum)));                09895000
   if <> then ferror(filenum)  <<error?>>                               09900000
   end;                                                                 09905000
$page "GENERAL PURPOSE PROCEDURES  -  FWRITEDIR'"              <<00207>>09910000
$ control segment = seg3                                                09915000
procedure fwritedir' (filenum,target,recnum);                           09920000
   <<interface to fwritedir: adds the record size of 128 words and      09925000
     converts the record number to double>>                             09930000
   value filenum,recnum;                                                09935000
   integer filenum,recnum; integer array target;                        09940000
   begin                                                                09945000
   fwritedir(filenum,target,128,double(logical(recnum)));               09950000
   if <> then ferror(filenum)  <<error?>>                               09955000
   end;                                                                 09960000
$page "GENERAL PURPOSE PROCEDURES  -  FREADMR''"               <<00207>>09965000
$ control segment = seg3                                                09970000
procedure freadmr''(filenum,target,count,recnum);                       09975000
   <<interface to file system mulit-record read>>                       09980000
   value filenum,count,recnum;                                          09985000
   integer filenum,count,recnum;                                        09990000
   integer array target;                                                09995000
   begin                                                                10000000
   entry freadmr';                                                      10005000
   tos := filenum;  <<file nr.>>                                        10010000
   tos := @target;  <<buffer adr.>>                                     10015000
   tos := count;  <<word count>>                                        10020000
   if = then go getout;  <<zero count?>>                                10025000
   freaddir(*,*,*,double(logical(recnum)));                             10030000
   if > then  <<eof?>>                                                  10035000
      begin                                                             10040000
      count _ (feof(filenum)-recnum)&lsl(7);  <<adj. count>>            10045000
      go read                                                           10050000
      end;                                                              10055000
   go readcheck;                                                        10060000
                                                                        10065000
   freadmr': read:                                                      10070000
   freaddir(filenum,target,count,double(logical(recnum)));              10075000
                                                                        10080000
   readcheck:                                                           10085000
   if <> then ferror(filenum);  <<error?>>                              10090000
                                                                        10095000
   getout:                                                              10100000
   end;                                                                 10105000
$page "GENERAL PURPOSE PROCEDURES  -  FWRITEMR''"              <<00207>>10110000
$ control segment = seg3                                                10115000
procedure fwritemr''(filenum,target,count,recnum);                      10120000
   <<integface to file system multi-record write>>                      10125000
   value filenum,count,recnum;                                          10130000
   integer filenum,count,recnum;                                        10135000
   integer array target;                                                10140000
   begin                                                                10145000
   entry fwritemr';                                                     10150000
   count _ min2(feof(filenum)-recnum,count&lsr(7))&lsl(7);              10155000
                                                                        10160000
   fwritemr':                                                           10165000
   fwritedir(filenum,target,count,double(logical(recnum)));             10170000
   if <> then ferror(filenum)  <<error?>>                               10175000
   end;                                                                 10180000
$page "GENERAL PURPOSE PROCEDURES  -  CLEANLINE"               <<00207>>10185000
$ control segment = seg3                                                10190000
procedure clearline;                                                    10195000
   <<clears the list buffer>>                                           10200000
   begin                                                                10205000
   tos _ @line; ps0 _ "  ";                                             10210000
   assemble(dup,incb); tos _ 65; assemble(move 3)                       10215000
   end;                                                                 10220000
$page "GENERAL PURPOSE PROCEDURES  -  BLANKLINE"               <<00207>>10225000
$ control segment = seg3                                                10230000
procedure blankline;                                                    10235000
   <<prints a blank line on the list device and clears the list buffer>>10240000
   begin                                                                10245000
   if list then                                                         10250000
      begin                                                             10255000
      fwrite(listfnum,line,0,0);                                        10260000
      if <> then ferror(listfnum)  <<error?>>                           10265000
      end;                                                              10270000
   clearline                                                            10275000
   end;                                                                 10280000
$page "GENERAL PURPOSE PROCEDURES  -  PRINTLINE"               <<00207>>10285000
$ control segment = seg3                                                10290000
procedure printline;                                                    10295000
   <<prints the contents of the list buffer on the list device and      10300000
     clears the list buffer>>                                           10305000
   begin                                                                10310000
   if list then                                                         10315000
      begin                                                             10320000
      tos _ listfnum;                                                   10325000
      tos _ @line;                                                      10330000
      tos _ @bline(71);  <<pointer to last char.>>                      10335000
      if bps0 = " " then                                                10340000
         begin                                                          10345000
         assemble(dup,decb);                                            10350000
         tos _ -71;                                                     10355000
         assemble(cmpb 2)                                               10360000
         end;                                                           10365000
      tos _ -(tos-@bline+1);  <<neg. nr. char's>>                       10370000
      if s0 < listwidth then  <<truncate line?>>                        10375000
         begin                                                          10380000
         del;                                                           10385000
         tos _ listwidth                                                10390000
         end;                                                           10395000
      fwrite(*,*,*,0);                                                  10400000
      if <> then ferror(listfnum)  <<error?>>                           10405000
      end;                                                              10410000
   clearline                                                            10415000
   end;                                                                 10420000
$page "GENERAL PURPOSE PROCEDURES  -  EJECTPAGE"               <<00207>>10425000
$ control segment = seg3                                                10430000
procedure ejectpage;                                                    10435000
   <<ejects the page on the list device>>                               10440000
   begin                                                                10445000
   if list then                                                         10450000
      begin                                                             10455000
      tos _ listfnum; tos _ 0; tos _ 0;                                 10460000
      fwrite(*,*,*,%61);                                                10465000
      if <> then ferror(listfnum)  <<error?>>                           10470000
      end                                                               10475000
   end;                                                                 10480000
$page "GENERAL PURPOSE PROCEDURES  -  MIN2"                    <<00207>>10485000
$ control segment = seg3                                                10490000
integer procedure min2(a,b);                                            10495000
   <<returns the minimum argument>>                                     10500000
   value a,b;                                                           10505000
   integer a,b;                                                         10510000
   min2 _ if a < b then a else b;                                       10515000
$page "GENERAL PURPOSE PROCEDURES  -  MIN3"                    <<00207>>10520000
$ control segment = seg3                                                10525000
integer procedure min3(a,b,c);                                          10530000
   <<returns the minimum argument>>                                     10535000
   value a,b,c;                                                         10540000
   integer a,b,c;                                                       10545000
   min3 _ if (a < b) and (a < c) then a else min2(b,c);                 10550000
$page "GENERAL PURPOSE PROCEDURES  -  TESTBIT"                 <<00207>>10555000
$ control segment = seg3                                                10560000
logical procedure testbit (bitarray,bitnumber);                         10565000
   value bitnumber; integer array bitarray; integer bitnumber;          10570000
   begin                                                                10575000
   tos _ bitnumber.(0:12)+@bitarray;                                    10580000
   tos _ ps0;                                                           10585000
   xreg _ bitnumber.(12:4);                                             10590000
   assemble(csl 1,x);                                                   10595000
   testbit _ tos                                                        10600000
   end;                                                                 10605000
$page "GENERAL PURPOSE PROCEDURES  -  CLEARBIT"                <<00207>>10610000
$ control segment = seg3                                                10615000
procedure clearbit (bitarray,bitnumber);                                10620000
   <<clears the bit specified by bitnumber in the bit array             10625000
     specified by bitarray>>                                            10630000
   value bitnumber;                                                     10635000
   integer array bitarray; integer bitnumber;                           10640000
   begin                                                                10645000
   tos _ bitnumber.(0:12)+@bitarray;                                    10650000
   tos _ ps0;                                                           10655000
   xreg _ bitnumber;                                                    10660000
   assemble(trbc 0,x);                                                  10665000
   ps1 _ tos                                                            10670000
   end;                                                                 10675000
$page "GENERAL PURPOSE PROCEDURES  -  SETBIT"                  <<00207>>10680000
$ control segment = seg3                                                10685000
procedure setbit (bitarray,bitnumber);                                  10690000
   <<sets the bit specified by bitnumber in the bit array               10695000
     specified by bitarray>>                                            10700000
   value bitnumber;                                                     10705000
   integer array bitarray; integer bitnumber;                           10710000
   begin                                                                10715000
   tos _ bitnumber.(0:12)+@bitarray;                                    10720000
   tos _ ps0;                                                           10725000
   xreg _ bitnumber;                                                    10730000
   assemble(tsbc 0,x);                                                  10735000
   ps1 _ tos                                                            10740000
   end;                                                                 10745000
$page "GENERAL PURPOSE PROCEDURES  -  SUMBITS"                 <<00207>>10750000
$ control segment = seg3                                                10755000
integer procedure sumbits (bitarray);                                   10760000
   <<returns the number of bits set in a 16 word bit map>>              10765000
   integer array bitarray;                                              10770000
   begin                                                                10775000
   integer bitcount = sumbits;                                          10780000
   tos _ 15;                                                            10785000
   do begin                                                             10790000
      tos _ bitarray(s0);                                               10795000
      while <> do                                                       10800000
         begin                                                          10805000
         assemble(scan 0);                                              10810000
         bitcount _ bitcount+1                                          10815000
         end;                                                           10820000
      assemble(del,deca)                                                10825000
      end until <                                                       10830000
   end;                                                                 10835000
$page "GENERAL PURPOSE PROCEDURES  -  DNTOA"                   <<00207>>10840000
$ control segment = seg3                                                10845000
procedure dntoa (num,base,ba);                                          10850000
   value num,base;                                                      10855000
   double num; integer base; byte array ba;                             10860000
   begin                                                                10865000
   ba(0) _ "0";                                                         10870000
   while num <> 0d do                                                   10875000
      begin                                                             10880000
      assemble(zero; load num; load base; ldiv;                         10885000
               ldd num; delb; load base; ldiv;                          10890000
               addi %60);                                               10895000
      ba(xreg) _ tos;                                                   10900000
      num _ tos;                                                        10905000
      xreg _ xreg-1                                                     10910000
      end                                                               10915000
   end;                                                                 10920000
$page "GENERAL PURPOSE PROCEDURES  -  NTOA"                    <<00207>>10925000
$ control segment = seg3                                                10930000
procedure ntoa (num,base,ba);                                           10935000
   value num,base;                                                      10940000
   integer num,base;                                                    10945000
   byte array ba;                                                       10950000
   dntoa(double(logical(num)),base,ba);                                 10955000
$page "GENERAL PURPOSE PROCEDURES  -  LDNTOA"                  <<00595>>10960000
$ control segment = seg3                                       <<00595>>10965000
   integer procedure ldntoa(num, base, ba);                    <<00595>>10970000
      value num, base;                                         <<00595>>10975000
      double num;                                              <<00595>>10980000
      integer base;                                            <<00595>>10985000
      byte array ba;                                           <<00595>>10990000
   begin                                                       <<00595>>10995000
      byte array buf(0:11)=q;                                  <<00595>>11000000
                                                               <<00595>>11005000
      xreg := 12;                                              <<00595>>11010000
      do begin                                                 <<00595>>11015000
         assemble(zero; load num; load base; ldiv;             <<00595>>11020000
                  ldd num; delb; load base; ldiv;              <<00595>>11025000
                  addi %60);                                   <<00595>>11030000
         buf(xreg:=xreg-1) := tos;                             <<00595>>11035000
         num := tos;                                           <<00595>>11040000
         end until num=0d;                                     <<00595>>11045000
      move ba := buf(xreg),(ldntoa:=12-xreg);                  <<00595>>11050000
   end;                                                        <<00595>>11055000
$page "GENERAL PURPOSE PROCEDURES  -  LNTOA"                   <<00595>>11060000
$ control segment = seg3                                       <<00595>>11065000
   integer procedure lntoa( num, base, ba);                    <<00595>>11070000
      value num, base;                                         <<00595>>11075000
      integer num, base;                                       <<00595>>11080000
      byte array ba;                                           <<00595>>11085000
      lntoa := ldntoa(double(logical(num)),base,ba);           <<00595>>11090000
$page "GENERAL PURPOSE PROCEDURES  -  WARN"                    <<00595>>11095000
$ control segment = seg4                                                11100000
procedure warn (num);                                                   11105000
   value num;                                                           11110000
   integer num;                                                         11115000
   printwarning(num,m1d,null,null);                            <<00595>>11120000
$page "GENERAL PURPOSE PROCEDURES  -  WARNS"                   <<00207>>11125000
$ control segment = seg4                                                11130000
procedure warns (num,sparm);                                            11135000
   value num;                                                           11140000
   integer num;                                                         11145000
   byte array sparm;                                                    11150000
   printwarning(num,m1d,sparm,null);                           <<00595>>11155000
$page "GENERAL PURPOSE PROCEDURES  -  WARNS2"                  <<01124>>11160000
$ control segment = seg4                                       <<01124>>11165000
procedure warns2 (num,sparm1,sparm2);                          <<01124>>11170000
   value num;                                                  <<01124>>11175000
   integer num;                                                <<01124>>11180000
   byte array sparm1,sparm2;                                   <<01124>>11185000
   printwarning(num,m1d,sparm1,sparm2);                        <<01124>>11190000
$page "GENERAL PURPOSE PROCEDURES  -  ERROR"                   <<01124>>11195000
$ control segment = seg4                                                11200000
procedure error (num);                                                  11205000
   value num; integer num;                                              11210000
   printerror(num,m1d,null,null);                              <<00595>>11215000
$page "GENERAL PURPOSE PROCEDURES  -  ERRORN"                  <<00207>>11220000
$ control segment = seg4                                                11225000
procedure errorn (num,nparm);                                           11230000
   value num,nparm;                                                     11235000
   integer num; double nparm;                                           11240000
   printfilerror(num,nparm,null,null);<<prints fcheck>>        <<00595>>11245000
$page "GENERAL PURPOSE PROCEDURES  -  ERRORI"                  <<00207>>11250000
$control segment=seg4                                          <<00207>>11255000
procedure errori(num, nparm);                                  <<00207>>11260000
   value num, nparm;                                           <<00207>>11265000
   integer num, nparm;                                         <<00207>>11270000
   errorn(num, double(nparm));                                 <<00207>>11275000
$page "GENERAL PURPOSE PROCEDURES  -  ERRORS"                  <<00207>>11280000
$ control segment = seg4                                                11285000
procedure errors (num,sparm);                                           11290000
   value num;                                                           11295000
   integer num;                                                         11300000
   byte array sparm;                                                    11305000
   printerror(num,m1d,sparm,null);                             <<00595>>11310000
$page "GENERAL PURPOSE PROCEDURES  -  ERRORS2"                 <<00595>>11315000
$control segment = seg4                                        <<00595>>11320000
procedure errors2 (num,sparm1,sparm2);                         <<00595>>11325000
   value num;                                                  <<00595>>11330000
   integer num;                                                <<00595>>11335000
   byte array sparm1,sparm2;                                   <<00595>>11340000
   printerror(num,m1d,sparm1,sparm2);                          <<00595>>11345000
$page "GENERAL PURPOSE PROCEDURES  -  PRINTERROR"              <<00595>>11350000
$ control segment = seg4                                                11355000
procedure printerror (error,nerror,serror1,serror2);           <<00595>>11360000
   <<prints an error message on the job list device along with an       11365000
     optional numeric parameter (if not equal to -1d) and an optional   11370000
     string parameter (if the character count is not equal to 0)>>      11375000
   value error,nerror;                                                  11380000
   integer error;                                                       11385000
   double nerror;                                                       11390000
   byte array serror1,serror2;                                 <<00595>>11395000
   begin                                                                11400000
   entry printwarning;                                                  11405000
   entry printfilerror;                                                 11410000
   move bline _ "*** ERROR *** ",2;                                     11415000
   hard:                                                                11420000
   if not interactive then  <<set abort bit?>>                          11425000
      begin                                                             11430000
      tos := getjcw;                                                    11435000
      tos.(0:1) := 1;  <<set abort bit>>                                11440000
      setjcw(*)                                                         11445000
      end;                                                              11450000
   tos _ harderror;                                                     11455000
   go parms;                                                            11460000
                                                                        11465000
   printfilerror:                                                       11470000
   move bline _ "*** FILE ERROR ",2;                                    11475000
   go hard;                                                             11480000
                                                                        11485000
   printwarning:                                                        11490000
   move bline _ "*** WARNING *** ",2;                                   11495000
   tos _ softerror;                                                     11500000
                                                                        11505000
   parms:                                                               11510000
   errornr _ tos;  <<set error flag>>                                   11515000
   if nerror <> m1d then <<numeric param>>                              11520000
      begin                                                             11525000
      tos_ldntoa(nerror,10,bps0);<<conv parm dec>>             <<00595>>11530000
      tos_tos+tos; <<add to length>>                                    11535000
      bps0 _ " "; <<add blank if string param>>                         11540000
      assemble(inca);                                                   11545000
      end;                                                              11550000
   xreg := serror1.(12:4);  <<nr. char's>>                     <<00595>>11555000
   if <> then  <<string parameter?>>                                    11560000
      begin                                                             11565000
      tos := @serror1;                                         <<00595>>11570000
      assemble(inca,ldxa);                                              11575000
      move * := *,(tos),2;  <<insert string>>                           11580000
      end;                                                              11585000
   xreg := serror2.(12:4);                                     <<00595>>11590000
   if <> then                                                  <<00595>>11595000
      begin                                                    <<00595>>11600000
      bps0 := ",";                                             <<00595>>11605000
      tos := tos+1;                                            <<00595>>11610000
      tos := @serror2;                                         <<00595>>11615000
      assemble(inca,ldxa);                                     <<00595>>11620000
      move * := *,(tos),2;  <<insert string>>                  <<00595>>11625000
      end;                                                     <<00595>>11630000
   print(line,@bline-s0,0);  <<print string and parameters>>            11635000
   print(line,-message(error,bline),0);  <<print error message>>        11640000
   clearline                                                            11645000
   end;                                                                 11650000
$page "GENERAL PURPOSE PROCEDURES  -  PRINTBITMAP"             <<00595>>11655000
$ control segment = seg4                                       <<00595>>11660000
procedure printbitmap( map);                                   <<00595>>11665000
   array map;                                                  <<00595>>11670000
begin                                                          <<00595>>11675000
   integer col := 0, i;                                        <<00595>>11680000
                                                               <<00595>>11685000
   for *i := 0 until %77 do                                    <<00595>>11690000
      begin                                                    <<00595>>11695000
      if col > 60 then                                         <<00595>>11700000
         begin                                                 <<00595>>11705000
         print(line,-col,0);                                   <<00595>>11710000
         col := 0;                                             <<00595>>11715000
         end;                                                  <<00595>>11720000
      if testbit( map, i) then                                 <<00595>>11725000
         begin                                                 <<00595>>11730000
         if col <> 0 then                                      <<00595>>11735000
            begin                                              <<00595>>11740000
            bline(col) := ",";                                 <<00595>>11745000
            col:=col+1;                                        <<00595>>11750000
            end;                                               <<00595>>11755000
         col := col+lntoa(i+1,10,bline(col));                  <<00595>>11760000
         end;                                                  <<00595>>11765000
      end;                                                     <<00595>>11770000
   if col <> 0 then print(line,-col,0);                        <<00595>>11775000
   clearline;                                                  <<00595>>11780000
end;                                                           <<00595>>11785000
$page "GENERAL PURPOSE PROCEDURES  -  MESSAGE"                 <<00595>>11790000
$ control segment = seg4                                                11795000
integer procedure message (nr,buf);                                     11800000
   <<this procedure composes the message identified by nr               11805000
     (0 <= nr <= 254) and inserts the message in the buffer buf,        11810000
     returning the number of characters in the message.  if a message   11815000
     does not exist, a zero length is returned>>                        11820000
   value nr;                                                            11825000
   integer nr;                                                          11830000
   byte array buf;                                                      11835000
   begin                                                                11840000
   byte array vocab(*) = pb :=                                 <<02817>>11845000
      <<%0>> 3,"USL",                                                   11850000
      <<%1>> 2,"SL",                                                    11855000
      <<%2>> 2,"RL",                                                    11860000
      <<%3>> 7,"PROGRAM",                                               11865000
      <<%4>> 4,"FILE",                                                  11870000
      <<%5>> 7,"SEGMENT",                                               11875000
      <<%6>> 4,"UNIT",                                                  11880000
      <<%7>> 9,"PROCEDURE",                                             11885000
      <<%10>> 9,"DIRECTORY",                                            11890000
      <<%11>> 4,"INFO",                                                 11895000
      <<%12>> 10,"ATTEMPT TO",                                          11900000
      <<%13>> 6,"EXCEED",                                               11905000
      <<%14>> 7,"MAXIMUM",                                              11910000
      <<%15>> 4,"SIZE",                                                 11915000
      <<%16>> 9,"AVAILABLE",                                            11920000
      <<%17>> 5,"SPACE",                                                11925000
      <<%20>> 9,"EXHAUSTED",                                            11930000
      <<%21>> 10,"DESIGNATED",                                          11935000
      <<%22>> 7,"ILLEGAL",                                              11940000
      <<%23>> 13,"SPECIFICATION",                                       11945000
      <<%24>> 9,"UNABLE TO",                                            11950000
      <<%25>> 6,"ACCESS",                                               11955000
      <<%26>> 7,"CONTAIN",                                              11960000
      <<%27>> 7,"PRIMARY",                                              11965000
      <<%30>> 5,"OUTER",                                                11970000
      <<%31>> 5,"POINT",                                                11975000
      <<%32>> 15,"ALREADY DEFINED",                                     11980000
      <<%33>> 2,"NO",                                                   11985000
      <<%34>> 10,"OTHER THAN",                                          11990000
      <<%35>> 6,"ACTIVE",                                               11995000
      <<%36>> 4,"OPEN",                                                 12000000
      <<%37>> 7,"STORAGE",                                              12005000
      <<%40>> 7,"REQUIRE",                                              12010000
      <<%41>> 5,"FATAL",                                                12015000
      <<%42>> 6,"ACTUAL",                                               12020000
      <<%43>> 6,"FORMAL",                                               12025000
      <<%44>> 9,"PARAMETER",                                            12030000
      <<%45>> 12,"INCOMPATIBLE",                                        12035000
      <<%46>> 5,"CLASS",                                                12040000
      <<%47>> 4,"WITH",                                                 12045000
      <<%50>> 6,"USABLE",                                               12050000
      <<%51>> 10,"PRIVILEGED",                                          12055000
      <<%52>> 4,"DATA",                                                 12060000
      <<%53>> 4,"CODE",                                                 12065000
      <<%54>> 3,"STT",                                                  12070000
      <<%55>> 13,"MORE THAN ONE",                                       12075000
      <<%56>> 2,"IS",                                                   12080000
      <<%57>> 3,"HAS",                                                  12085000
      <<%60>> 8,"EXTERNAL",                                             12090000
      <<%61>> 8,"VARIABLE",                                             12095000
      <<%62>> 6,"GLOBAL",                                               12100000
      <<%63>> 3,"NOT",                                                  12105000
      <<%64>> 8,"DECLARED",                                             12110000
      <<%65>> 6,"LOCATE",                                               12115000
      <<%66>> 6,"COMMON",                                               12120000
      <<%67>> 5,"LABEL",                                                12125000
      <<%70>> 9,"DIFFERENT",                                            12130000
      <<%71>> 3,"USE",                                                  12135000
      <<%72>> 5,"BLOCK",                                                12140000
      <<%73>> 12,"NON-EXISTENT",                                        12145000
      <<%74>> 12,"INSUFFICIENT",                                        12150000
      <<%75>> 7,"SCRATCH",                                              12155000
      <<%76>> 4,"ITEM",                                                 12160000
      <<%77>> 7,"COMMAND",                                              12165000
      <<%100>> 12,"INAPPLICABLE",                                       12170000
      <<%101>> 8,"OVERFLOW",                                            12175000
      <<%102>> 2,"ON",                                                  12180000
      <<%103>> 8,"TOO MANY",                                            12185000
      <<%104>> 5,"ENTRY",                                               12190000
      <<%105>> 6,"HEADER",                                              12195000
      <<%106>> 5,"PATCH",                                               12200000
      <<%107>> 4,"TYPE",                                                12205000
      <<%110>> 4,"LIST",                                                12210000
      <<%111>> 10,"UNEXPECTED",                                         12215000
      <<%112>> 3,"I/O",                                                 12220000
      <<%113>> 4,"FROM",                                                12225000
      <<%114>> 5,"CLOSE",                                               12230000
      <<%115>> 5,"ERROR",                                               12235000
      <<%116>> 9,"NON-FATAL",                                           12240000
      <<%117>> 2,"TO",                                                  12245000
      <<%120>> 7,"PREPARE",                                             12250000
      <<%121>> 4,"AUX.",                                                12255000
      <<%122>> 7,"LIBRARY",                                             12260000
      <<%123>> 6,"EXTENT",                                              12265000
      <<%124>> 4,"USED",                                                12270000
      <<%125>> 10,"CAPABILITY",                                         12275000
      <<%126>> 7,"INVALID",                                             12280000
      <<%127>> 9,"CURRENTLY",                                           12285000
      <<%130>> 6,"LOADED",                                              12290000
      <<%131>> 4,"MODE",                                                12295000
      <<%132>> 6,"MAY BE",                                              12300000
      <<%133>> 9,"TOO LARGE",                                           12305000
      <<%134>> 7, "LOGICAL",                                            12310000
      <<%135>> 5,"STACK",                                               12315000
      <<%136>> 2,"DL",                                                  12320000
      <<%137>> 7,"MAXDATA",                                    <<00.eb>>12325000
      <<%140>> 6,"FREEZE",                                     <<00207>>12330000
      <<%141>> 3,"NEW",                                        <<00207>>12335000
      <<%142>> 3,"OLD",                                        <<00465>>12340000
      <<%143>> 2,"IN",                                         <<00207>>12345000
      <<%144>> 5,"WRONG",                                      <<00207>>12350000
      <<%145>> 11,"END OF FILE",                               <<00207>>12355000
      <<%146>> 4,"COPY",                                       <<00207>>12360000
      <<%147>> 6,"FACTOR",                                     <<00207>>12365000
      <<%150>> 9,"DUPLICATE",                                  <<00207>>12370000
      <<%151>> 4,"NAME",                                       <<00595>>12375000
      <<%152>> 2,"OF",                                         <<00595>>12380000
      <<%153>> 6,"NUMBER",                                     <<00595>>12385000
      <<%154>> 8,"FUNCTION",                                   <<04102>>12390000
      <<%155>> 5,"DEBUG",                                      <<04102>>12395000
      <<%156>> 8,"SYMBOLIC",                                   <<04584>>12400000
      <<%157>> 2,"SM",                                         <<04584>>12405000
      <<%160>> 8,"INTERNAL",                                   <<04584>>12410000
      <<%161>> 4,"PMAP",                                       <<04781>>12415000
      <<%162>> 9,"PERMANENT",                                  <<04781>>12420000
      <<%163>> 9,"TOO SMALL",                                  <<04781>>12425000
      <<%164>> 2,"DB",                                         <<06293>>12430000
      0;                                                       <<04781>>12435000
   equate access = %25,                                                 12440000
          active' = %35,                                                12445000
          actual = %42,                                                 12450000
          already'defined = %32,                                        12455000
          attempt'to = %12,                                             12460000
          aux = %121,                                                   12465000
          available = %16,                                              12470000
          block = %72,                                                  12475000
          capability = %125,                                            12480000
          class' = %46,                                                 12485000
          close = %114,                                                 12490000
          code = %53,                                                   12495000
          command = %77,                                                12500000
          common = %66,                                                 12505000
          contain = %26,                                                12510000
          contains = %226,                                              12515000
          copy=%146,                                           <<00207>>12520000
          currently = %127,                                             12525000
          data = %52,                                                   12530000
          db' = %164,                                          <<06293>>12535000
          debug = %155,                                        <<04102>>12540000
          declared = %64,                                               12545000
          designated = %21,                                             12550000
          different = %70,                                              12555000
          directory = %10,                                              12560000
          dl = %136,                                                    12565000
          duplicate = %150,                                    <<00207>>12570000
          end'of'file = %145,                                  <<00207>>12575000
          entry'point = %31,                                            12580000
          entry' = %104,                                                12585000
          error = %115,                                                 12590000
          exceed = %13,                                                 12595000
          exceeds = %213,                                               12600000
          exhausted = %20,                                              12605000
          extent = %123,                                                12610000
          external' = %60,                                              12615000
          factor=%147,                                         <<00207>>12620000
          fatal = %41,                                                  12625000
          file = %4,                                                    12630000
          formal = %43,                                                 12635000
          freeze = %140,                                       <<00.eb>>12640000
          from = %113,                                                  12645000
          function = %154,                                     <<00595>>12650000
          global' = %62,                                                12655000
          has = %57,                                                    12660000
          header = %105,                                                12665000
          illegal = %22,                                                12670000
          in = %143,                                           <<00207>>12675000
          inapplicable = %100,                                          12680000
          incompatible = %45,                                           12685000
          info = %11,                                                   12690000
          insufficient = %74,                                           12695000
          invalid = %126,                                               12700000
          internal' = %160,                                    <<04584>>12705000
          io = %112,                                                    12710000
          item = %76,                                                   12715000
          is = %56,                                                     12720000
          label' = %67,                                                 12725000
          labels = %267,                                                12730000
          library = %122,                                               12735000
          list' = %110,                                                 12740000
          loaded = %130,                                                12745000
          locate = %65,                                                 12750000
          logical' = %134,                                              12755000
          maxdata = %137,                                               12760000
          maximum = %14,                                                12765000
          may'be = %132,                                                12770000
          mode = %131,                                                  12775000
          more'than'one = %55,                                          12780000
          name = %151,                                         <<00207>>12785000
          new = %141,                                          <<00207>>12790000
          no = %33,                                                     12795000
          non'existent = %73,                                           12800000
          non'fatal = %116,                                             12805000
          not' = %63,                                                   12810000
          old = %142,                                          <<00465>>12815000
          number = %153,                                       <<00595>>12820000
          of' = %152,                                          <<00595>>12825000
          on = %102,                                                    12830000
          open = %36,                                                   12835000
          other'than = %34,                                             12840000
          outer = %30,                                                  12845000
          overflow' = %101,                                             12850000
          parameter = %44,                                              12855000
          parameters = %244,                                            12860000
          patch = %106,                                                 12865000
          permanent = %162,                                    <<04781>>12870000
          pmap = %161,                                         <<04584>>12875000
          point = %31,                                                  12880000
          points = %231,                                                12885000
          prepare = %120,                                               12890000
          primary = %27,                                                12895000
          privileged' = %51,                                            12900000
          procedure' = %7,                                              12905000
          procedures = %207,                                            12910000
          program = %3,                                                 12915000
          require = %40,                                                12920000
          requires = %240,                                              12925000
          rl = %2,                                                      12930000
          scratch = %75,                                                12935000
          segment' = %5,                                                12940000
          segments = %205,                                              12945000
          size = %15,                                                   12950000
          sl = %1,                                                      12955000
          sm = %157,                                           <<04584>>12960000
          space = %17,                                                  12965000
          specification = %23,                                          12970000
          stack = %135,                                                 12975000
          storage = %37,                                                12980000
          stt = %54,                                                    12985000
          symbolic = %156,                                     <<04102>>12990000
          to' = %117,                                                   12995000
          too'large = %133,                                             13000000
          too'many = %103,                                              13005000
          too'small = %163,                                    <<04781>>13010000
          type = %107,                                                  13015000
          unable'to = %24,                                              13020000
          unexpected = %111,                                            13025000
          unit = %6,                                                    13030000
          units = %206,                                                 13035000
          usable = %50,                                                 13040000
          use = %71,                                                    13045000
          used = %124,                                                  13050000
          usl = %0,                                                     13055000
          variable' = %61,                                              13060000
          with' = %47,                                         <<06170>>13065000
          wrong = %144;                                        <<00207>>13070000
   byte array mess(*) = pb :=                                  <<02817>>13075000
                                                                        13080000
      <<usl file messages>>                                             13085000
                                                                        13090000
      0,2,illegal,entry',                                               13095000
      1,2,illegal,header,                                               13100000
      2,5,attempt'to,exceed,maximum,directory,size,                     13105000
      3,4,available,directory,space,exhausted,                          13110000
      4,4,available,info,space,exhausted,                               13115000
      5,4,usl,file,not',designated,                                     13120000
      6,4,illegal,usl,file,specification,                               13125000
      7,4,unable'to,open,usl,file,                                      13130000
      8,3,invalid,usl,file,                                             13135000
      9,4,unable'to,close,usl,file,                                     13140000
                                                                        13145000
      <<sl file messages>>                                              13150000
                                                                        13155000
      10,4,unable'to,close,sl,file,                                     13160000
      11,4,available,file,space,exhausted,                              13165000
      12,3,entry',point,already'defined,                                13170000
      13,6,segment',contains,program,units,other'than,procedures,       13175000
      14,4,segment',requires,global',storage,                           13180000
      15,2,segment',already'defined,                                    13185000
      16,4,sl,file,not',designated,                                     13190000
      17,4,illegal,sl,file,specification,                               13195000
      18,4,unable'to,open,sl,file,                                      13200000
      19,3,invalid,sl,file,                                             13205000
                                                                        13210000
      <<rl file messages>>                                              13215000
                                                                        13220000
      20,4,illegal,rl,file,specification,                               13225000
      21,4,rl,file,not',designated,                                     13230000
      22,3,invalid,rl,file,                                             13235000
      23,4,unable'to,close,rl,file,                                     13240000
      28,6,procedure',has,no,usable,entry',point,                       13245000
      30,4,unable'to,open,rl,file,                                      13250000
                                                                        13255000
      <<program preparation messages>>                                  13260000
                                                                        13265000
      32,3,invalid,program,file,                                        13270000
      33,3,illegal,capability,specification,                            13275000
      34,3,more'than'one,extent,used,                                   13280000
      35,4,no,program,to',prepare,                                      13285000
      36,4,unable'to,close,program,file,                                13290000
      37,4,unable'to,open,program,file,                                 13295000
      38,3,data,segment',overflow',                                     13300000
      39,3,too'many,code,segments,                                      13305000
                                                                        13310000
      <<segment preparation messages>>                                  13315000
                                                                        13320000
      40,3,code,segment',overflow',                                     13325000
      41,2,stt,overflow',                                               13330000
      42,6,segment',has,no,usable,entry',point,                         13335000
      43,3,unable'to,access,procedure',                                 13340000
      44,4,requires,privileged',mode,capability,                        13345000
      45,6,actual,parameters,incompatible,with',formal,parameters,<<08>>13350000
      46,5,program,unit,contains,fatal,error,                           13355000
      47,5,program,unit,contains,non'fatal,error,                       13360000
      48,4,code,segment',may'be,too'large,                              13365000
      49,6,actual,function,incompatible,with',formal,function, <<06170>>13370000
      50,4,incompatible,number,of',parameters,                 <<00595>>13375000
                                                                        13380000
      <<program preparation messages (cont.)>>                          13385000
                                                                        13390000
      60,5,no,outer,block,is,active',                                   13395000
      61,5,more'than'one,outer,block,is,active',                        13400000
      62,7,more'than'one,outer,block,has,active',entry',points,         13405000
      63,5,external',variable',not',declared,global',                   13410000
      64,6,external',variable',incompatible,with',global',variable',    13415000
      66,4,too'many,common,data,labels,                                 13420000
      67,5,common,declared,with',different,size,                        13425000
      68,7,attempt'to,use,block,data,on,non'existent,common,            13430000
      69,7,attempt'to,use,block,data,on,incompatible,common,            13435000
      70,3,illegal,stack,size,                                          13440000
      71,3,illegal,dl,size,                                             13445000
      72,3,illegal,maxdata,size,                                        13450000
      73,4,duplicate,active',entry',name,                      <<04121>>13455000
      74,5,unable'to,prepare,with',symbolic,debug,             <<06170>>13460000
      75,5,permanent,program,file,size,too'small,              <<04781>>13465000
      76,3,primary,db',overflow',                              <<06293>>13470000
                                                                        13475000
      <<miscellaneous messages>>                                        13480000
                                                                        13485000
      80,2,insufficient,storage,                                        13490000
      81,2,illegal,patch,                                               13495000
      82,4,unable'to,open,scratch,file,                                 13500000
      83,4,unable'to,open,list',file,                                   13505000
      84,3,unexpected,io,error,                                         13510000
      86,5,item,different,from,class',specification,                    13515000
      87,4,item,not',primary,entry'point,                               13520000
      88,3,incompatible,item,type,                                      13525000
      89,3,invalid,class',specification,                                13530000
      93,3,unable'to,locate,item,                                       13535000
      94,2,unexpected,end'of'file,                             <<00207>>13540000
      95,3,invalid,copy,factor,                                <<00207>>13545000
      96,3,illegal,file,access,                                <<00563>>13550000
      97,4,unable'to,close,scratch,file,                       <<04102>>13555000
      98,6,no,internal',pmap,in,program,file,                  <<04584>>13560000
      99,3,require,sm,capability,                              <<04584>>13565000
                                                                        13570000
      <<sl file messages (cont.)>>                                      13575000
                                                                        13580000
      110,3,segment',currently,loaded,                                  13585000
      111,4,segment',contains,external',variable',                      13590000
      112,3,segment',contains,common,                                   13595000
      113,4,segment',contains,logical',units,                           13600000
      114,3,unable'to,freeze,segment',                         <<00.eb>>13605000
                                                                        13610000
      <<auxiliary usl file messages>>                                   13615000
                                                                        13620000
      120,5,aux,usl,file,not',designated,                               13625000
      121,5,unable'to,open,new,usl,file,                       <<00207>>13630000
      122,3,duplicate,file,name,                               <<00207>>13635000
                                                                        13640000
      <<miscellaneous strings>>                                         13645000
                                                                        13650000
      200,2,usl,file,                                                   13655000
      201,3,aux,usl,file,                                               13660000
      202,2,sl,file,                                                    13665000
      203,2,rl,file,                                                    13670000
      204,3,rl,library,file,                                            13675000
      205,2,program,file,                                               13680000
      206,2,list',file,                                                 13685000
      207,2,scratch,file,                                               13690000
      208,3,old,sl,file,                                       <<00465>>13695000
      209,3,new,usl,file,                                      <<00207>>13700000
                                                                        13705000
      255;  <<table terminator>>                                        13710000
   byte array test (0:8);  <<message buffer>>                           13715000
   byte pointer phrase;                                                 13720000
   tos _ @test; tos _ @mess;                                            13725000
   l1: move * _ * pb,(2),1;  <<load message nr. and nr. phrases>>       13730000
   if integer(test) = 255 or integer(test) > nr then return;            13735000
   if <> then  <<correct message?>>                                     13740000
      begin                                                             13745000
      assemble(decb,decb);                                              13750000
      tos _ tos+test(1);                                                13755000
      go l1                                                             13760000
      end;                                                              13765000
   @phrase _ s1;  <<save pointer to phrase nr.>>                        13770000
   move * _ * pb,(integer(test(1)));  <<load remainder of message>>     13775000
   tos_@buf; <<load beg. of buff>>                                      13780000
   if nr < 200 then <<kluge. no nr for misc msg>>                       13785000
   begin                                                                13790000
      move buf_"ERROR #    ";                                           13795000
      tos_ascii(nr,10,buf(7));<<put msg nr>>                            13800000
      tos_tos+tos+8; <<ptr 1 past msg nr>>                              13805000
   end;                                                                 13810000
   do begin                                                             13815000
      tos _ @test; tos _ @vocab;                                        13820000
      xreg _ phrase.(9:7);                                              13825000
      while > do                                                        13830000
         begin                                                          13835000
         move * _ * pb,(1),1;  <<load nr. bytes in phrase>>             13840000
         tos _ tos+test;                                                13845000
         assemble(decb,decx)                                            13850000
         end;                                                           13855000
      move * _ * pb,(1),1;  <<load nr. bytes in phrase>>                13860000
      assemble(delb);  <<leave pointer to phrase>>                      13865000
      move * _ * pb,(integer(test)),2;  <<put phrase in buffer>>        13870000
      if logical(phrase.(8:1)) then  <<append "S"?>>                    13875000
         begin                                                          13880000
         bps0 _ "S";                                                    13885000
         tos _ tos+1                                                    13890000
         end;                                                           13895000
      bps0 _ " ";  <<append " ">>                                       13900000
      tos _ tos+1;                                                      13905000
      @phrase _ @phrase+1;  <<next phrase nr.>>                         13910000
      test(1) _ test(1)-1  <<dec. nr. phrases>>                         13915000
      end until =;                                                      13920000
   message _ tos-@buf-1  <<nr. bytes in message>>                       13925000
   end;                                                                 13930000
$page "GENERAL PURPOSE PROCEDURES  -  CTLY'TRAP"               <<00207>>13935000
$ control segment = seg4                                       <<00.dm>>13940000
procedure ctly'trap;                                           <<00.dm>>13945000
   begin                                                       <<00.dm>>13950000
   integer sdec, i;                                            <<00.dm>>13955000
                                                               <<00.dm>>13960000
   blankline;                                                  <<00.dm>>13965000
   printline;                                                  <<00.dm>>13970000
   resetcontrol;                                               <<00.dm>>13975000
   fcontrol(infnum,disable'ctly,i);                            <<00.dm>>13980000
   ctly := true;                                               <<00.dm>>13985000
   tos := %31400+sdec;                                         <<00.dm>>13990000
   assemble( xeq 0 );                                          <<00.dm>>13995000
   end;                                                        <<00.dm>>14000000
$page "GENERAL PURPOSE PROCEDURES  -  GETRECDDISP"             <<00207>>14005000
$ control segment = seg3                                                14010000
procedure getrecddisp (fileadr,recd,disp);                              14015000
   <<returns the record number and record displacement for the          14020000
     given file address.  the record number may be positive or          14025000
     negative but is adjusted so that the record displacement is        14030000
     always non-negative>>                                              14035000
   value fileadr;                                                       14040000
   double fileadr; integer recd,disp;                                   14045000
   begin                                                                14050000
   tos _ fileadr; tos _ recsize;                                        14055000
   assemble(divl);                                                      14060000
   disp _ tos; recd _ tos;                                              14065000
   if disp < 0 then                                                     14070000
      begin                                                             14075000
      recd _ recd-1; disp _ disp+recsize                                14080000
      end                                                               14085000
   end;                                                                 14090000
$page "GENERAL PURPOSE PROCEDURES  -  REPAIRRECORD"            <<00207>>14095000
$ control segment = seg3                                                14100000
procedure repairrecord (fnum,fileadr,newword);                          14105000
   value fnum,fileadr,newword;                                          14110000
   integer fnum,newword; double fileadr;                                14115000
   begin                                                                14120000
   integer recd,disp;                                                   14125000
   getrecddisp(fileadr,recd,disp);                                      14130000
   repairrecord'(fnum,recd,disp,newword)                                14135000
   end;                                                                 14140000
$page "GENERAL PURPOSE PROCEDURES  -  REPAIRRECORD'"           <<00207>>14145000
$ control segment = seg3                                                14150000
procedure repairrecord' (fnum,recd,disp,newword);                       14155000
   value fnum,recd,disp,newword;                                        14160000
   integer fnum,recd,disp,newword;                                      14165000
   begin                                                                14170000
   freaddir'(fnum,buf,recd);                                            14175000
   buf(disp) _ newword;  <<repair word>>                                14180000
   fwritedir'(fnum,buf,recd)                                            14185000
   end;                                                                 14190000
$page "GENERAL PURPOSE PROCEDURES  -  COREBUF1"                <<00207>>14195000
$ control segment = seg3                                                14200000
procedure corebuf1 (buffer,length);                                     14205000
   value length;                                                        14210000
   integer array buffer;                                                14215000
   integer length;                                                      14220000
   begin                                                                14225000
   entry corebuf2;                                                      14230000
   tos _ tfnum1; tos _ 0; tos _ @tbuf1; tos _ @trecd1; tos _ @tdisp1;   14235000
   go l1;                                                               14240000
                                                                        14245000
   corebuf2:                                                            14250000
   tos _ tfnum1; tos _ 0; tos _ @tbuf2; tos _ @trecd2; tos _ @tdisp2;   14255000
                                                                        14260000
   l1:                                                                  14265000
   masterbuf(*,*,*,*,*,false,0d,buffer,length)                          14270000
   end;                                                                 14275000
$page "GENERAL-PURPOSE PROCEDURES  -  COREBUFPMAP"             <<04102>>14280000
$control segment = seg3                                        <<04102>>14285000
procedure corebufpmap(buffer, length);                         <<04102>>14290000
   value length;                                               <<04102>>14295000
   integer array buffer;          << buffer to be written >>   <<04102>>14300000
   integer       length;          << # words in buffer >>      <<04102>>14305000
                                                               <<04102>>14310000
   << writes buffer to the pmap scratch file starting at dis-  <<04102>>14315000
   << placement pmapbufdisp in record pmaprecnr.  the record   <<04102>>14320000
   << and displacement values will be updated upon return.     <<04102>>14325000
   << note that a priming read of pmapbuf may be necessary     <<04102>>14330000
   << prior to the first call.                                 <<04102>>14335000
                                                               <<04102>>14340000
   begin << corebufpmap >>                                     <<04102>>14345000
                                                               <<04102>>14350000
      masterbuf(pmapfilenr, 0, pmapbuf, pmaprecnr, pmapbufdisp,<<04102>>14355000
                false, 0d, buffer, length);                    <<04102>>14360000
                                                               <<04102>>14365000
   end; << corebufpmap >>                                      <<04102>>14370000
$page "GENERAL-PURPOSE PROCEDURES  -  COREBUFSI"               <<04102>>14375000
$control segment = seg3                                        <<04102>>14380000
procedure corebufsi(buffer, length);                           <<04102>>14385000
   value length;                                               <<04102>>14390000
   integer array buffer;          << buffer to be written >>   <<04102>>14395000
   integer       length;          << # words in buffer >>      <<04102>>14400000
                                                               <<04102>>14405000
   << writes buffer to the toolbox symbol item (si) header     <<04102>>14410000
   << scratch file starting at displacement sibufdisp in rec-  <<04102>>14415000
   << ord sirecnr.  the record and displacement values will    <<04102>>14420000
   << be updated upon return.  note that a priming read of     <<04102>>14425000
   << sibuf may be necessary prior to the first call.          <<04102>>14430000
                                                               <<04102>>14435000
   begin << corebufsi >>                                       <<04102>>14440000
                                                               <<04102>>14445000
      masterbuf(sifilenr, 0, sibuf, sirecnr, sibufdisp,        <<04102>>14450000
                false, 0d, buffer, length);                    <<04102>>14455000
                                                               <<04102>>14460000
   end; << corebufsi >>                                        <<04102>>14465000
$ control segment = seg3                                                14470000
   procedure masterbufd (tfnum,sfnum,tbuf,trecd,tdisp,         <<04102>>14475000
                     flag,adr,buffer,length);                           14480000
   <<moves the specified buffer into the file record buffer and then    14485000
     into the file.  if flag is set, the buffer is disc resident        14490000
     and it's file address is given by adr; otherwise the buffer is     14495000
     core resident and is given by buffer>>                             14500000
   value tfnum,sfnum,flag,adr,length;                                   14505000
   integer tfnum,sfnum,trecd,tdisp;  double length;            <<04102>>14510000
   integer array tbuf,buffer; double adr; logical flag;                 14515000
   begin                                                                14520000
   integer i,srecd,sdisp _ 0;                                           14525000
   integer len=length+1;                                       <<04102>>14530000
   if flag then  <<disc resident buffer?>>                              14535000
      begin                                                             14540000
      getrecddisp(adr,srecd,sdisp);                                     14545000
      @buffer _ @buf;  <<use utility buffer>>                           14550000
      freaddir'(sfnum,buffer,srecd)  <<read first source recd>>         14555000
      end;                                                              14560000
   while length > 0d do  <<fill target or empty source>>       <<04102>>14565000
      begin                                                             14570000
      if flag then i:=min2(128-tdisp,128-sdisp)                <<04102>>14575000
              else i:=128-tdisp;                               <<04102>>14580000
      if length < %(2)111111111111111d then                    <<04102>>14585000
         i:=min2(len,i);                                       <<04102>>14590000
      move tbuf(tdisp) _ buffer(sdisp),(i);                             14595000
      length:=length-double(i);                                <<04102>>14600000
      tos _ sdisp+i;                                                    14605000
      if flag then tos _ tos.(9:7);                                     14610000
      sdisp _ tos;                                                      14615000
      tdisp _ (tdisp+i).(9:7);                                          14620000
      if tdisp = 0 then  <<target full?>>                               14625000
         begin                                                          14630000
         fwritedir'(tfnum,tbuf,trecd);  <<write target record>>         14635000
         trecd _ trecd+1;                                               14640000
         if not flag and length >= 128d then                   <<04102>>14645000
            begin                                                       14650000
            i:=len.(9:7);                                      <<04102>>14655000
            length:=length-double(i);                          <<04102>>14660000
            fwritemr'(tfnum,buffer(sdisp),len,trecd);          <<04102>>14665000
            trecd:=trecd+len.(0:9);                            <<04102>>14670000
         if feof(tfnum) > trecd then  <<prime buffer?>>                 14675000
                 freaddir'(tfnum,tbuf,trecd);                           14680000
            move tbuf:=buffer(sdisp+len),(i),2;                <<04102>>14685000
            tdisp _ tos-@tbuf;                                          14690000
            return                                                      14695000
            end;                                                        14700000
         if length<128d and feof(tfnum) > trecd then           <<04102>>14705000
            freaddir'(tfnum,tbuf,trecd);                                14710000
         end;                                                           14715000
      if flag and (sdisp = 0) and (length <> 0d) then          <<04102>>14720000
         freaddir'(sfnum,buffer,(srecd _ srecd+1))  <<next source>>     14725000
      end                                                               14730000
   end;                                                                 14735000
$page "GENERAL PURPOSE PROCEDURE - MASTERBUF"                           14740000
$control segment=seg3                                                   14745000
procedure masterbuf (tfnum,sfnum,tbuf,trecd,tdisp,             <<04102>>14750000
                     flag,adr,buffer,length);                  <<04102>>14755000
<<interface to masterbufd>>                                    <<04102>>14760000
value tfnum,sfnum,flag,adr,length;                             <<04102>>14765000
integer tfnum,sfnum,trecd,tdisp,length;                        <<04102>>14770000
integer array tbuf,buffer;                                     <<04102>>14775000
double adr;                                                    <<04102>>14780000
logical flag;                                                  <<04102>>14785000
                                                               <<04102>>14790000
begin                                                          <<04102>>14795000
   masterbufd(tfnum,sfnum,tbuf,trecd,tdisp,                    <<04102>>14800000
              flag,adr,buffer,double(length));                 <<04102>>14805000
end;                                                           <<04102>>14810000
$ control segment = seg3                                                14815000
procedure bufferdatabytes (dbadr,buf,length,times);                     14820000
   <<generalized buffering procedure for initializing the data segment  14825000
     image in the program file.  the byte buffer is assumed to be       14830000
     core resident and to be length bytes long.  this initialization    14835000
     block is to begin at dbadr (byte address) and is to be repeated    14840000
     times times>>                                                      14845000
   value dbadr,length,times;                                            14850000
   logical dbadr,length;                                                14855000
   byte array buf;                                                      14860000
   integer times;                                                       14865000
   begin                                                                14870000
                                                                        14875000
   subroutine savebuffer (nextrecd);                                    14880000
      <<saves the contents of the data buffer and initializes it with   14885000
        the next record.  note that this subroutine must not alter the  14890000
        x register>>                                                    14895000
      value nextrecd;                                                   14900000
      integer nextrecd;                                                 14905000
      begin                                                             14910000
      tos _ xreg;  <<save x register>>                                  14915000
      if s2 <> trecd2 then  <<different record?>>                       14920000
         begin                                                          14925000
         if trecd2 <> 0 then  <<non-empty buffer?>>                     14930000
            begin                                                       14935000
            fwritedir'(progfnum,tbuf2,trecd2);                          14940000
            setbit(dirtydata,trecd2-psag)                               14945000
            end;                                                        14950000
         if testbit(dirtydata,s2-psag) then  <<re-read record?>>        14955000
            freaddir'(progfnum,tbuf2,s2)                                14960000
         else if zerodb then  <<init. buffer to zero?>>                 14965000
            begin                                                       14970000
            tos _ @tbuf2; ps0 _ 0;                                      14975000
            assemble(dup,incb); tos _ 127; assemble(move 3)             14980000
            end                                                         14985000
         end;                                                           14990000
      trecd2 _ s2;  <<save rec. nr.>>                                   14995000
      xreg _ tos  <<restore x register>>                                15000000
      end;                                                              15005000
                                                                        15010000
   tos _ double(dbadr)&dlsl(8);                                         15015000
   tdisp2 _ tos&lsr(8);                                                 15020000
   savebuffer(tos+psag);  <<init. buffer>>                              15025000
   tos _ times;                                                         15030000
   if > then                                <<valid times?>>   <<c0.06>>15035000
   do begin                                                             15040000
      tos _ @buf;  <<source byte adr.>>                                 15045000
      tos _ length;  <<nr. bytes>>                                      15050000
      while <> do                                                       15055000
         begin                                                          15060000
         tos _ @tbuf2&lsl(1)+tdisp2;  <<target byte adr.>>              15065000
         tos _ @bps2;  <<source byte adr.>>                             15070000
         tos _ min2(s2,p256-tdisp2);  <<nr. bytes moved>>               15075000
         xreg _ s0;  <<save copy in xreg>>                              15080000
         move * _ *,(tos),1;                                            15085000
         @bps3 _ tos;  <<update source byte adr.>>                      15090000
         assemble(del,ldxa);                                            15095000
         tdisp2 _ (tos+tdisp2).(8:8);  <<update target disp.>>          15100000
         if = then savebuffer(trecd2+1);  <<target buffer full?>>       15105000
         tos _ logical(tos)-logical(xreg)  <<update nr. bytes>>         15110000
         end;                                                           15115000
      assemble(ddel,deca)                                               15120000
      end until =;                                                      15125000
   tos _ tdisp2;                                                        15130000
   if = and not testbit(dirtydata,trecd2-psag) then  <<valid buffer?>>  15135000
      trecd2 _ tos  <<mark buffer empty>>                               15140000
   end;                                                                 15145000
$page "GENERAL PURPOSE PROCEDURES  -  BUFFERDATAWORDS"         <<00207>>15150000
$ control segment = seg3                                                15155000
procedure bufferdatawords (dbadr,buf,length,times);                     15160000
   <<same as bufferdatabytes except manipulates word buffers>>          15165000
   value dbadr,length,times;                                            15170000
   logical dbadr,length;                                                15175000
   integer array buf;                                                   15180000
   integer times;                                                       15185000
   begin                                                                15190000
   tos _ dbadr&lsl(1);                                                  15195000
   tos _ @buf&lsl(1);                                                   15200000
   tos _ length&lsl(1);                                                 15205000
   bufferdatabytes(*,*,*,times)                                         15210000
   end;                                                                 15215000
$page "GENERAL PURPOSE PROCEDURES  -  HASH"                    <<00207>>15220000
$ control segment = seg3                                                15225000
integer procedure hash (name);                                          15230000
   <<evaluates the hash code of an identifier.  assumes that the        15235000
     identifier is a string of bytes and that the lower four bits       15240000
     of the first byte is the number of characters in the               15245000
     identifier>>                                                       15250000
   byte array name;                                                     15255000
   begin                                                                15260000
   tos _ name&csl(8)+name(1);  <<nc and first char>>                    15265000
   tos _ tos.(4:12);  <<clear flag bits from nc>>                       15270000
   xreg _ name.(12:4)-1;  <<nc - 1>>                                    15275000
   tos _ name(xreg)&csl(8);  <<second to last char>>                    15280000
   xreg _ xreg+1;                                                       15285000
   tos _ name(xreg);                                                    15290000
   assemble(add,decx);                                                  15295000
   if = then tos _ tos.(4:12);  <<clear flag bits if nc = 1>>           15300000
   tos _ 95;                                                            15305000
   assemble(ldiv,delb);                                                 15310000
   hash _ tos                                                           15315000
   end;                                                                 15320000
$page "DL AREA TABLE MAINTAINENCE PROCEDURES   -  MAKEROOMINDL"<<00207>>15325000
<<----------------------------------------------------------------------15330000
*                                                                      *15335000
*  dl area table maintainence procedures                               *15340000
*                                                                      *15345000
---------------------------------------------------------------------->>15350000
                                                                        15355000
$ control segment = seg3                                                15360000
procedure makeroomindl (nrwords);                                       15365000
   <<checks the available space in the dl area to see if there is room  15370000
     for nrwords.  if there is not enough room the dl area is expanded, 15375000
     the tables in area 2 are moved, and the pointers into area 2 are   15380000
     updated.  if there is still not enough room, a dl overflow message 15385000
     is printed.  note that this procedure uses the condition code to   15390000
     indicate an error>>                                                15395000
   value nrwords;                                                       15400000
   integer nrwords;                                                     15405000
   begin                                                                15410000
   integer nwavail = q+1;                                               15415000
   tos _ @dlarea1-@dlavail;  <<nr. words available>>                    15420000
   if nrwords > nwavail then  <<not enough room?>>                      15425000
      begin                                                             15430000
                                                                        15435000
      <<* * * expand dl area * * *>>                                    15440000
                                                                        15445000
      tos _ 0;  <<for result of dlsize>>                                15450000
      tos _ @dlarea2;                                                   15455000
      tos _ dlincrement;  <<init. increment>>                           15460000
      while nrwords > s0+nwavail do tos _ tos+dlincrement;              15465000
      tos _ tos-tos;  <<new dl limit>>                                  15470000
      tos _ dlsize(*);  <<expand dl area>>                              15475000
                                                                        15480000
      <<* * * move tables and fix pointers in area 2 * * *>>            15485000
                                                                        15490000
      move ps0 _ dlarea2,(@dlavail-@dlarea2);  <<move tables>>          15495000
      tos _ tos-@dlarea2;  <<pointer fix term>>                         15500000
      @ptable _ @ptable+s0;                                             15505000
      @patchp _ @patchp+s0;                                             15510000
      @logicalunits _ @logicalunits+s0;                                 15515000
      @prog0 _ @prog0+s0;                                               15520000
      @pmap _ @pmap+s0+s0;                                              15525000
      @pdescrip _ @pdescrip+s0;                                         15530000
      @common _ @common+s0;                                             15535000
      @comtab := @comtab+s0;                                            15540000
      @comp _ @comp+s0;                                                 15545000
      if not rlibequalrl then                                           15550000
         begin                                                          15555000
         @rlibrec0 _ @rlibrec0+s0;                                      15560000
         @rlibdir _ @rlibdir+s0;                                        15565000
         @rlibp _ @rlibp+s0;                                            15570000
         @rlibp1 _ @rlibp1+s0;                                          15575000
         end;                                                           15580000
      @rltable _ @rltable+s0;                                           15585000
      @rlentp _ @rlentp+s0;                                             15590000
      @pustbuf _ @pustbuf+s0;                                           15595000
      @dlarea2 _ @dlarea2+s0;                                           15600000
      @dlavail _ tos+@dlavail;                                          15605000
      if nrwords > @dlarea1-@dlavail then  <<still no room?>>           15610000
         begin                                                          15615000
         error(80);                                                     15620000
         go nfg                                                         15625000
         end                                                            15630000
      end;                                                              15635000
   tos _ cce;  <<ok condition code>>                                    15640000
   go getout;                                                           15645000
                                                                        15650000
   nfg:                                                                 15655000
   tos _ ccl;  <<error condition code>>                                 15660000
                                                                        15665000
   getout:                                                              15670000
   condcode _ tos  <<store condition code>>                             15675000
   end;                                                                 15680000
$page "USL FILE MAINTAINENCE PROCEDURES   -   OPENUSL"         <<00207>>15685000
<<----------------------------------------------------------------------15690000
*                                                                      *15695000
*  usl file maintainence procedures                                    *15700000
*                                                                      *15705000
---------------------------------------------------------------------->>15710000
                                                                        15715000
$ control segment = seg13                                               15720000
procedure openusl (newfile);                                            15725000
   <<preserves any information in core that may be destroyed by         15730000
     loading the usl, then loads the usl and initializes the            15735000
     necessary global parameters.  if newfile is set, record 0          15740000
     is initialized according to the parameters in the command          15745000
     buffer; otherwise record 0 is loaded and the directory is          15750000
     loaded, if possible>>                                              15755000
   value newfile; logical newfile;                                      15760000
   begin                                                                15765000
   integer savedlarea1;                                        <<00563>>15770000
   integer aoptions;     <<passed to fopen>>                   <<00563>>15775000
   integer realaoptions; <<from fgetinfo>>                     <<00563>>15780000
   integer flag := 0;    <<dl buffers just allocated?>>        <<00563>>15785000
                                                                        15790000
   <<* * * initialize local variables * * *>>                           15795000
                                                                        15800000
   savedlarea1 := @dlarea1;  <<save dl area 1 limit>>          <<00563>>15805000
                                                                        15810000
   <<* * * allocate dl buffers * * *>>                                  15815000
                                                                        15820000
   if not uslbufalloc then  <<buffers allocated?>>                      15825000
      begin                                                             15830000
      makeroomindl(usldlbufs);  <<request space>>                       15835000
      if < then go nfg;  <<error?>>                                     15840000
      @uslrec0 _ @dlarea1-128;                                          15845000
      @head _ @uslrec0-maxhead;                                         15850000
      @dir _ @head-maxdir;                                              15855000
      @dlarea1 := @dir;  <<new dl area 1 limit>>                        15860000
      uslbufalloc := true;  <<set flag>>                                15865000
      flag := flag+1  <<set flag>>                                      15870000
      end;                                                              15875000
                                                                        15880000
   <<* * * preserve overlayable information * * *>>                     15885000
                                                                        15890000
   closeusl;                                                            15895000
   if < then go nfg;  <<error?>>                                        15900000
                                                                        15905000
   <<* * * load new usl information * * *>>                             15910000
                                                                        15915000
   if newfile then  <<init. record 0?>>                                 15920000
      begin                                                             15925000
      if not (minusl <= filesize <= maxusl) then                        15930000
         begin                                                          15935000
         error(6);                                                      15940000
         go nfg                                                         15945000
         end;                                                           15950000
      uslfnum _ fopen(bfilename,%(2)10000000000,%(2)101010100,,,,,,,    15955000
         double(logical(filesize)),nrextents,,uslfilecode);             15960000
      if < then  <<error?>>                                             15965000
         begin                                                          15970000
         fopenerror:                                                    15975000
         tos _ 7;                                                       15980000
         tos _ 0d; fcheck(0,s0);  <<file sys. error nr.>>               15985000
         errorn(*,*);                                                   15990000
         go nfg                                                         15995000
         end;                                                           16000000
      uslstate.(1:9) := %(2)011010010;  <<init. state word>>   <<00660>>16005000
      tos _ @uslrec0; ps0 _ 0;                                          16010000
      assemble(dup,incb); tos _ 127; assemble(move 3);                  16015000
      usllid := uslfileid;  <<version nr.>>                             16020000
      uslfl _ double(logical(filesize))&dlsl(7);  <<file length>>       16025000
      uslsaad _ 128;  <<s.a. dir. avail. block>>                        16030000
      tos _ (logical(filesize)+3)&lsr(3);                               16035000
      if s0 > 255 then tos _ 255;  <<max. dir. size>>                   16040000
      usladl _ tos&lsl(7);  <<dir. avail. block length>>                16045000
      uslsai _ double(usladl)+p128d;  <<s.a. info block>>               16050000
      uslsaai _ uslsai;  <<s.a. info avail. block>>                     16055000
      uslail := uslfl-uslsai;  <<info avail. block length>>             16060000
      diradr := 128;                                                    16065000
      infoadr := 0d                                                     16070000
      end                                                               16075000
   else  <<read record 0 and directory>>                                16080000
      begin                                                             16085000
      tos_0;  <<result of fopen>>                                       16090000
      tos _ @bfilename;                                                 16095000
      tos _ %(2)10000000011; <<foptions>>                               16100000
      aoptions := if logical(statechanged) then                <<00665>>16105000
         %(2)110010000   <<aoptions for auxusl>>               <<00665>>16110000
      else                                                     <<00665>>16115000
         %(2)101010100;  <<aoptions for usl>>                  <<00665>>16120000
      uslfnum := fopen(*,*,aoptions);                          <<00563>>16125000
      if < then go fopenerror;  <<error?>>                              16130000
      tos := 0d;                         <<eof>>               <<c+.06>>16135000
      tos _ 0;                                                          16140000
      fgetinfo (uslfnum,,,realaoptions,,,,,s0,,ds2);           <<00563>>16145000
      if realaoptions.(7:9) <> aoptions then                   <<00563>>16150000
         begin                                                 <<00563>>16155000
         error(96);                                            <<00563>>16160000
         closeusl;                                             <<00563>>16165000
         go nfg;                                               <<00563>>16170000
         end;                                                  <<00563>>16175000
      if tos <> uslfilecode then                               <<c+.06>>16180000
      begin                                                    <<c+.06>>16185000
          ddel;                                                <<c+.06>>16190000
          go to uslerr;                                        <<c+.06>>16195000
      end;                                                     <<c+.06>>16200000
      if tos = 0d then                   <<uninitialized usl?>><<c+.06>>16205000
      begin                                                    <<c+.06>>16210000
          inituslf (uslfnum,uslrec0);                          <<c+.06>>16215000
          if < then go to uslerr;        <<failed?>>           <<c+.06>>16220000
          diradr := 128;                                       <<c+.06>>16225000
          uslstate.(1:9) := %(2)011010000;                     <<00660>>16230000
          go to getout;                                        <<c+.06>>16235000
      end;                                                     <<c+.06>>16240000
      freaddir' (uslfnum,uslrec0,0);                           <<c+.06>>16245000
      if usllid <> uslfileid then                              <<c+.06>>16250000
   uslerr:                                                     <<c+.06>>16255000
      begin                                                    <<c+.06>>16260000
          error (8);                                           <<c+.06>>16265000
          go to nfg;                                           <<c+.06>>16270000
      end;                                                     <<c+.06>>16275000
      uslstate.(1:9) := %(2)000000000; <<init. state word>>    <<00660>>16280000
      diradr := -maxdir;                                                16285000
      infoadr := double(-maxhead);                                      16290000
      getdir;  <<try to load directory>>                                16295000
      getinfo  <<try to load info block>>                               16300000
      end;                                                              16305000
   go getout;                                                           16310000
                                                                        16315000
   nfg:                                                                 16320000
   if logical(flag) then  <<deallocate buffers?>>                       16325000
      begin                                                             16330000
      @dlarea1 := savedlarea1;  <<restore dl area 1 limit>>             16335000
      uslbufalloc := false  <<clear flag>>                              16340000
      end;                                                              16345000
                                                                        16350000
   getout:                                                              16355000
   end;                                                                 16360000
$page "USL FILE MAINTAINENCE PROCEDURES   -   CLOSEUSL"        <<00207>>16365000
$ control segment = seg13                                               16370000
procedure closeusl;                                                     16375000
   <<if a usl file is opened, saves the information in core that        16380000
     has been modified; saves record 0 and the directory or current     16385000
     entry if they have been modified.  note that this procedure uses   16390000
     the condition code to indicate an error>>                          16395000
   begin                                                                16400000
   tos := uslfnum;  <<file nr.>>                                        16405000
   if <> then  <<file opened?>>                                         16410000
      begin                                                             16415000
      if uslrec0mod then  <<record 0 modified?>>                        16420000
         begin                                                          16425000
         fwritedir'(uslfnum,uslrec0,0);  <<save record 0>>              16430000
         uslrec0mod _ false  <<clear flag>>                             16435000
         end;                                                           16440000
      putdir;  <<save directory buffer>>                                16445000
      putinfo;  <<save info buffer>>                                    16450000
      fclose(uslfnum,uslclosecode,0);                          <<00660>>16455000
      if < then  <<error?>>                                             16460000
         begin                                                          16465000
         tos _ 9;                                                       16470000
         tos _ 0d; fcheck(uslfnum,s0);  <<file sys. error nr.>>         16475000
         errorn(*,*);                                                   16480000
         tos _ ccl;  <<error condition code>>                           16485000
         go getout                                                      16490000
         end;                                                           16495000
      uslstate.(1:6) := %(2)000000;  <<re-set state word>>              16500000
      uslfnum := 0  <<mark file closed>>                                16505000
      end;                                                              16510000
   tos _ cce;  <<ok condition code>>                                    16515000
                                                                        16520000
   getout:                                                              16525000
   condcode _ tos  <<store condition code>>                             16530000
   end;                                                                 16535000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETDIR"          <<00207>>16540000
$ control segment = seg10                                               16545000
procedure getdir;                                                       16550000
   <<loads the directory if it is not in core and it will fit>>         16555000
   begin                                                                16560000
   if not usldirincore and usldl <= maxdir then                         16565000
      begin                                                             16570000
      freadmr''(uslfnum,dir,usldl,1);  <<read directory>>               16575000
      diradr := 128;  <<init. dir. adr.>>                               16580000
      uslstate.(3:2) := %(2)10  <<re-set state>>                        16585000
      end                                                               16590000
   end;                                                                 16595000
$page "USL FILE MAINTAINENCE PROCEDURES   -   PUTDIR"          <<00207>>16600000
$ control segment = seg10                                               16605000
procedure putdir;                                                       16610000
   <<writes the directory or current entry back into the usl file if    16615000
     the buffer has been modified and sets the appropriate state flags>>16620000
   begin                                                                16625000
   if usldirmod then  <<directory modified?>>                           16630000
      begin                                                             16635000
      fwritemr'(uslfnum,dir,min2(uslsaad-diradr,maxdir),diradr.(0:9));  16640000
      usldirmod _ false  <<clear flag>>                                 16645000
      end                                                               16650000
   end;                                                                 16655000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETINFO"         <<00207>>16660000
$ control segment = seg10                                               16665000
procedure getinfo;                                                      16670000
   <<if the info block is not in core and it will fit into the          16675000
     header buffer it will be loaded and the appropriate flags will     16680000
     will be set>>                                                      16685000
   begin                                                                16690000
   if (not uslinfoincore) and (uslil <= double(maxdir)) then            16695000
      begin                                                             16700000
      tos _ uslfnum; tos _ @head; tos _ uslil2;                         16705000
      tos _ uslsai&dlsr(7); delb;                                       16710000
      infoadr _ 0d;                                                     16715000
      freadmr''(*,*,*,*);  <<load info block>>                          16720000
      uslstate.(5:2) := %(2)10  <<init. flags>>                         16725000
      end                                                               16730000
   end;                                                                 16735000
$page "USL FILE MAINTAINENCE PROCEDURES   -   PUTINFO"         <<00207>>16740000
$ control segment = seg10                                               16745000
procedure putinfo;                                                      16750000
   <<writes the info block or current header/code module back into the  16755000
     usl file if it has been modified and sets the appropriate flags>>  16760000
   begin                                                                16765000
   if uslinfomod then  <<info modified?>>                               16770000
      begin                                                             16775000
      tos := uslfnum;  <<usl file nr.>>                                 16780000
      tos := @head;  <<info buffer>>                                    16785000
      tos := uslil-infoadr;                                             16790000
      tos := 0; tos := maxhead;                                         16795000
      if ds1 < ds3 then assemble(dxch);                                 16800000
      assemble(ddel,delb);  <<word count>>                              16805000
      tos := (infoadr+uslsai)&dlsr(7); delb;  <<rec. nr.>>              16810000
      fwritemr'(*,*,*,*);  <<save buffer>>                              16815000
      uslinfomod := false  <<clear flag>>                               16820000
      end                                                               16825000
   end;                                                                 16830000
$page "USL FILE MAINTAINENCE PROCEDURES   -   USLCLEAN"        <<00207>>16835000
$control segment=seg13                                         <<00207>>16840000
procedure uslclean;                                            <<00207>>16845000
                                                               <<00207>>16850000
   comment:   this procedure performs the cleanusl command by  <<00207>>16855000
              calling the intrinsic "CLEANUSL".  input is the  <<00207>>16860000
              name of the new usl in bfname1;                  <<00207>>16865000
                                                               <<00207>>16870000
begin                                                          <<00660>>16875000
    byte array b0(*)=pb := 14,"USL OR NEW USL";                <<00660>>16880000
    byte array b1(*)=pb := 8,"USL FILE";                       <<00660>>16885000
    byte array b2(*)=pb := 15,"CLEANUSL,      ";               <<00660>>16890000
    byte array bnewpass(*)=pb:="$NEWPASS ";                    <<04779>>16895000
    byte array boldpass(*)=pb:="$OLDPASS ";                    <<04779>>16900000
    byte array oldfilename(0:31);                              <<00660>>16905000
    byte array msgbuf(*) = oldfilename;                        <<00660>>16910000
    integer clerr = nuslfnum;<<00660usl rtns error on failure>><<00660>>16915000
    logical replaceoldusl := false;                            <<00660>>16920000
    integer errorcode,fopt,domain;                             <<04979>>16925000
                                                               <<00660>>16930000
    subroutine filesyserr( fnum, errmsg);                      <<00660>>16935000
       value fnum, errmsg;                                     <<00660>>16940000
       integer fnum, errmsg;                                   <<00660>>16945000
    begin                                                      <<00660>>16950000
       fcheck( fnum, i);                                       <<00660>>16955000
       errori( errmsg, i);                                     <<00660>>16960000
    end;                                                       <<00660>>16965000
                                                               <<00660>>16970000
    if uslfnum = 0 then <<usl file open?>>                     <<00660>>16975000
       begin                                                   <<00660>>16980000
       error(5);                                               <<00660>>16985000
       return;                                                 <<00660>>16990000
       end;                                                    <<00660>>16995000
                                                               <<00660>>17000000
    fgetinfo(uslfnum,oldfilename,fopt);                        <<04979>>17005000
    if <> then                                                 <<00660>>17010000
       begin                                                   <<00660>>17015000
       filesyserr( uslfnum, 200);                              <<00660>>17020000
       return;                                                 <<00660>>17025000
       end;                                                    <<00660>>17030000
    if bfname1 = " " then <<replace old usl file?>>            <<00660>>17035000
       begin                                                   <<00660>>17040000
       replaceoldusl := true;                                  <<00660>>17045000
       move bfname1 := oldfilename,(32);                       <<00660>>17050000
       end                                                     <<00660>>17055000
    else                                                       <<00660>>17060000
       begin                                                   <<00660>>17065000
       oldfile( bfname1, 209);                                 <<00660>>17070000
       if < then return;                                       <<00660>>17075000
       end;                                                    <<00660>>17080000
                                                               <<00660>>17085000
    <<flush buffers to disc>>                                  <<00660>>17090000
    if uslrec0mod then <<record 0 modified?>>                  <<00660>>17095000
       begin                                                   <<00660>>17100000
       fwritedir'(uslfnum,uslrec0,0);<<save record 0>>         <<00660>>17105000
       uslrec0mod := false; <<clear flag>>                     <<00660>>17110000
       end;                                                    <<00660>>17115000
    putdir;  <<save directory buffer>>                         <<00660>>17120000
    putinfo; <<save info buffer>>                              <<00660>>17125000
                                                               <<00660>>17130000
    nuslfnum := cleanusl( uslfnum, bfname1);                   <<00660>>17135000
    if < then                                                  <<00660>>17140000
       begin                                                   <<00660>>17145000
       move msgbuf := b0,(15);                                 <<00660>>17150000
       if clerr = 0 then errors( 94, msgbuf)                   <<00660>>17155000
     else                                                      <<00660>>17160000
       if clerr = 1 then errors( 84, msgbuf)                   <<00660>>17165000
     else                                                      <<00660>>17170000
       if clerr = 7 then error(121)                            <<00660>>17175000
     else                                                      <<00660>>17180000
       if clerr = 12 then                                      <<00660>>17185000
          begin                                                <<00660>>17190000
          move msgbuf := b1,(9);                               <<00660>>17195000
          errors( 8, msgbuf);                                  <<00660>>17200000
          end                                                  <<00660>>17205000
       else                                                    <<00660>>17210000
          begin <<what error??????>>                           <<00660>>17215000
          move msgbuf := b2,(16);                              <<00660>>17220000
          lntoa( clerr, 10, msgbuf(10));                       <<00660>>17225000
          errors( 209, msgbuf);                                <<00660>>17230000
          end;                                                 <<00660>>17235000
       nuslfnum := 0;                                          <<00660>>17240000
       return;                                                 <<00660>>17245000
       end;                                                    <<00660>>17250000
   if replaceoldusl then                                       <<04779>>17255000
      begin                                                    <<04779>>17260000
         domain := fopt.(14:2);                                <<04979>>17265000
         if domain = 0 then     << oldfilename is a new file >><<04979>>17270000
            domain := 1;        << so save nuslfnum as perm >> <<04979>>17275000
         fclose(nuslfnum,domain,0);                            <<04979>>17280000
         if <> then                                            <<04779>>17285000
            begin                                              <<04779>>17290000
           fcheck(nuslfnum,errorcode);                         <<04979>>17295000
           if errorcode = 100 or errorcode = 101 then          <<04979>>17300000
                  begin                                        <<04779>>17305000
                     uslclosecode := 4;                        <<04779>>17310000
                     closeusl;                                 <<04779>>17315000
                     if < then return;                         <<04779>>17320000
                     fclose(nuslfnum,domain,0);                <<04979>>17325000
                     if <> then                                <<04779>>17330000
                        filesyserr(nuslfnum,209);              <<04779>>17335000
                  end                                          <<04779>>17340000
               else                                            <<04779>>17345000
                  begin                                        <<04779>>17350000
                     errori(209,s0);                           <<04779>>17355000
                     closeusl;                                 <<04779>>17360000
                     if < then return;                         <<04779>>17365000
                  end;                                         <<04779>>17370000
               del;                                            <<04779>>17375000
            end                                                <<04779>>17380000
         else                                                  <<04779>>17385000
            begin                                              <<04779>>17390000
               uslclosecode := 4;                              <<04779>>17395000
               closeusl;                                       <<04779>>17400000
               if < then return;                               <<04779>>17405000
            end;                                               <<04779>>17410000
      end                                                      <<04779>>17415000
   else                                                        <<04779>>17420000
      begin                                                    <<04779>>17425000
         closeusl;                                             <<04779>>17430000
         if < then return;                                     <<04779>>17435000
         fclose(nuslfnum,1,0);                                 <<04779>>17440000
         if <> then                                            <<04779>>17445000
            begin                                              <<04779>>17450000
               filesyserr(nuslfnum,209);                       <<04779>>17455000
               move bfname1 := oldfilename,(32);               <<04779>>17460000
            end;                                               <<04779>>17465000
      end;                                                     <<04779>>17470000
                                                               <<04779>>17475000
   if bfname1 = bnewpass,(8) then                              <<04779>>17480000
      move bfname1 := boldpass,(9);                            <<04779>>17485000
   nuslfnum := 0;                                              <<04779>>17490000
   openusl (false);                                            <<04967>>17495000
end;                                                           <<00660>>17500000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETENTRY"        <<00207>>17505000
$ control segment = seg10                                               17510000
procedure getentry (fileadr);                                           17515000
   <<loads the usl entry having the file address fileadr and sets       17520000
     the entry parameters>>                                             17525000
   value fileadr; integer fileadr;                                      17530000
   begin                                                                17535000
   integer maxdir' = q+1;                                               17540000
                                                                        17545000
   subroutine load;                                                     17550000
      <<loads the specified entry by filling the directory buffer       17555000
        starting with the record containing the first word of the       17560000
        entry>>                                                         17565000
      begin                                                             17570000
      putdir;  <<save directory buffer>>                                17575000
      freadmr''(uslfnum,dir,maxdir',entfileadr.(0:9));                  17580000
      @entp _ @dir+entfileadr.(9:7);  <<init. entry pointer>>           17585000
      diradr _ entfileadr&lsr(7)&lsl(7)                                 17590000
      end;                                                              17595000
                                                                        17600000
   tos _ maxdir;                                                        17605000
   entfileadr _ fileadr.(1:15);  <<strip "LAST BIT" and save adr.>>     17610000
   if usldirincore then  <<directory in core?>>                         17615000
      @entp _ @dir+entfileadr-128                                       17620000
   else                                                                 17625000
      begin                                                             17630000
      tos _ entfileadr-diradr;  <<dir. disp. of entry>>                 17635000
      if < or s0 >= maxdir' then  <<first word in core?>>               17640000
         load                                                           17645000
      else                                                              17650000
         begin                                                          17655000
         @entp _ tos+@dir;  <<init. entry pointer>>                     17660000
         if @entp+enw > @dir+maxdir' then load                          17665000
         end                                                            17670000
      end;                                                              17675000
   uslentryparms                                                        17680000
   end;                                                                 17685000
$page "USL FILE MAINTAINENCE PROCEDURES   -   USLCOPY"         <<00207>>17690000
$control segment=seg10                                         <<00207>>17695000
procedure uslcopy;                                             <<00207>>17700000
                                                               <<00207>>17705000
   comment: this procedure implements the copyusl command.  it <<00207>>17710000
            expects to find the percentage in num1 and the new <<00207>>17715000
            file name in bfname1;                              <<00207>>17720000
                                                               <<00207>>17725000
begin                                                          <<00666>>17730000
    byte array bnewpass(*)=pb := "$NEWPASS ";                  <<00666>>17735000
    byte array boldpass(*)=pb := "$OLDPASS ";                  <<00666>>17740000
    byte array oldfilename(0:31);                              <<00666>>17745000
    double                                                     <<00666>>17750000
       factor,                                                 <<00666>>17755000
       totaldl,                                                <<00666>>17760000
       totalil;                                                <<00666>>17765000
    logical replaceoldusl := false;                            <<00666>>17770000
    integer errorcode,domain;                                  <<04979>>17775000
    integer                                                    <<00666>>17780000
       fopt;                                                   <<00666>>17785000
    integer pointer                                            <<00666>>17790000
       newrec0,                                                <<00666>>17795000
       tbuf;                                                   <<00666>>17800000
    double pointer                                             <<00666>>17805000
       dnewrec0 = newrec0;                                     <<00666>>17810000
    define                                                     <<00666>>17815000
       newpass  = fopt.(10:3) = 2#,                            <<00666>>17820000
       oldpass  = fopt.(10:3) = 3#;                            <<00666>>17825000
                                                               <<00666>>17830000
    subroutine filesyserr( fnum, errmsg);                      <<00666>>17835000
       value fnum, errmsg;                                     <<00666>>17840000
       integer fnum, errmsg;                                   <<00666>>17845000
    begin                                                      <<00666>>17850000
       fcheck( fnum, i);                                       <<00666>>17855000
       errori( errmsg, i);                                     <<00666>>17860000
    end;                                                       <<00666>>17865000
                                                               <<00666>>17870000
    subroutine copyrec0;                                       <<00666>>17875000
    begin                                                      <<00666>>17880000
       move newrec0 := uslrec0,(128);                          <<00666>>17885000
       newfl := (totaldl+totalil+1d)&dlsl(7);                  <<00666>>17890000
       newadl := integer(totaldl&dlsl(7))-newdl;               <<00666>>17895000
       newsai := (totaldl+1d)&dlsl(7);                         <<00666>>17900000
       newsaai := newsai+newil;                                <<00666>>17905000
       newail := totalil&dlsl(7)-newil;                        <<00666>>17910000
       fwritedir'( nuslfnum, newrec0, 0);                      <<00666>>17915000
    end;                                                       <<00666>>17920000
                                                               <<00666>>17925000
    subroutine copy( start, last, newposition);                <<00666>>17930000
       value start, last, newposition;                         <<00666>>17935000
       integer start, last, newposition;                       <<00666>>17940000
    begin                                                      <<00666>>17945000
       while start <= last do                                  <<00666>>17950000
          begin                                                <<00666>>17955000
          freaddir'( uslfnum, tbuf, start);                    <<00666>>17960000
          fwritedir'( nuslfnum, tbuf, newposition);            <<00666>>17965000
          start := start+1;                                    <<00666>>17970000
          newposition := newposition+1;                        <<00666>>17975000
          end;                                                 <<00666>>17980000
    end;                                                       <<00666>>17985000
                                                               <<00666>>17990000
    if uslfnum = 0 then <<usl file open?>>                     <<00666>>17995000
       begin                                                   <<00666>>18000000
       error(5);                                               <<00666>>18005000
       return;                                                 <<00666>>18010000
       end;                                                    <<00666>>18015000
    factor := double(num1) + 100d;                             <<00666>>18020000
    if factor < 100d or factor > 10000d then                   <<00666>>18025000
       begin                                                   <<00666>>18030000
       error(95);                                              <<00666>>18035000
       return;                                                 <<00666>>18040000
       end;                                                    <<00666>>18045000
                                                               <<00666>>18050000
    fgetinfo( uslfnum,oldfilename,fopt);<<present usl file name<<00666>>18055000
    if <> then                                                 <<00666>>18060000
       begin                                                   <<00666>>18065000
       filesyserr( uslfnum, 200);                              <<00666>>18070000
       return;                                                 <<00666>>18075000
       end;                                                    <<00666>>18080000
    if bfname1 = " " then <<replace old usl file?>>            <<00666>>18085000
       begin                                                   <<00666>>18090000
       replaceoldusl := true;                                  <<00666>>18095000
       if oldpass then                                         <<00666>>18100000
          move bfname1 := bnewpass,(9)                         <<00666>>18105000
       else                                                    <<00666>>18110000
          move bfname1 := oldfilename,(32);                    <<00666>>18115000
       end                                                     <<00666>>18120000
    else                                                       <<00666>>18125000
       begin                                                   <<00666>>18130000
       oldfile( bfname1, 209);                                 <<00666>>18135000
       if < then return;                                       <<00666>>18140000
       if bfname1 = boldpass,(8) then                          <<00666>>18145000
          move bfname1 := bnewpass,(9);                        <<00666>>18150000
       end;                                                    <<00666>>18155000
                                                               <<00666>>18160000
    <<flush buffers to disc>>                                  <<00666>>18165000
    if uslrec0mod then <<record 0 modified?>>                  <<00666>>18170000
       begin                                                   <<00666>>18175000
       fwritedir'(uslfnum,uslrec0,0);<<save record 0>>         <<00666>>18180000
       uslrec0mod := false; <<clear flag>>                     <<00666>>18185000
       end;                                                    <<00666>>18190000
    putdir;  <<save directory buffer>>                         <<00666>>18195000
    putinfo; <<save info buffer>>                              <<00666>>18200000
                                                               <<00666>>18205000
    <<open new usl file>>                                      <<00666>>18210000
    totaldl := delta(double(usldl+127)&dlsr(7),factor);        <<00666>>18215000
    if totaldl > 255d then totaldl := 255d;                    <<00666>>18220000
    totalil := delta((uslil+127d)&dlsr(7),factor);             <<00666>>18225000
    if totaldl+totalil+1d > double(maxusl) then                <<00666>>18230000
       begin                                                   <<00666>>18235000
       error(6);                                               <<00666>>18240000
       return;                                                 <<00666>>18245000
       end;                                                    <<00666>>18250000
    nuslfnum := fopen( bfname1,,4,,,,,,,totaldl+totalil+1d,    <<00666>>18255000
       16,1,uslfilecode);                                      <<00666>>18260000
    if <> then                                                 <<00666>>18265000
       begin                                                   <<00666>>18270000
       filesyserr( nuslfnum, 209);                             <<00666>>18275000
       return;                                                 <<00666>>18280000
       end;                                                    <<00666>>18285000
                                                               <<00666>>18290000
    <<allocate storage>>                                       <<00666>>18295000
    makeroomindl(256); <<get 256 words>>                       <<00666>>18300000
    if < then return;                                          <<00666>>18305000
    @tbuf := @dlarea1;                                         <<00666>>18310000
    @newrec0 := @dlarea1+128;                                  <<00666>>18315000
                                                               <<00666>>18320000
    <<begin copy into new usl file>>                           <<00666>>18325000
    copyrec0;                                                  <<00666>>18330000
    copy( 1, (uslsaad+127)&lsr(7), 1);                         <<00666>>18335000
    copy( integer(uslsai&dlsr(7)), integer((uslsaai+127d)&dlsr(7))-1,   18340000
          integer(newsai&dlsr(7)));                            <<00666>>18345000
                                                               <<00666>>18350000
   if replaceoldusl then                                       <<04779>>18355000
      begin                                                    <<04779>>18360000
         domain := fopt.(14:2);                                <<04979>>18365000
         if domain = 0 then     << oldfilename is a new file >><<04979>>18370000
            domain := 1;        << so save nuslfnum as perm >> <<04979>>18375000
         fclose(nuslfnum,domain,0);                            <<04979>>18380000
         if <> then                                            <<04779>>18385000
            begin                                              <<04779>>18390000
           fcheck(nuslfnum,errorcode);                         <<04979>>18395000
           if errorcode = 100 or errorcode = 101 then          <<04979>>18400000
                  begin                                        <<04779>>18405000
                     uslclosecode := 4;                        <<04779>>18410000
                     closeusl;                                 <<04779>>18415000
                     if < then return;                         <<04779>>18420000
                     fclose(nuslfnum,domain,0);                <<04979>>18425000
                     if <> then                                <<04779>>18430000
                        filesyserr(nuslfnum,209);              <<04779>>18435000
                  end                                          <<04779>>18440000
               else                                            <<04779>>18445000
                  begin                                        <<04779>>18450000
                     errori(209,s0);                           <<04779>>18455000
                     closeusl;                                 <<04779>>18460000
                     if < then return;                         <<04779>>18465000
                  end;                                         <<04779>>18470000
               del;                                            <<04779>>18475000
            end                                                <<04779>>18480000
         else                                                  <<04779>>18485000
            begin                                              <<04779>>18490000
               uslclosecode := 4;                              <<04779>>18495000
               closeusl;                                       <<04779>>18500000
               if < then return;                               <<04779>>18505000
            end;                                               <<04779>>18510000
      end                                                      <<04779>>18515000
   else                                                        <<04779>>18520000
      begin                                                    <<04779>>18525000
         closeusl;                                             <<04779>>18530000
         if < then return;                                     <<04779>>18535000
         fclose(nuslfnum,1,0);                                 <<04779>>18540000
         if <> then                                            <<04779>>18545000
            begin                                              <<04779>>18550000
               filesyserr(nuslfnum,209);                       <<04779>>18555000
               move bfname1 := oldfilename,(32);               <<04779>>18560000
            end;                                               <<04779>>18565000
      end;                                                     <<04779>>18570000
                                                               <<04779>>18575000
   if bfname1 = bnewpass,(8) then                              <<04779>>18580000
      move bfname1 := boldpass,(9);                            <<04779>>18585000
   nuslfnum := 0;                                              <<04779>>18590000
   openusl(false);                                             <<04779>>18595000
end;                                                           <<04779>>18600000
$page "USL FILE MAINTAINENCE PROCEDURES   -   DELTA"           <<00207>>18605000
$control segment=seg10                                         <<00207>>18610000
double procedure delta(x,f);                                   <<00207>>18615000
   value x,f; double x,f;                                      <<00207>>18620000
   begin                                                       <<00207>>18625000
      delta:=(x*f+50d)/100d;                                   <<00207>>18630000
   end;                                                        <<00207>>18635000
$page "USL FILE MAINTAINENCE PROCEDURES   -   OLDFILE"         <<00207>>18640000
$control segment=seg10                                         <<00207>>18645000
procedure oldfile( name, errnum);                              <<00648>>18650000
   value errnum;                                               <<00648>>18655000
   byte array name;                                            <<00648>>18660000
   integer errnum;                                             <<00648>>18665000
begin                                                          <<00648>>18670000
   integer fnum, i;                                            <<00648>>18675000
   if name <> " " then                                         <<00648>>18680000
      begin                                                    <<00648>>18685000
      fnum := fopen( name, 3);                                 <<00648>>18690000
      if = then                                                <<00648>>18695000
         begin                                                 <<00648>>18700000
         fclose( fnum, 0, 0);                                  <<00648>>18705000
         error(122);                                           <<00648>>18710000
         go nfg;                                               <<00648>>18715000
         end                                                   <<00648>>18720000
      else                                                     <<00648>>18725000
         begin                                                 <<00648>>18730000
         fcheck( fnum, i);                                     <<00648>>18735000
         if i <> 52 and i <> 58 then                           <<00660>>18740000
            begin                                              <<00648>>18745000
            errorn( errnum, double(i));                        <<00648>>18750000
            go nfg;                                            <<00648>>18755000
            end;                                               <<00648>>18760000
         end;                                                  <<00648>>18765000
      end;                                                     <<00648>>18770000
   condcode := cce;                                            <<00648>>18775000
   return;                                                     <<00648>>18780000
nfg:                                                           <<00648>>18785000
   condcode := ccl;                                            <<00648>>18790000
end;                                                           <<00648>>18795000
$page "USL FILE MAINTAINENCE PROCEDURES   -   USLENTRYPARMS"   <<00207>>18800000
$ control segment = seg10                                      <<00207>>18805000
procedure uslentryparms;                                                18810000
   <<calculates the usl entry parameters for the entry pointed to       18815000
     by entp.  checks for a valid entry type number; if an invalid      18820000
     one is found, a message is printed and the program terminates>>    18825000
   begin                                                                18830000
   switch entrysw := entry2,done,entry4,done,entry6,entry7,entry8;      18835000
   entnw _ enw;  <<nr. words in entry>>                                 18840000
   enttype _ etype;  <<entry type nr.>>                                 18845000
   if enttype > 8 then  <<illegal entry?>>                              18850000
      begin                                                             18855000
      printerror(0,double(logical(entfileadr)),null,null);     <<00595>>18860000
      quit(1)                                                           18865000
      end;                                                              18870000
   entnc _ enc;  <<nr. char's in name>>                                 18875000
   entnamenw _ entnc&lsr(1)+1;  <<nr. words for name>>                  18880000
   enthash _ hash(ename);  <<get entry hash code>>                      18885000
   @entp1 := @entp+entnamenw+2;  <<points to word following name>>      18890000
   go entrysw(enttype-2);                                               18895000
   go done;                                                             18900000
                                                                        18905000
   <<outer block>>                                                      18910000
                                                                        18915000
   entry2:                                                              18920000
   tos := @entp1(11);  <<first header set pointer>>                     18925000
   entry2b:                                                             18930000
   assemble(dup,incb);                                                  18935000
   @entheadsetp _ tos;  <<first header set pointer>>                    18940000
   entheadadr _ dps0;  <<first header set adr.>>                        18945000
   @entheadp _ tos+1;  <<init. header descriptor pointer>>              18950000
   tos := @esac1;  <<pointer to s.a. of code module>>                   18955000
   entcodeadr _ dps0;  <<s.a. of code module>>                          18960000
   entnwcode _ enwc;  <<nr. words in code module>>                      18965000
   go done;                                                             18970000
                                                                        18975000
   <<procedure>>                                                        18980000
                                                                        18985000
   entry4:                                                              18990000
   @entp2 := @entp1(11);  <<pointer to parm. info>>                     18995000
   entparmlen := parmlen(eparms);  <<parm. info length>>                19000000
   tos := @eparms+entparmlen;  <<first header set pointer>>             19005000
   go entry2b;                                                          19010000
                                                                        19015000
   <<interupt procedure>>                                               19020000
                                                                        19025000
   entry6:                                                              19030000
   tos _ @entp1(6);  <<first header set pointer>>                       19035000
   go entry2b;                                                          19040000
                                                                        19045000
   <<block data>>                                                       19050000
                                                                        19055000
   entry7:                                                              19060000
   @bdp _ @entp1(1);  <<init. block data pointer>>                      19065000
   tos _ @bdp+bdp(1).(4:3)+2;  <<pointer to first header set>>          19070000
   go entry2b;                                                          19075000
                                                                        19080000
   <<secondary procedure with parm's>>                                  19085000
                                                                        19090000
   entry8:                                                              19095000
   @entp2 := @entp1(2);  <<pointer to parm. info>>                      19100000
   entparmlen := parmlen(eparms);  <<parm. info length>>                19105000
                                                                        19110000
   done:                                                                19115000
   headtype _ 0  <<init. header type nr.>>                              19120000
   end;                                                                 19125000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETHEADER"       <<00207>>19130000
$ control segment = seg10                                               19135000
procedure getheader (codeflag,fileadr);                                 19140000
   <<loads the header or code module having the specified file address  19145000
     (relative to sai) and calculates the header parameters.  if the    19150000
     code module flag is set, the header type number is -1 and the      19155000
     number of words in the header is number of words of the code       19160000
     module in the header buffer>>                                      19165000
   value codeflag,fileadr;                                              19170000
   logical codeflag;                                                    19175000
   double fileadr;                                                      19180000
   begin                                                                19185000
   integer maxhead' = q+1;                                              19190000
                                                                        19195000
   subroutine load;                                                     19200000
      begin                                                             19205000
      putinfo;  <<save info buffer>>                                    19210000
      tos _ uslfnum; tos _ @head; tos _ maxhead';                       19215000
      tos _ headfileadr&dlsl(9);                                        19220000
      @headp _ tos&lsr(9)+@head;  <<init. header pointer>>              19225000
      freadmr''(*,*,*,*);                                               19230000
      infoadr _ fileadr&dlsr(7)&dlsl(7)                                 19235000
      end;                                                              19240000
                                                                        19245000
   tos _ maxhead;                                                       19250000
   headfileadr _ uslsai+fileadr;  <<absolute file adr.>>                19255000
   tos _ fileadr-infoadr;  <<buffer disp. of info>>                     19260000
   if < or ds1 >= double(logical(maxhead')) then  <<out of buffer?>>    19265000
      load                                                              19270000
   else  <<in buffer>>                                                  19275000
      @headp _ tos+@head;                                               19280000
   if codeflag then  <<code module?>>                                   19285000
      begin                                                             19290000
      tos _ -1;  <<header type nr.>>                                    19295000
      tos _ min3(entnwcode,@head+maxhead'-@headp,biggesthead);          19300000
      end                                                               19305000
   else  <<header>>                                                     19310000
      begin                                                             19315000
      tos _ htype;  <<header type nr.>>                                 19320000
      if s0 > 15 then  << illegal type number? >>              <<02817>>19325000
         begin                                                          19330000
      printerror(1,headfileadr,null,null);                     <<00595>>19335000
         quit(2)                                                        19340000
         end;                                                           19345000
      tos _ hnw;  <<nr. words in header>>                               19350000
      if @headp+s0 > @head+maxhead' then load  <<completely loaded?>>   19355000
      end;                                                              19360000
   headnw _ tos;  <<nr. words in header>>                               19365000
   headtype _ tos  <<header type nr.>>                                  19370000
   end;                                                                 19375000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETNEXTDESCRIP"  <<00207>>19380000
$ control segment = seg10                                               19385000
logical procedure getnextdescrip;                                       19390000
   <<sets the header descriptor pointer to the next descriptor in the   19395000
     header set of the current entry.  returns the value false if       19400000
     there are no more descriptors>>                                    19405000
   begin                                                                19410000
   @entheadp _ @entheadp+1;  <<next descriptor>>                        19415000
   if @entheadp >= @entp+entnw then return;  <<no more?>>               19420000
   if @entheadp = @entheadsetp+entheadsetp.(1:15)+3 then                19425000
      begin                                                             19430000
      @entheadsetp _ @entheadp;                                         19435000
      @entheadp _ @entheadp+3                                           19440000
      end;                                                              19445000
   getnextdescrip _ true                                                19450000
   end;                                                                 19455000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETNEXTHEADER"   <<00207>>19460000
$ control segment = seg10                                               19465000
logical procedure getnextheader (codeflag,bitmap);                      19470000
   <<loads the next header whose type number is equal to one specified  19475000
     by bitmap.  if codeflag is set, will set the header pointer to the 19480000
     code module when it is loaded, and sets headtype to -1 and headnw  19485000
     to the length of the code module that is in core.  returns the     19490000
     value false when there are no more headers>>                       19495000
   value codeflag,bitmap;                                               19500000
   logical codeflag,bitmap;                                             19505000
   begin                                                                19510000
   xreg _ headtype;  <<last header type nr.>>                           19515000
   if < then  <<code module?>>                                          19520000
      begin                                                             19525000
      entheadadr _ entheadadr+double(logical(headnw));                  19530000
      entnwcode _ entnwcode-headnw;                                     19535000
      if <> then go l3;  <<more code?>>                                 19540000
      if @entheadsetp >= @entp+entnw then return;  <<no headers?>>      19545000
      go l2                                                             19550000
      end;                                                              19555000
   if @entheadsetp >= @entp+entnw then  <<no header set?>>              19560000
      begin                                                             19565000
      if codeflag then  <<want code?>>                                  19570000
         begin                                                          19575000
         entheadadr _ entcodeadr;                                       19580000
         go l3                                                          19585000
         end;                                                           19590000
      return                                                            19595000
      end;                                                              19600000
   l1:                                                                  19605000
   if @entheadp > @entheadsetp+2 then                                   19610000
      entheadadr _ entheadadr+double(logical(eheadnw));                 19615000
   if entheadadr = entcodeadr then  <<hit code module?>>                19620000
      begin                                                             19625000
      if codeflag then  <<skip code module?>>                           19630000
         begin                                                          19635000
         l3:                                                            19640000
         tos _ true;                                                    19645000
         go l4                                                          19650000
         end;                                                           19655000
      entheadadr _ entheadadr+double(logical(entnwcode))                19660000
      end;                                                              19665000
   l2:                                                                  19670000
   @entheadp _ @entheadp+1;  <<next descriptor>>                        19675000
   if @entheadp = @entheadsetp+3+entheadsetp.(1:15) then                19680000
      begin                                                             19685000
      if entheadsetp < 0 then return;  <<last header set?>>             19690000
      tos _ @entheadp;                                                  19695000
      assemble(dup,incb);                                               19700000
      @entheadsetp _ tos;                                               19705000
      entheadadr _ dps0;                                                19710000
      @entheadp _ tos+1;                                                19715000
      go l1                                                             19720000
      end;                                                              19725000
   if not bitmap&csr(eheadtype) then go l1;  <<skip header?>>           19730000
   tos _ false;                                                         19735000
   l4:                                                                  19740000
   getheader(*,entheadadr);  <<load header or code>>                    19745000
   getout:                                                              19750000
   getnextheader _ true                                                 19755000
   end;                                                                 19760000
$page "USL FILE MAINTAINENCE PROCEDURES   -   BLOCKDATARESET"  <<00207>>19765000
$ control segment = seg10                                               19770000
logical procedure blockdatareset;                                       19775000
   <<checks to see if there is more than one set of headers in          19780000
     an entry (as is the case with the block data entry).  if so        19785000
     the value true is returned, the number of headers in the           19790000
     new set is calculated and the block data pointer (bdp) and         19795000
     the header pointer (entheadp) are reset.  otherwise the            19800000
     value false is returned>>                                          19805000
   begin                                                                19810000
   if @entheadp-@entp < entnw then                                      19815000
      begin                                                             19820000
      @bdp _ @entheadp;  <<re-init. common array pointer>>              19825000
      tos _ @bdp+bdp(1).(4:3)+2;                                        19830000
      assemble(dup,incb);                                               19835000
      @entheadsetp _ tos;  <<re-init. header set pointer>>              19840000
      entheadadr _ dps0;  <<s.a. of first header in set>>               19845000
      @entheadp _ tos+1;  <<re-init. header descriptor pointer>>        19850000
      blockdatareset _ true                                             19855000
      end                                                               19860000
   end;                                                                 19865000
$page "USL FILE MAINTAINENCE PROCEDURES   -   SEARCHUSL"       <<00207>>19870000
$control segment = seg10                                       <<03026>>19875000
logical procedure searchusl(name,index,type,mode');            <<03026>>19880000
  << searches the usl file and loads the entry having the   >> <<03026>>19885000
  << name name, index index and entry type corresponding    >> <<03026>>19890000
  << to type:                                               >> <<03026>>19895000
  <<    type < 0    any entry type                          >> <<03026>>19900000
  <<    type = 0    segment entry type                      >> <<03026>>19905000
  <<    type > 0    non-segment entry type                  >> <<03026>>19910000
  << assumptions:                                           >> <<03026>>19915000
  <<    leftmost byte of name(0) contains character count   >> <<03026>>19920000
  <<    optional mode' specified --- search for inactive    >> <<03026>>19925000
  <<    mode' not specified --- search foe active entry     >> <<03026>>19930000
  <<    index = 0 means first occurrence (active / inactive)>> <<03026>>19935000
  <<    index > 0 means the i-th occurrence                 >> <<03026>>19940000
  << note that index is ignored foe segment entry searches  >> <<03026>>19945000
                                                               <<03026>>19950000
   value index,type,mode';                                     <<03026>>19955000
   integer index,type;                                         <<03026>>19960000
   logical mode';                                              <<03026>>19965000
   integer array name;                                         <<03026>>19970000
                                                               <<03026>>19975000
   option variable;                                            <<03026>>19980000
                                                               <<03026>>19985000
   begin                                                       <<03026>>19990000
      integer mask=q-4;                                        <<03026>>19995000
      integer adr;                                             <<03026>>20000000
                                                               <<03026>>20005000
      adr:=uslrec0(uslfhi+hash(name));                         <<03026>>20010000
      while adr > 0 do                                         <<03026>>20015000
        begin                                                  <<03026>>20020000
          getentry(adr);                                       <<03026>>20025000
          if name.(4:4)=entnc then                             <<03026>>20030000
            begin                                              <<03026>>20035000
              tos:=@name&lsl(1)+1;                             <<03026>>20040000
              tos:=@ename&lsl(1)+1;                            <<03026>>20045000
              if * = *,(entnc) then                            <<03026>>20050000
                 if type < 0 or                                <<03026>>20055000
                    type = 0 and segmentname or                <<03026>>20060000
                    type > 0 and not segmentname then          <<03026>>20065000
                    begin                                      <<03026>>20070000
                      if integer(mask.(15:1))=0 then           <<03026>>20075000
                        if segmentname or                      <<03026>>20080000
                           index <= 0 and active or            <<03026>>20085000
                           index = 1 then                      <<03026>>20090000
                           begin                               <<03026>>20095000
                             found: searchusl:=true;           <<03026>>20100000
                             return                            <<03026>>20105000
                           end                                 <<03026>>20110000
                        else  index:=index-1                   <<03026>>20115000
                      else                                     <<03026>>20120000
                        if segmentname or                      <<03026>>20125000
                           index <= 0 and inactive or          <<03026>>20130000
                           index = 1 then                      <<03026>>20135000
                              go found                         <<03026>>20140000
                        else  index:=index-1                   <<03026>>20145000
                    end;                                       <<03026>>20150000
           end;                                                <<03026>>20155000
        adr:=ehl;                                              <<03026>>20160000
     end;                                                      <<03026>>20165000
   end;                                                        <<03026>>20170000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETFATHER"       <<00207>>20175000
$ control segment = seg10                                               20180000
procedure getfather;                                                    20185000
   <<loads the father entry of the entry in core.  nothing is done      20190000
     if the relationship is undefined or the father does not            20195000
     exist.  note that a kluge has been added for the removefamily      20200000
     procedure: entry type 0 has a father relation defined>>            20205000
   begin                                                                20210000
   if bitmap4&csr(enttype) then                                         20215000
      begin                                                             20220000
      while ebl > 0 do getentry(ebl);                                   20225000
      getentry(ebl)                                                     20230000
      end                                                               20235000
   end;                                                                 20240000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETBROTHER"      <<00207>>20245000
$ control segment = seg10                                               20250000
procedure getbrother;                                                   20255000
   <<loads the brother entry of the entry in core.  nothing is done     20260000
     if the relationship is undefined or the brother does not           20265000
     exist>>                                                            20270000
   begin                                                                20275000
   tos _ ebl;                                                           20280000
   if > then getentry(*)                                                20285000
   end;                                                                 20290000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETSON"          <<00207>>20295000
$ control segment = seg10                                               20300000
procedure getson;                                                       20305000
   <<loads the son entry of the entry in core.  nothing is done         20310000
     if the relationship is undefined or the son does not exist>>       20315000
   begin                                                                20320000
   if bitmap3&csr(enttype) then  <<relationship defined?>>              20325000
      begin                                                             20330000
      tos _ esl;                                                        20335000
      if > then getentry(*)                                             20340000
      end                                                               20345000
   end;                                                                 20350000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETENTRY"        <<00207>>20355000
$ control segment = seg10                                               20360000
procedure getsegentry;                                                  20365000
   <<loads the segment entry for the program unit entry currently       20370000
     in core.  if the entry in core is a segment, block data or         20375000
     interupt procedure entry nothing is done>>                         20380000
   begin                                                                20385000
   while not segmentname do getfather                                   20390000
   end;                                                                 20395000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETFAMILY"       <<00207>>20400000
$ control segment = seg10                                               20405000
logical procedure getfamily (fatheradr);                                20410000
   <<loads the son of the entry in core.  if no son exists, loads       20415000
     the brother of the entry in core.  if no brother exists,           20420000
     loads the brother of the father of the entry in core.  if          20425000
     the entry loaded is the same as fatheradr, the value false         20430000
     is returned; otherwise the value true is returned>>                20435000
   value fatheradr; integer fatheradr;                                  20440000
   begin                                                                20445000
   integer adr = q+1;                                                   20450000
   tos _ entfileadr;  <<save current entry address>>                    20455000
   getson;                                                              20460000
   if fatheradr = entfileadr then return;                               20465000
   if adr = entfileadr then                                             20470000
      begin                                                             20475000
      l1: getbrother;                                                   20480000
      if fatheradr = entfileadr then return;                            20485000
      if adr = entfileadr then                                          20490000
         begin                                                          20495000
         getfather;                                                     20500000
         adr _ entfileadr;  <<save address>>                            20505000
         if fatheradr = entfileadr then return;                         20510000
         go l1                                                          20515000
         end                                                            20520000
      end;                                                              20525000
   getfamily _ true                                                     20530000
   end;                                                                 20535000
$page "USL FILE MAINTAINENCE PROCEDURES   -   GETACTIVEFAMILY" <<02815>>20540000
$ control segment = seg10                                      <<02815>>20545000
logical procedure getactivefamily (fatheradr);                 <<02815>>20550000
     comment                                                   <<02815>>20555000
     loads only an active family member into core.             <<02815>>20560000
     loads the son of the entry in core.  if no son exists, loa<<02815>>20565000
     the brother of the entry in core.  if no brother exists,  <<02815>>20570000
     loads the brother of the father of the entry in core.  if <<02815>>20575000
     the entry loaded is the same as fatheradr, the value false<<02815>>20580000
     is returned, otherwise the value true is returned;        <<02815>>20585000
   value fatheradr; integer fatheradr;                         <<02815>>20590000
   begin                                                       <<02815>>20595000
   integer adr = q+1;                                          <<02815>>20600000
   tos _ entfileadr;  <<save current entry address>>           <<02815>>20605000
   if active then getson;                                      <<02815>>20610000
   if fatheradr = entfileadr then return;                      <<02815>>20615000
   if adr = entfileadr then                                    <<02815>>20620000
      begin                                                    <<02815>>20625000
      l1: getbrother;                                          <<02815>>20630000
      if fatheradr = entfileadr then return;                   <<02815>>20635000
      if adr = entfileadr then                                 <<02815>>20640000
         begin                                                 <<02815>>20645000
         getfather;                                            <<02815>>20650000
         adr _ entfileadr;  <<save address>>                   <<02815>>20655000
         if fatheradr = entfileadr then return;                <<02815>>20660000
         go l1                                                 <<02815>>20665000
         end                                                   <<02815>>20670000
      end;                                                     <<02815>>20675000
   if inactive then                                            <<02815>>20680000
      begin                                                    <<02815>>20685000
      adr _ entfileadr;                                        <<02815>>20690000
      go l1;                                                   <<02815>>20695000
      end;                                                     <<02815>>20700000
   getactivefamily _ true                                      <<02815>>20705000
   end;                                                        <<02815>>20710000
$ control segment = seg13                                               20715000
$page "USL FILE MAINTAINENCE PROCEDURES   -   ADDHASHLIST"     <<00207>>20720000
procedure addhashlist;                                                  20725000
   <<links the current entry into the hash table.  note that            20730000
     the state word flags are not changed>>                             20735000
   begin                                                                20740000
   ehl _ uslrec0(uslfhi+enthash);  <<move old link>>                    20745000
   uslrec0(uslfhi+enthash) _ entfileadr  <<insert new link>>            20750000
   end;                                                                 20755000
$page "USL FILE MAINTAINENCE PROCEDURES   -   ADDENTRY"        <<00207>>20760000
$ control segment = seg13                                               20765000
procedure addentry (size);                                              20770000
   <<adjusts the parameters in record 0 for the addition of an entry.   20775000
     a positive size indicates that an entry is being added; a          20780000
     negative size indicates that an entry is being deleted.  note that 20785000
     this procedure uses the condition code to indicate an error>>      20790000
   value size;                                                          20795000
   integer size;                                                        20800000
   begin                                                                20805000
   if size > usladl then  <<no room available?>>                        20810000
      begin                                                             20815000
      moveinfo((size+127)&lsr(7));  <<move info block>>                 20820000
      if < then  <<error?>>                                             20825000
         begin                                                          20830000
         tos := ccl;  <<error condition code>>                          20835000
         go getout                                                      20840000
         end                                                            20845000
      end;                                                              20850000
   uslne _ uslne + (if size > 0 then 1 else -1);                        20855000
   usldl _ usldl+size;                                                  20860000
   uslsaad _ uslsaad+size;                                              20865000
   usladl _ usladl-size;                                                20870000
   uslrec0mod := true;  <<set modified flag>>                           20875000
   tos := cce;  <<ok condition code>>                                   20880000
                                                                        20885000
   getout:                                                              20890000
   condcode := tos  <<store condition code>>                            20895000
   end;                                                                 20900000
$page "USL FILE MAINTAINENCE PROCEDURES   -   ADDHEADER"       <<00207>>20905000
$ control segment = seg13                                               20910000
procedure addheader (size);                                             20915000
   <<adjusts the parameters in record 0 for the addition of a header    20920000
     or code module.  a positive size indicates that a header is        20925000
     being added; a negative size indicates that an header is being     20930000
     deleted.  note that this procedure uses the condition code to      20935000
     indicate an error>>                                                20940000
   value size;                                                          20945000
   integer size;                                                        20950000
   begin                                                                20955000
   double dsize = q+1;                                                  20960000
                                                                        20965000
   tos := double(size);                                                 20970000
   if dsize > uslail then  <<no room available?>>                       20975000
      begin                                                             20980000
      moveinfo(-((size+127)&lsr(7)));  <<move info block>>              20985000
      if < then  <<error?>>                                             20990000
         begin                                                          20995000
         tos := ccl;  <<error condition code>>                          21000000
         go getout                                                      21005000
         end                                                            21010000
      end;                                                              21015000
   uslil := uslil+dsize;                                                21020000
   uslsaai := uslsaai+dsize;                                            21025000
   uslail := uslail-dsize;                                              21030000
   uslrec0mod := true;  <<set modified flag>>                           21035000
   tos := cce;  <<ok condition code>>                                   21040000
                                                                        21045000
   getout:                                                              21050000
   condcode := tos  <<store condition code>>                            21055000
   end;                                                                 21060000
$page "USL FILE MAINTAINENCE PROCEDURES   -   MOVEINFO"        <<00207>>21065000
$ control segment = seg13                                               21070000
procedure moveinfo (nrrecords);                                         21075000
   <<interface to adjustuslf procedure: moves the info block up or down 21080000
     in the usl file.  note that the file length is not changed.  note  21085000
     that this procedure uses the condition code to indicate an error>> 21090000
   value nrrecords;                                                     21095000
   integer nrrecords;                                                   21100000
   begin                                                                21105000
   if uslrec0mod then  <<record 0 modified?>>                           21110000
      begin                                                             21115000
      fwritedir'(uslfnum,uslrec0,0);  <<save record 0>>                 21120000
      uslrec0mod := false  <<clear flag>>                               21125000
      end;                                                              21130000
   putinfo;  <<save info buffer>>                                       21135000
   tos := adjustuslf(uslfnum,nrrecords);  <<move info>>                 21140000
   if < then  <<error?>>                                                21145000
      begin                                                             21150000
      xreg := s0;  <<error nr.>>                                        21155000
      assemble(dzro,inca);                                              21160000
      if (tos <= xreg <= tos) then ferror(uslfnum);  <<i/o error?>>     21165000
      error(tos-2);  <<insufficient space error>>                       21170000
      tos := ccl;  <<error condition code>>                             21175000
      go getout                                                         21180000
      end;                                                              21185000
   freaddir'(uslfnum,uslrec0,0);  <<reload record 0>>                   21190000
   tos := cce;  <<ok condition code>>                                   21195000
                                                                        21200000
   getout:                                                              21205000
   condcode := tos  <<store condition code>>                            21210000
   end;                                                                 21215000
$page "USL FILE MAINTAINENCE PROCEDURES   -   ADDTODIRECTORY"  <<00207>>21220000
$ control segment = seg13                                               21225000
procedure addtodirectory (size);                                        21230000
   <<checks the usl directory to see if there is room for a new         21235000
     entry of length size.  if there is room, an "EQUAL" condition      21240000
     code is returned and the buffers are adjusted for the new          21245000
     entry: the directory is removed if the new entry will              21250000
     overflow the buffer and the entry pointer (entp) is set to         21255000
     the new entry.  if there is not enough room, a "LESS THAN"         21260000
     condition code is returned and the buffers are restored to         21265000
     their origional state>>                                            21270000
   value size;                                                          21275000
   integer size;                                                        21280000
   begin                                                                21285000
   define direndrec = (recd & lsl (7))-128 #;                  <<c0.06>>21290000
   integer recd = q+1;  <<rec. nr.>>                                    21295000
   integer disp = q+2;  <<rec. disp.>>                                  21300000
                                                                        21305000
   <<* * * initialize local variables * * *>>                           21310000
                                                                        21315000
   tos := uslsaad.(0:9);                                                21320000
   tos := uslsaad.(9:7);                                                21325000
                                                                        21330000
   addentry(size);  <<update record 0>>                                 21335000
   if < then go nfg;  <<error?>>                                        21340000
   if usldirincore then  <<directory in core?>>                         21345000
      if usldl > maxdir then  <<dir. buf. overflow?>>                   21350000
         begin                                                          21355000
         putdir;  <<save directory buffer>>                             21360000
         usldirincore := false;  <<clear flag>>                         21365000
         tos := @dir; tos := @dir + direndrec; tos := disp;    <<c0.06>>21370000
<<move last chunk of directory (at rec boundary)>>             <<c0.06>>21375000
         assemble(move 3);                                              21380000
         diradr := recd&lsl(7);                                         21385000
         tos := disp                                                    21390000
         end                                                            21395000
      else                                                              21400000
         tos := uslsaad-size-128                                        21405000
   else  <<entry in core>>                                              21410000
      if uslsaad-diradr > maxdir then  <<dir. buf. overflow?>>          21415000
         begin                                                          21420000
         putdir;  <<save directory buffer>>                             21425000
         freadmr''(uslfnum,dir,disp,recd);  <<prime buffer>>            21430000
         diradr := recd&lsl(7);                                         21435000
         tos := disp                                                    21440000
         end                                                            21445000
      else                                                              21450000
         tos := uslsaad-size-diradr;                                    21455000
   @entp := tos+@dir;  <<entry pointer>>                                21460000
   tos := cce;  <<ok condition code>>                                   21465000
   go getout;                                                           21470000
                                                                        21475000
   nfg:                                                                 21480000
   tos := ccl;  <<error condition code>>                                21485000
                                                                        21490000
   getout:                                                              21495000
   condcode := tos  <<store condition code>>                            21500000
   end;                                                                 21505000
$page "USL FILE MAINTAINENCE PROCEDURES   -   ADDTOINFO"       <<00207>>21510000
$ control segment = seg13                                               21515000
procedure addtoinfo (size);                                             21520000
   <<adjusts the buffers for the addition of a new header or code       21525000
     module.  record 0 is updated and the header pointer is set to      21530000
     the space for the new header.  note that this procedure uses       21535000
     the condition code to indicate an error>>                          21540000
   value size;                                                          21545000
   integer size;                                                        21550000
   begin                                                                21555000
   define headrendrec = (recd & lsl (7)) #;                    <<00.06>>21560000
   integer recd = q+1;                                                  21565000
   integer disp = q+2;                                                  21570000
                                                                        21575000
   <<* * * initialize local variables * * *>>                           21580000
                                                                        21585000
   tos := uslil;                                                        21590000
   tos := tos&dlsl(9);                                                  21595000
   tos := tos&lsr(9);                                                   21600000
                                                                        21605000
   addheader(size);                                                     21610000
   if < then go nfg;  <<error?>>                                        21615000
   if uslinfoincore then  <<info in core?>>                             21620000
      if uslil > double (logical (maxhead)) then                        21625000
         begin                                                          21630000
         putinfo;  <<save info>>                                        21635000
         uslinfoincore := false;  <<clear flag>>                        21640000
         tos := @head; tos := @head+headrendrec; tos := disp;  <<00.06>>21645000
         assemble(move 3);  <<prime buffer>>                            21650000
         infoadr := double(logical(recd&lsl(7)));                       21655000
         tos := disp                                                    21660000
         end                                                            21665000
      else  <<no overflow>>                                             21670000
         tos := uslil2-size                                             21675000
   else  <<header or code module in core>>                              21680000
      begin                                                             21685000
      <<test for info buffer overflow>>                                 21690000
      if double (logical (maxhead)) < (uslil-infoadr) then              21695000
         begin                                                          21700000
         putinfo;  <<save info>>                                        21705000
         tos := uslfnum;                                                21710000
         tos := @head;                                                  21715000
         tos := disp;                                                   21720000
         tos := uslsai&dlsr(7); delb;                                   21725000
         freadmr''(*,*,*,tos+recd);  <<prime buffer>>                   21730000
         infoadr:=double (logical (recd)) & dlsl (7);          <<c0.02>>21735000
         tos := disp                                                    21740000
         end                                                            21745000
      else  <<no buffer overflow>>                                      21750000
         begin                                                          21755000
         tos := uslil-infoadr-double(size); delb                        21760000
         end                                                            21765000
      end;                                                              21770000
   @headp := tos+@head;  <<init. header pointer>>                       21775000
   tos := cce;  <<ok condition code>>                                   21780000
   go getout;                                                           21785000
                                                                        21790000
   nfg:                                                                 21795000
   tos := ccl;  <<error condition code>>                                21800000
                                                                        21805000
   getout:                                                              21810000
   condcode := tos  <<store condition code>>                            21815000
   end;                                                                 21820000
$page "USL FILE MAINTAINENCE PROCEDURES   -   CREATESEGENTRY"  <<00207>>21825000
$ control segment = seg13                                               21830000
procedure createsegentry (name);                                        21835000
   <<creates a segment entry having the name specified.  this           21840000
     entry becomes the current entry in core and is completely          21845000
     linked in the usl.  note that this procedure uses the condition    21850000
     code to indicate an error>>                                        21855000
   integer array name;                                                  21860000
   begin                                                                21865000
   integer size = q+1;  <<nr. words in segment entry>>                  21870000
   tos := name.(4:3)+5;                                                 21875000
   addtodirectory(size);                                                21880000
   if < then go nfg;  <<error?>>                                        21885000
   entfileadr := uslsaad-size;  <<entry file adr.>>                     21890000
   tos := size&lsl(5); setbit15; edescrip := tos;  <<descrip. word>>    21895000
   move ename := name,(size-4);  <<entry name>>                         21900000
   uslentryparms;  <<get entry parm's>>                                 21905000
   addhashlist;  <<add entry to hash lists>>                            21910000
   tos := uslsl;  <<brother link>>                                      21915000
   tos := entfileadr; setbit0;  <<son link>>                            21920000
   elinks := tos;                                                       21925000
   uslsl := entfileadr;  <<s.a. of segment list>>                       21930000
   uslrec0mod := true;  <<set modified flag>>                           21935000
   usldirmod := true;  <<set modified flag>>                            21940000
   tos := cce;  <<ok condition code>>                                   21945000
   go getout;                                                           21950000
                                                                        21955000
   nfg:                                                                 21960000
   tos := ccl;  <<error condition code>>                                21965000
                                                                        21970000
   getout:                                                              21975000
   condcode := tos  <<store condition coce>>                            21980000
   end;                                                                 21985000
$page "USL FILE MAINTAINENCE PROCEDURES   -   SETACTIVITY"     <<00207>>21990000
$ control segment = seg1                                                21995000
procedure setactivity (adflag);                                         22000000
   <<adjusts the activity bit of the family of entries whose root       22005000
     is in core>>                                                       22010000
   value adflag; logical adflag;                                        22015000
   begin                                                                22020000
                                                                        22025000
   subroutine fixbit;                                                   22030000
      <<adjusts the activity bit in the current entry>>                 22035000
      begin                                                             22040000
      eactivitybit := adflag;  <<reset activity bit>>                   22045000
      usldirmod _ true  <<set modified flag>>                           22050000
      end;                                                              22055000
                                                                        22060000
   fixbit;  <<adjust entry activity bit>>                               22065000
   if class <> entryclass then  <<adj. activity of sons?>>              22070000
      begin                                                             22075000
      tos _ entfileadr;  <<save entry address>>                         22080000
      while getfamily(s0) do fixbit                                     22085000
      end;                                                              22090000
   if not adflag and bitmap10&csr(enttype) then  <<act. seg.?>>         22095000
      begin                                                             22100000
      getsegentry;  <<get segment entry>>                               22105000
      fixbit                                                            22110000
      end                                                               22115000
   end;                                                                 22120000
$page "USL FILE MAINTAINENCE PROCEDURES   -   LISTUSL'"        <<00207>>22125000
$ control segment = seg13                                               22130000
procedure listusl';                                                     22135000
   <<lists the contents of the current usl file on the list device>>    22140000
   begin                                                                22145000
   array abbrev (2:8)=pb := "OB","SO","P ","SP","I0","BD","CP";         22150000
   byte array b0 (0:8)=pb _ "USL FILE ";                                22155000
   byte array b1 (0:11)=pb _ "BLOCK DATA'S";                            22160000
   byte array b2 (0:19)=pb := "INTERRUPT PROCEDURES";                   22165000
   byte array b3 (0:8)=pb _ "FILE SIZE";                                22170000
   byte array b4 (0:8)=pb _ "DIR. USED";                                22175000
   byte array b5 (0:8)=pb _ "INFO USED";                                22180000
   byte array b6 (0:9)=pb _ "DIR. GARB.";                               22185000
   byte array b7 (0:9)=pb _ "INFO GARB.";                               22190000
   byte array b8 (0:10)=pb _ "DIR. AVAIL.";                             22195000
   byte array b9 (0:10)=pb _ "INFO AVAIL.";                             22200000
                                                                        22205000
   subroutine descrip;                                                  22210000
      <<prints a one line description of the current program unit or    22215000
        entry point>>                                                   22220000
      begin                                                             22225000
      if ctly then assemble( exit 0 ); <<check for control y>> <<00.dm>>22230000
      tos _ @bline(3); tos _ @ename&lsl(1)+1;                           22235000
      move * _ *,(entnc);  <<entry name>>                               22240000
      if bitmap5&csr(enttype) then  <<code module?>>                    22245000
         begin                                                          22250000
         ntoa(enwc,8,bline(23));  <<nr. words of code>>                 22255000
         bline(33) _ if privledged then "P" else "N"                    22260000
         end;                                                           22265000
      line(13) _ abbrev(enttype);  <<entry type abbreviation>>          22270000
      if interuptproc then bline(27) _ integer(bline(27))+eit;          22275000
      bline(29) _ if inactive then "I" else "A";  <<activity>>          22280000
      if bitmap10&csr(enttype) then  <<callability>>                    22285000
         bline(31) _ if callable' then "U" else "C";                    22290000
      if not bitmap1&csr(enttype) then  <<hiddenness>>                  22295000
         bline(35) _ if hidden then "H" else "R";                       22300000
      printline                                                         22305000
      end;                                                              22310000
                                                                        22315000
   if uslrec0mod then  <<record 0 modified?>>                  <<00294>>22320000
      begin                                                    <<00294>>22325000
      fwritedir'(uslfnum,uslrec0,0);  <<save record 0>>        <<00294>>22330000
      uslrec0mod _ false  <<clear flag>>                       <<00294>>22335000
      end;                                                     <<00294>>22340000
   putdir;  <<save directory buffer>>                          <<00294>>22345000
   putinfo;  <<save info buffer>>                              <<00294>>22350000
   fcontrol(infnum,enable'ctly,i);                             <<00.dm>>22355000
   ctly := false;                                              <<00.dm>>22360000
   blankline;                                                           22365000
                                                               <<00592>>22370000
   if segname.(4:4) <> 0 then  <<list just one segment?>>      <<00592>>22375000
      begin                                                    <<00592>>22380000
      if searchusl(segname,0,uslseg) then                      <<00592>>22385000
         begin                                                 <<00592>>22390000
         tos := @ename&lsl(1)+1;                               <<00592>>22395000
         move bline := *,(entnc);                              <<00592>>22400000
         printline;                                            <<00592>>22405000
         tos := entfileadr;                                    <<00592>>22410000
         while getfamily(s0) do descrip;                       <<00592>>22415000
         end                                                   <<00592>>22420000
      else                                                     <<00592>>22425000
         error(93);                                            <<00592>>22430000
      return;                                                  <<00592>>22435000
      end;                                                     <<00592>>22440000
                                                               <<00592>>22445000
   tos _ uslfnum;                                                       22450000
   move bline _ b0,(9),2;                                               22455000
   fgetinfo(*,*);  <<insert usl file name>>                             22460000
   printline;                                                           22465000
   blankline;                                                           22470000
                                                                        22475000
   <<* * * list segments and entry points * * *>>                       22480000
                                                                        22485000
   tos _ uslsl;  <<s.a. segment list>>                                  22490000
   if <> then                                                           22495000
      begin                                                             22500000
      do begin                                                          22505000
         getentry(s0);  <<get segment entry>>                           22510000
         tos _ @bline; tos _ @ename&lsl(1)+1;                           22515000
         move * _ *,(entnc);  <<segment name>>                          22520000
         printline;                                                     22525000
         while getfamily(s0) do descrip;                                22530000
         del;                                                           22535000
         tos _ ebl;  <<next segment adr.>>                              22540000
         if <> then getbrother                                          22545000
         end until =;                                                   22550000
      blankline                                                         22555000
      end;                                                              22560000
                                                                        22565000
   <<* * * list block data program units * * *>>                        22570000
                                                                        22575000
   tos _ uslbdl;  <<s.a. block data list>>                              22580000
   if <> then                                                           22585000
      begin                                                             22590000
      move bline _ b1,(12);                                             22595000
      printline;                                                        22600000
      do begin                                                          22605000
         getentry(*);  <<get block data entry>>                         22610000
         descrip;                                                       22615000
         tos _ ebl  <<next block data entry>>                           22620000
         end until =;                                                   22625000
      blankline                                                         22630000
      end;                                                              22635000
                                                                        22640000
   <<* * * list interupt procedure program units * * *>>                22645000
                                                                        22650000
   tos _ uslipl;  <<s.a. interupt procedure list>>                      22655000
   if <> then                                                           22660000
      begin                                                             22665000
      move bline := b2,(20);                                            22670000
      printline;                                                        22675000
      do begin                                                          22680000
         getentry(*);  <<get interupt proc. entry>>                     22685000
         descrip;                                                       22690000
         tos _ ebl  <<next interupt proc. entry>>                       22695000
         end until =;                                                   22700000
      blankline                                                         22705000
      end;                                                              22710000
                                                                        22715000
   <<* * * list usl file parameters * * *>>                             22720000
                                                                        22725000
   move bline:=b3,(9); dntoa(uslfl,8,bline(19));               <<00207>>22730000
   bline(20):="(";                                             <<00207>>22735000
   dntoa((uslfl&dasr(7)),8,bline(25));                         <<00207>>22740000
   bline(26):=".";                                             <<00207>>22745000
   ntoa(uslfl2.(9:7),8,bline(29));                             <<00207>>22750000
   bline(30):=")";                                             <<00207>>22755000
   printline;                                                  <<00207>>22760000
   move bline:=b4,(9); ntoa((usldl+%200),8,bline(19));         <<00207>>22765000
   move bline(35):=b5,(9); dntoa(uslil,8,bline(54));           <<00207>>22770000
   bline(20):="(";                                             <<00207>>22775000
   ntoa(usldl.(0:9)+1,8,bline(25));                            <<00591>>22780000
   bline(26):=".";                                             <<00207>>22785000
   ntoa(usldl.(9:7),8,bline(29));                              <<00207>>22790000
   bline(30):=")";                                             <<00207>>22795000
   bline(55):="(";                                             <<00207>>22800000
   dntoa((uslil&dasr(7)),8,bline(60));                         <<00207>>22805000
   bline(61):=".";                                             <<00207>>22810000
   ntoa(uslil2.(9:7),8,bline(64));                             <<00207>>22815000
   bline(65):=")";                                             <<00207>>22820000
   printline;                                                  <<00207>>22825000
   move bline:=b6,(10); ntoa(usltdg,8,bline(19));              <<00207>>22830000
   move bline(35):=b7,(10); dntoa(usltig,8,bline(54));         <<00207>>22835000
   bline(20):="(";                                             <<00207>>22840000
  ntoa(usltdg.(0:9),8,bline(25));                              <<00207>>22845000
   bline(26):=".";                                             <<00207>>22850000
   ntoa(usltdg.(9:7),8,bline(29));                             <<00207>>22855000
   bline(30):=")";                                             <<00207>>22860000
   bline(55):="(";                                             <<00207>>22865000
   dntoa((usltig&dasr(7)),8,bline(60));                        <<00207>>22870000
   bline(61):=".";                                             <<00207>>22875000
   ntoa(usltig2.(9:7),8,bline(64));                            <<00207>>22880000
   bline(65):=")";                                             <<00207>>22885000
   printline;                                                  <<00207>>22890000
   move bline:=b8,(11); ntoa(usladl,8,bline(19));              <<00207>>22895000
   move bline(35):=b9,(11); dntoa(uslail,8,bline(54));         <<00207>>22900000
   bline(20):="(";                                             <<00207>>22905000
  ntoa(usladl.(0:9),8,bline(25));                              <<00207>>22910000
   bline(26):=".";                                             <<00207>>22915000
   ntoa(usladl.(9:7),8,bline(29));                             <<00207>>22920000
   bline(30):=")";                                             <<00207>>22925000
   bline(55):="(";                                             <<00207>>22930000
   dntoa((uslail&dasr(7)),8,bline(60));                        <<00207>>22935000
   bline(61):=".";                                             <<00207>>22940000
   ntoa(uslail2.(9:7),8,bline(64));                            <<00207>>22945000
   bline(65):=")";                                             <<00207>>22950000
   printline;                                                           22955000
   ejectpage;                                                  <<00.dm>>22960000
   fcontrol(infnum,disable'ctly,i);                            <<00.dm>>22965000
   end;                                                                 22970000
$page "USL FILE MAINTAINENCE PROCEDURES   -   UNLINKFAMILY"    <<00207>>22975000
$ control segment = seg13                                               22980000
procedure unlinkfamily (fatheradr);                                     22985000
   <<unlinks a family of entries from the segment, block data or        22990000
     interupt procedure lists.  nothing is changed within the           22995000
     family of entries (including the hash links)>>                     23000000
   value fatheradr; integer fatheradr;                                  23005000
   begin                                                                23010000
   integer brotheradr;                                                  23015000
                                                                        23020000
   subroutine getpredentry (startadr,entryadr);                         23025000
      <<steps through a list of brother entries looking for the         23030000
        predecessor entry of the specified entry.  when done the        23035000
        predecessor entry is in core.  if the starting entry address    23040000
        is the same as the specified entry, nothing is done>>           23045000
      value startadr,entryadr; integer startadr,entryadr;               23050000
      begin                                                             23055000
      if startadr <> entryadr then                                      23060000
         begin                                                          23065000
         getentry(startadr);                                            23070000
         while entp1.(1:15) <> entryadr do getbrother                   23075000
         end                                                            23080000
      end;                                                              23085000
                                                                        23090000
   subroutine unlink (startadr,flag);                                   23095000
      <<moves entry link to predecessor entry or rec0 and sets the      23100000
        appropriate modified flag>>                                     23105000
      value flag;                                                       23110000
      integer startadr; logical flag;                                   23115000
      begin                                                             23120000
      if fatheradr = startadr then  <<first entry in list?>>            23125000
         begin                                                          23130000
         startadr _ brotheradr;  <<insert link>>                        23135000
         if flag then uslrec0mod _ true else usldirmod _ true           23140000
         end                                                            23145000
      else                                                              23150000
         begin                                                          23155000
         getpredentry(startadr,fatheradr);                              23160000
         ebl _ brotheradr;  <<insert link>>                             23165000
         usldirmod _ true  <<set modified flag>>                        23170000
         end                                                            23175000
      end;                                                              23180000
                                                                        23185000
   getentry(fatheradr);                                                 23190000
   brotheradr _ ebl;  <<save brother link>>                             23195000
   if segmentname then unlink(uslsl,true)                               23200000
   else if interuptproc then unlink(uslipl,true)                        23205000
   else if blockdata then unlink(uslbdl,true)                           23210000
   else                                                                 23215000
      begin                                                             23220000
      getsegentry;                                                      23225000
      unlink(esl,false)                                                 23230000
      end                                                               23235000
   end;                                                                 23240000
$page "USL FILE MAINTAINENCE PROCEDURES   -   REMOVEFAMILY"    <<00207>>23245000
$ control segment = seg13                                               23250000
procedure removefamily (fatheradr);                                     23255000
   <<removes a family of entries from the current usl file>>            23260000
   value fatheradr; integer fatheradr;                                  23265000
   begin                                                                23270000
   integer i,entryadr;                                                  23275000
   unlinkfamily(fatheradr);                                             23280000
                                                                        23285000
   <<* * * free entry family storage * * *>>                            23290000
                                                                        23295000
   getentry(fatheradr);                                                 23300000
   do begin                                                             23305000
      entryadr _ entfileadr;  <<save entry address>>                    23310000
      tos _ ehl;  <<save hash link>>                                    23315000
                                                                        23320000
      <<* * * free header and code module storage * * *>>               23325000
                                                                        23330000
      if bitmap6&csr(enttype) then                                      23335000
         begin                                                          23340000
         if bitmap5&csr(enttype) then  <<code module?>>                 23345000
            usltig _ usltig+double(logical(entnwcode));                 23350000
         do while getnextdescrip do                                     23355000
            usltig _ usltig+double(logical(eheadnw))                    23360000
            until not blockdatareset                                    23365000
         end;                                                           23370000
                                                                        23375000
      <<* * * remove entry from hash list * * *>>                       23380000
                                                                        23385000
      i _ uslrec0(uslfhi+enthash);                                      23390000
      if i = entfileadr then uslrec0(xreg) _ tos  <<new hash link>>     23395000
      else                                                              23400000
         begin                                                          23405000
         do begin  <<get predecessor hash entry>>                       23410000
            getentry(i);                                                23415000
            i _ ehl  <<save hash link>>                                 23420000
            end until i = entryadr;                                     23425000
         ehl _ tos;  <<insert new hash link>>                           23430000
         usldirmod _ true;                                              23435000
         getentry(entryadr)                                             23440000
         end;                                                           23445000
                                                               <<01141>>23450000
      <<* * * free entry storage * * *>>                       <<01141>>23455000
                                                               <<01141>>23460000
      etype _ 0;  <<garbage type nr.>>                         <<01141>>23465000
      usltdg _ usltdg+entnw;                                   <<01141>>23470000
      uslndg _ uslndg+1;                                       <<01141>>23475000
      usldirmod _ true;                                        <<01141>>23480000
                                                               <<01141>>23485000
      end until not getfamily(fatheradr);                               23490000
                                                                        23495000
   <<* * * check for empty usl file * * *>>                             23500000
                                                                        23505000
   if usltdg = usldl then  <<directory empty?>>                         23510000
      begin                                                             23515000
      assemble(dzro,dzro; dzro,dzro; zero);                             23520000
      usladl := usladl+usldl;  <<re-set avail. directory length>>       23525000
      uslne := tos; usldl := tos; usltdg := tos; uslndg := tos;         23530000
      uslsaad := 128;                                                   23535000
      uslail := uslail+uslil;  <<re-set avail. info length>>            23540000
      uslil := tos; usltig := tos; uslnig := tos;                       23545000
      uslsaai := uslsai;                                       <<01.dm>>23550000
      diradr := 128;                                           <<01.dm>>23555000
      infoadr := 0d;                                           <<01.dm>>23560000
      uslstate.(3:4) := %(2)1010;                              <<01.dm>>23565000
      end;                                                              23570000
   uslrec0mod _ true                                                    23575000
   end;                                                                 23580000
$page "AUXILIARY USL FILE MAINTAINENCE PROC - CHANGESTATE"     <<00207>>23585000
<<----------------------------------------------------------------------23590000
*                                                                      *23595000
* auxiliary usl file maintainence procedures                           *23600000
*                                                                      *23605000
---------------------------------------------------------------------->>23610000
                                                                        23615000
$ control segment = seg13                                               23620000
procedure changestate;                                                  23625000
   <<interchanges the state variables for the usl and aux. usl          23630000
     files>>                                                            23635000
   begin                                                                23640000
   tos := uslstate; tos := xuslstate;                                   23645000
   uslstate := tos; xuslstate := tos;                                   23650000
   tos := uslfnum; tos := xuslfnum;                                     23655000
   uslfnum := tos; xuslfnum := tos;                                     23660000
   tos := @uslrec0; tos := @xuslrec0;                                   23665000
   @uslrec0 := tos; @xuslrec0 := tos;                                   23670000
   tos := @dir; tos := @xdir;                                           23675000
   @dir := tos; @xdir := tos;                                           23680000
   tos := diradr; tos := xdiradr;                                       23685000
   diradr := tos; xdiradr := tos;                                       23690000
   tos := @entp; tos := @xentp;                                         23695000
   @entp := tos; @xentp := tos;                                         23700000
   tos := @entp1; tos := @xentp1;                                       23705000
   @entp1 := tos; @xentp1 := tos;                                       23710000
   tos := @entp2; tos := @xentp2;                                       23715000
   @entp2 := tos; @xentp2 := tos;                                       23720000
   tos := @head; tos := @xhead;                                         23725000
   @head := tos; @xhead := tos;                                         23730000
   tos := infoadr; tos := xinfoadr;                                     23735000
   infoadr := tos; xinfoadr := tos;                                     23740000
   tos := @headp; tos := @xheadp;                                       23745000
   @headp := tos; @xheadp := tos;                                       23750000
   statechanged := statechanged+1  <<set state flag>>                   23755000
   end;                                                                 23760000
$page "AUXILIARY USL FILE MAINTAINENCE PROC - COPYFAMILY"      <<00207>>23765000
$ control segment = seg13                                               23770000
procedure copyfamily;                                                   23775000
   <<copies a family of entries from the aux. usl file into the         23780000
     orig. usl file.  it is assumed that the usl state has been         23785000
     changed when the procedure is called>>                             23790000
   begin                                                                23795000
   integer fatheradr = q+1;  <<address of family root entry>>           23800000
   integer entryadr = q+2;  <<address of first copied entry>>           23805000
   integer segadr = q+3;  <<address of segment entry>>                  23810000
   integer unitadr = q+4;  <<address of unit entry>>                    23815000
   integer codeflag = q+5;  <<first part of code module flag>>          23820000
   integer array saverec0 (*) = q+6;  <<save rec0 buffer>>              23825000
                                                                        23830000
   subroutine copyentry;                                                23835000
      <<copies the current entry from the aux. usl file to the orig.    23840000
        usl file>>                                                      23845000
      begin                                                             23850000
      changestate;  <<back to orig. usl file>>                          23855000
      addtodirectory(entnw);  <<allocate entry>>                        23860000
      if < then go nfg;  <<error?>>                                     23865000
      move entp := xentp,(entnw);  <<copy entry>>                       23870000
      @entp1 := @entp+entnamenw+2;  <<init. secondary pointer>>         23875000
      usldirmod := true;  <<set modified flag>>                         23880000
      changestate  <<back to aux. usl>>                                 23885000
      end;                                                              23890000
                                                                        23895000
   subroutine copyheader;                                               23900000
      <<copies the current header or code module from the aux. usl      23905000
        file to the orig. usl file>>                                    23910000
      begin                                                             23915000
      changestate;  <<back to orig. usl file>>                          23920000
      addtoinfo(headnw);  <<append header or code module>>              23925000
      if < then go nfg;  <<error?>>                                     23930000
      move headp := xheadp,(headnw);  <<copy header>>                   23935000
      uslinfomod := true;  <<set flag>>                                 23940000
      changestate  <<back to aux. usl>>                                 23945000
      end;                                                              23950000
                                                                        23955000
   subroutine linkup (listadr);                                         23960000
      <<inserts the current entry into the specified primary            23965000
        (i.e. segment, interupt procedure or block data) list>>         23970000
      integer listadr;                                                  23975000
      begin                                                             23980000
      ebl := listadr;  <<insert brother link>>                          23985000
      listadr := entryadr  <<new s.a. of list>>                         23990000
      end;                                                              23995000
                                                                        24000000
   subroutine insert;                                                   24005000
      <<inserts the current entry into the appropriate hash list>>      24010000
      begin                                                             24015000
      addhashlist;  <<link entry into hash list>>                       24020000
      usldirmod := true;  <<set modified flag>>                         24025000
      entryadr := entryadr+entnw  <<next entry adr.>>                   24030000
      end;                                                              24035000
                                                                        24040000
   <<* * * initialize local variables * * *>>                           24045000
                                                                        24050000
   tos := entfileadr;  <<save root adr.>>                               24055000
   tos := xuslsaad;  <<save first entry adr.>>                          24060000
   assemble(adds 131);                                                  24065000
   move saverec0 := xuslrec0,(128);  <<save record 0>>                  24070000
                                                                        24075000
   <<* * * copy segment entry * * *>>                                   24080000
                                                                        24085000
   if bitmap12&csr(enttype) then  <<seg. entry required?>>              24090000
      begin                                                             24095000
      getsegentry;  <<get segment entry>>                               24100000
      changestate;  <<back to orig. usl>>                               24105000
      if searchusl(xename,0,uslseg) then  <<seg. entry exists?>>        24110000
         begin                                                          24115000
         tos := false;                                                  24120000
         tos := entfileadr                                              24125000
         end                                                            24130000
      else  <<seg. entry copy needed>>                                  24135000
         begin                                                          24140000
         tos := true;                                                   24145000
         tos := uslsaad                                                 24150000
         end;                                                           24155000
      segadr := tos;  <<save seg. adr.>>                                24160000
      changestate;  <<back to aux. usl>>                                24165000
      if tos then  <<copy seg. entry?>>                                 24170000
         begin                                                          24175000
         uslentryparms;  <<restore entry parm's>>                       24180000
         copyentry                                                      24185000
         end;                                                           24190000
      getentry(fatheradr)  <<restore root entry>>                       24195000
      end;                                                              24200000
                                                                        24205000
   <<* * * copy entry, headers and code * * *>>                         24210000
                                                                        24215000
   do begin                                                             24220000
                                                                        24225000
      <<* * * copy entry * * *>>                                        24230000
                                                                        24235000
      if not segmentname then copyentry;  <<copy entry?>>               24240000
                                                                        24245000
      <<* * * copy headers and code * * *>>                             24250000
                                                                        24255000
      codeflag := -1;  <<init. code module flag>>                       24260000
      if bitmap6&csr(enttype) then  <<headers or code?>>                24265000
         do begin                                                       24270000
            while getnextheader(true,-1) do                             24275000
               begin                                                    24280000
               xreg := headtype;  <<header type nr.>>                   24285000
               if < then  <<code module?>>                              24290000
                  begin                                                 24295000
                  codeflag := codeflag+1;                               24300000
                  if = then  <<first part of code module?>>             24305000
                     begin                                              24310000
                     tos := xuslil;  <<s.a. code module>>               24315000
                     xesac2:= tos; xesac1 := tos                        24320000
                     end                                                24325000
                  end                                                   24330000
               else  <<header>>                                         24335000
                  if @entheadp-@entheadsetp = 3 then  <<new set?>>      24340000
                     begin                                              24345000
                     tos := @xentp+@entheadsetp-@entp+1;  <<sah pntr>>  24350000
                     if codeflag <> -1 then                             24355000
                     begin  <<code first>>                              24360000
                         tos := xesac1;                                 24365000
                         tos := xesac2;                                 24370000
                     end                                                24375000
                     else    <<head first in set>>                      24380000
                      tos := xuslil;                                    24385000
                     dps2 := tos;  <<insert s.a. of header set>>        24390000
                     del                                                24395000
                     end;                                               24400000
               copyheader  <<copy header/code module>>                  24405000
               end                                                      24410000
            end until not blockdatareset                                24415000
      end until not getfamily(fatheradr);                               24420000
                                                                        24425000
   <<* * * insert family root into appropriate list * * *>>             24430000
                                                                        24435000
   changestate;  <<back to orig. usl>>                                  24440000
   if entryadr = uslsaad then go getout; << anything copied? >><<01145>>24445000
   getentry(entryadr);  <<get first copied entry>>                      24450000
   if map12(enttype) = segclass then  <<new list entry?>>               24455000
      begin                                                             24460000
      if segmentname then  <<segment entry?>>                           24465000
         begin                                                          24470000
         linkup(uslsl);  <<insert into list>>                           24475000
         tos := entryadr; setbit0; esl := tos  <<empty son link>>       24480000
         end                                                            24485000
      else if interuptproc then  <<interupt procedure entry?>>          24490000
         linkup(uslipl)  <<insert into list>>                           24495000
      else linkup(uslbdl);  <<block data entry>>                        24500000
      insert  <<insert into hash list>>                                 24505000
      end;                                                              24510000
                                                                        24515000
   <<* * * insert entries into family list * * *>>                      24520000
                                                                        24525000
   while entryadr <> uslsaad do                                         24530000
      begin                                                             24535000
      getentry(entryadr);  <<get next entry>>                           24540000
      tos := map12(enttype);  <<entry level>>                           24545000
      getentry(if s0 = unitclass then segadr else unitadr);             24550000
      tos := esl;  <<save son link>>                                    24555000
      esl := entryadr;  <<insert new son link>>                         24560000
      usldirmod := true;  <<set modified flag>>                         24565000
      getentry(entryadr);  <<get entry again>>                          24570000
      ebl := tos;  <<insert brother link>>                              24575000
      if tos = unitclass then                                           24580000
         begin                                                          24585000
         tos := entryadr; setbit0; esl := tos;  <<empty son link>>      24590000
         unitadr := entryadr                                            24595000
         end;                                                           24600000
      insert  <<insert into hash list>>                                 24605000
      end;                                                              24610000
   go getout;                                                           24615000
                                                                        24620000
   nfg:                                                                 24625000
   tos := uslsai; tos := uslsaai;  <<new info position>>                24630000
   move uslrec0 := saverec0,(128);  <<restore record 0>>                24635000
   uslsaai := tos; uslsai := tos;  <<set new info position>>            24640000
                                                                        24645000
   getout:                                                              24650000
   uslrec0mod := true  <<set modified flag>>                            24655000
   end;                                                                 24660000
$page "SYMBOL TABLE MAINTAINENCE PROCEDURES  -  SEARCHSYM"     <<00207>>24665000
<<----------------------------------------------------------------------24670000
*                                                                      *24675000
*  symbol table maintainence procedures                                *24680000
*                                                                      *24685000
---------------------------------------------------------------------->>24690000
                                                                        24695000
$ control segment = seg21                                               24700000
logical procedure searchsym (name,type);                                24705000
   value type;                                                 <<04102>>24710000
   integer array name;            << name to be searched for >><<04102>>24715000
   logical type;                  << bit map of valid types >> <<04102>>24720000
                                                               <<04102>>24725000
   << this procedure searches the symbol table for a specific ><<04102>>24730000
   << name and qualifying type.  the type is specified in a    <<04102>>24735000
   << bit map whose bits are numbered from the right, starting <<04102>>24740000
   << with 16, then 1 through 15.  if a bit is set in the map, <<04102>>24745000
   << then the corresponding entry type qualifies for a match. <<04102>>24750000
                                                               <<04102>>24755000
   begin << searchsym >>                                       <<04102>>24760000
                                                               <<04102>>24765000
   @symp _ symbol(hash(name));  <<get initial address>>                 24770000
   while <> do                                                          24775000
      begin                                                             24780000
      symentparms;  <<get entry parm's>>                                24785000
      if name.(4:4) = symnc then                                        24790000
         begin                                                          24795000
         tos _ @name&lsl(1)+1; tos _ @sname&lsl(1)+1;                   24800000
         if * = *,(symnc) then  <<names match?>>                        24805000
                                                               <<04102>>24810000
            if type & csr(symtype) then                        <<04102>>24815000
               begin                                                    24820000
               searchsym _ true;                                        24825000
               return                                                   24830000
               end                                                      24835000
         end;                                                           24840000
      @symp _ shl  <<next entry>>                                       24845000
      end                                                               24850000
   end;                                                                 24855000
$page "SYMBOL TABLE MAINTAINENCE PROCEDURES  -  SYMENTPARMS"   <<00207>>24860000
$ control segment = seg21                                               24865000
procedure symentparms;                                                  24870000
   <<calculates the parameters of the symbol table entry pointed        24875000
     to by symp>>                                                       24880000
   begin                                                                24885000
   symnw _ snw;  <<nr. words in entry>>                                 24890000
   symtype _ stype;  <<entry type number>>                              24895000
   symnc _ snc;  <<nr. char's in name>>                                 24900000
   symnamenw _ symnc&lsr(1)+1;  <<nr. words for name>>                  24905000
   @symp1 _ @symp+symnamenw+2;  <<secondary pointer>>                   24910000
   @symp2 _ integer(map11(symtype))+@symp1;  <<secondary pointer>>      24915000
   if symtype = 7 then @symp2 := @symp2+sxnl                            24920000
   end;                                                                 24925000
$page "SYMBOL TABLE MAINTAINENCE PROCEDURES  -  CREATESYMENT"  <<00207>>24930000
$ control segment = seg21                                               24935000
procedure createsyment (type,name,parms);                               24940000
   <<creates a symbol table entry of the specified type and links       24945000
     it into the symbol table.  when done the symbol table entry        24950000
     parameters are set.  note that this procedure uses the             24955000
     condition code to indicate an error>>                              24960000
   value type;                                                          24965000
   integer type; byte array name; integer array parms;                  24970000
   begin                                                                24975000
   logical bitmap0 := %(2)0000111110011000;  <<ent's with parm. info>>  24980000
   integer parminfolen;                                                 24985000
                                                                        24990000
   <<* * * allocate space for entry * * *>>                             24995000
                                                                        25000000
   symnc _ name.(12:4);  <<nr. char's in name>>                         25005000
   symnamenw _ symnc&lsr(1)+1;  <<nr words for name>>                   25010000
   tos _ 0;  <<init. parm. info length>>                                25015000
   if bitmap0&csr(type) then  <<entry contains parm. info?>>            25020000
      begin                                                             25025000
      tos _ @parms;                                                     25030000
      tos _ parmlen(*)                                                  25035000
      end;                                                              25040000
   parminfolen _ tos;  <<parm. info length>>                            25045000
   symnw _ integer(map11(type))+2+symnamenw+parminfolen;  <<ent. len.>> 25050000
   makeroomindl(symnw);  <<is there room?>>                             25055000
   if < then  <<error?>>                                                25060000
      begin                                                             25065000
      tos _ ccl;  <<error condition code>>                              25070000
      go getout                                                         25075000
      end;                                                              25080000
   @stable _ @stable-symnw;  <<adj. symbol table pointer>>              25085000
   @dlarea1 _ @stable;  <<adj. dl avail. area pointer>>                 25090000
   usedsymbol _ usedsymbol+symnw;  <<adj. used space count>>            25095000
                                                                        25100000
   <<* * * initialize entry * * *>>                                     25105000
                                                                        25110000
   @symp _ @stable;  <<init. entry pointer>>                            25115000
   symtype _ type;  <<entry type number>>                               25120000
   symp := symtype cat symnw (0:6:10);  <<descriptor word>>    <<01124>>25125000
   tos _ hash(name);  <<hash code of name>>                             25130000
   shl _ symbol(s0);  <<insert entry hash link>>                        25135000
   symbol(tos) _ @symp;  <<new s.a. of hash list>>                      25140000
   tos _ @sname&lsl(1);                                                 25145000
   move * _ name,(symnc+1);  <<insert entry name>>                      25150000
   @symp1 _ @symp+symnamenw+2;  <<init. secondary pointer>>             25155000
   @symp2 _ integer(map11(type))+@symp1;  <<init. secondary pointer>>   25160000
   move sparms := parms,(parminfolen);  <<insert parm. info>>           25165000
   tos _ cce;  <<ok condition code>>                                    25170000
   getout:                                                              25175000
   condcode _ tos  <<store condition code>>                             25180000
   end;                                                                 25185000
$page "SYMBOL TABLE MAINTAINENCE PROCEDURES  -  EXPANDSYMENT"  <<00207>>25190000
$ control segment = seg21                                               25195000
procedure expandsyment (pntr,nrwords);                                  25200000
   <<expands the symbol table entry pointed to by symp by the           25205000
     specified number of words.  pntr points to the first word that     25210000
     is to be made available.  also repairs all entry pointers that     25215000
     reference moved entries.  note that this procedure uses the        25220000
     condition code to indicate an error>>                              25225000
   value pntr,nrwords; integer pointer pntr; integer nrwords;           25230000
   begin                                                                25235000
   subroutine fix (link);                                               25240000
      <<fixes the specified symbol table pointer (if necessary)>>       25245000
      integer link;                                                     25250000
      begin                                                             25255000
      if link < @pntr then link := link-nrwords                <<01124>>25260000
      end;                                                              25265000
   makeroomindl(nrwords);  <<is there room?>>                           25270000
   if < then  <<error - no room?>>                                      25275000
      begin                                                             25280000
      tos _ ccl;  <<error condition code>>                              25285000
      go getout                                                         25290000
      end;                                                              25295000
   @stable _ @stable-nrwords;  <<adj. symbol table pointer>>            25300000
   @dlarea1 _ @stable;  <<adj. dl available area pointer>>              25305000
   usedsymbol _ usedsymbol+nrwords;  <<adj. used space count>>          25310000
                                                                        25315000
   <<* * * expand symbol table entry * * *>>                            25320000
                                                                        25325000
   tos _ @stable; tos _ s0+nrwords; tos _ @pntr-s0+1;                   25330000
   assemble(move 3);                                                    25335000
   @symp _ @symp-nrwords;  <<adj. entry pointer>>                       25340000
   snw _ snw+nrwords;  <<adj. nr. words in entry>>                      25345000
                                                                        25350000
   <<* * * repair pointers to moved entries * * *>>                     25355000
                                                                        25360000
   xreg := 94;  <<hash index>>                                          25365000
   do begin                                                             25370000
      fix(symbol(xreg));  <<repair list head>>                          25375000
      xreg := xreg-1                                                    25380000
      end until <;                                                      25385000
   tos _ @symp;  <<save current entry pointer>>                         25390000
   @symp _ @stable;                                                     25395000
   while @symp < @stable(usedsymbol) do                                 25400000
      begin                                                             25405000
      symentparms;  <<get entry parm's>>                                25410000
      fix(shl);  <<repair hash link>>                                   25415000
      @symp _ @symp+symnw  <<next entry>>                               25420000
      end;                                                              25425000
   tos _ @rltable;  <<entry pointer>>                                   25430000
   tos _ nrrlent;  <<entry counter>>                                    25435000
   while <> do                                                          25440000
      begin                                                             25445000
      fix(ps1(2));                                                      25450000
      assemble(incb,incb; incb,deca)                                    25455000
      end;                                                              25460000
   ddel;                                                                25465000
   @symp _ tos;  <<restore current entry pointer>>                      25470000
   symentparms;  <<restore entry parm's>>                               25475000
   tos _ cce;  <<ok condition code>>                                    25480000
                                                                        25485000
   getout:                                                              25490000
   condcode _ tos  <<store condition code>>                             25495000
   end;                                                                 25500000
$page "PATCH TABLE MAINTAINENCE PROCEDURES  -  CREATEPATCHENT" <<00207>>25505000
<<----------------------------------------------------------------------25510000
*                                                                      *25515000
*  patch table maintainence procedures                                 *25520000
*                                                                      *25525000
---------------------------------------------------------------------->>25530000
                                                                        25535000
$ control segment = seg21                                               25540000
procedure createpatchent (type,adr);                                    25545000
   <<creates a patch table entry of the specified type for the          25550000
     specified segment address and links the entry into the patch       25555000
     table.  note that this procedure uses the condition code to        25560000
     indicate an error>>                                                25565000
   value type,adr; integer type,adr;                                    25570000
   begin                                                                25575000
   makeroomindl(3);                                                     25580000
   if < then  <<error - no room?>>                                      25585000
      begin                                                             25590000
      tos _ ccl;  <<error condition code>>                              25595000
      go getout                                                         25600000
      end;                                                              25605000
   @patchp _ @dlavail;  <<init. entry pointer>>                         25610000
   @dlavail _ @dlavail+3;  <<adj. dl available area limit>>             25615000
   xreg _ adr.(0:9);  <<record nr. of patch>>                           25620000
   tos _ type cat adr (1:9:7);  <<entry header word>>                   25625000
   tos _ patch(xreg);  <<insert old link>>                              25630000
   patchdp _ tos;                                                       25635000
   patch(xreg) _ @patchp-@ptable;  <<insert new link>>                  25640000
   usedpatch _ usedpatch+3;  <<adj. patch table length>>                25645000
   tos _ cce;  <<ok condition code>>                                    25650000
   getout:                                                              25655000
   condcode _ tos  <<store condition code>>                             25660000
   end;                                                                 25665000
$page "COMMON DATA LABEL TABLE MAINTAINENCE PROC-SEARCHCOMMON" <<00207>>25670000
<<----------------------------------------------------------------------25675000
*                                                                      *25680000
*  common data label table maintainence procedures                     *25685000
*                                                                      *25690000
---------------------------------------------------------------------->>25695000
                                                                        25700000
$ control segment = seg23                                               25705000
logical procedure searchcommon (dlabel,type);                           25710000
   <<searches the common table for the specified data label.  returns   25715000
     the value true if the data label of the specified type is          25720000
     found and sets the entry pointer to the entry.                     25725000
        type.(14:1) set if blank common data label                      25730000
        type.(15:1) set if byte data label>>                            25735000
   value dlabel,type; logical dlabel,type;                              25740000
   begin                                                                25745000
   integer index = q+1;                                                 25750000
   tos _ common(dlabel mod comhash).(0:14);                    <<cm.dm>>25755000
   while index <> %037777 do                                            25760000
      begin                                                             25765000
      tos _ comtabd(index);  <<load entry>>                             25770000
      if tos = dlabel then  <<data label match?>>                       25775000
         begin                                                          25780000
         assemble(dup);  <<duplicate link word>>                        25785000
         if tos.(14:2) = type.(14:2) then  <<type match?>>              25790000
            begin                                                       25795000
            searchcommon _ true;                                        25800000
            @comp _ @comtabd(index);  <<set entry pointer>>             25805000
            return                                                      25810000
            end                                                         25815000
         end;                                                           25820000
      index _ tos.(0:14)  <<next entry>>                                25825000
      end                                                               25830000
   end;                                                                 25835000
$page "COMMON DATA LABEL TABLE MAINTAINENCE PROC-CREATECOMENT" <<00207>>25840000
$ control segment = seg23                                               25845000
procedure createcoment (dlabel,type);                                   25850000
   <<creates a common table entry for the specified data label.         25855000
     note that this procedure uses the condition code to indicate       25860000
     an error>>                                                         25865000
   value dlabel,type; logical dlabel,type;                              25870000
   begin                                                                25875000
   integer hashcode = q+1;                                              25880000
   if nrcoment = p256 then  <<table overflow?>>                         25885000
      begin                                                             25890000
      error(66);                                                        25895000
      tos _ ccl;  <<error condition code>>                              25900000
      go getout                                                         25905000
      end;                                                              25910000
   tos _ dlabel mod comhash;  <<get hash code>>                         25915000
   tos _ type cat common(hashcode) (0:0:14);  <<link word>>    <<cm.dm>>25920000
   tos _ dlabel;  <<data label>>                                        25925000
   comtabd(nrcoment) _ tos;  <<store entry into table>>                 25930000
   common(hashcode).(0:14) _ nrcoment;  <<new s.a. of list>>   <<cm.dm>>25935000
   nrcoment _ nrcoment+1;  <<bump nr. of entries>>                      25940000
   tos _ cce;  <<ok condition code>>                                    25945000
   getout:                                                              25950000
   condcode _ tos  <<store condition code>>                             25955000
   end;                                                                 25960000
$page "RL TABLE MAINTAINENCE PROCEDURES - SEARCHRLTAB"         <<00207>>25965000
<<----------------------------------------------------------------------25970000
*                                                                      *25975000
*  rl table maintainence procedures                                    *25980000
*                                                                      *25985000
---------------------------------------------------------------------->>25990000
                                                                        25995000
$ control segment = seg23                                               26000000
logical procedure searchrltab (infoadr);                                26005000
   <<searches the rl table for the entry having the given info address. 26010000
     if found, the rl entry pointer is set to the entry and the value   26015000
     true is returned; otherwise the value false is returned>>          26020000
   value infoadr;                                                       26025000
   double infoadr;                                                      26030000
   begin                                                                26035000
   @rlentp _ @rltable;  <<init. entry pointer>>                         26040000
   tos _ nrrlent;  <<entry counter>>                                    26045000
   while <> do                                                          26050000
      begin                                                             26055000
      if rlentdp = infoadr then                                         26060000
         begin                                                          26065000
         searchrltab _ true;                                            26070000
         return                                                         26075000
         end;                                                           26080000
      @rlentp _ @rlentp+3;  <<next entry>>                              26085000
      tos _ tos-1                                                       26090000
      end                                                               26095000
   end;                                                                 26100000
$page "CODE SEGMENT PREPARATION PROCEDURES - PARMLEN"          <<00207>>26105000
<<----------------------------------------------------------------------26110000
*                                                                      *26115000
*  code segment preparation procedures                                 *26120000
*                                                                      *26125000
---------------------------------------------------------------------->>26130000
                                                                        26135000
$ control segment = seg3                                                26140000
integer procedure parmlen (parms);                                      26145000
   <<determines the number of words in the specified parameter          26150000
     information array>>                                                26155000
   integer array parms;                                                 26160000
   begin                                                                26165000
   integer p = q+1;                                                     26170000
   tos _ parms.(0:2);  <<value of p>>                                   26175000
   parmlen _ if = then 1 else if p = 3 then parms.(2:6)+2 else 2        26180000
   end;                                                                 26185000
$page "CODE SEGMENT PREPARATION PROCEDURES - PARMCHECK"        <<00207>>26190000
$ control segment = seg3                                                26195000
procedure parmcheck (formalp,actualp,parms);                   <<00595>>26200000
   integer array formalp,actualp,parms;                        <<00595>>26205000
   begin                                                                26210000
   integer p = q+1;  <<level of checking>>                     <<00595>>26215000
   integer pointer parmmap = q+2; <<bad parms bit map>>        <<00595>>26220000
                                                                        26225000
   <<* * * level 0 - no checking * * *>>                                26230000
                                                                        26235000
   parms := 0;                                                 <<00595>>26240000
   move parms(1) := parms,(4);                                 <<00595>>26245000
   tos _ min2(formalp.(0:2),actualp.(0:2));  <<checking level>>         26250000
   assemble(test);                                                      26255000
   if = then go match;                                                  26260000
   tos := @parms(1);  <<initialize parmmap>>                   <<00595>>26265000
                                                                        26270000
   <<* * * level 1 - procedure type * * *>>                             26275000
                                                                        26280000
   tos _ formalp(1);                                                    26285000
   if = then go l1;                                                     26290000
   tos _ actualp(xreg);                                                 26295000
   if = then go l1;                                                     26300000
   if tos <> tos or                                            <<00595>>26305000
      formalp.(8:8) <> actualp.(8:8) then                      <<00595>>26310000
      begin                                                    <<00595>>26315000
      parms := 1;                                              <<00595>>26320000
      return;                                                  <<00595>>26325000
      end;                                                     <<00595>>26330000
   l1: if p = 1 then go match;                                          26335000
                                                                        26340000
   <<* * * level 2 - number of parameters * * *>>                       26345000
                                                                        26350000
   tos _ formalp.(2:6);                                                 26355000
   tos _ actualp.(2:6);                                                 26360000
   assemble(ddup,cmp);                                                  26365000
   if <> then                                                  <<00595>>26370000
      begin                                                    <<00595>>26375000
      parms := 2;                                              <<00595>>26380000
      return;                                                  <<00595>>26385000
      end;                                                     <<00595>>26390000
   if p = 2 then go match;                                              26395000
                                                                        26400000
   <<* * * level 3 - parameter types * * *>>                            26405000
                                                                        26410000
   assemble(del,test);                                                  26415000
   if = then go match;  <<check for no parm's>>                         26420000
   again:                                                               26425000
   xreg _ xreg+1;                                                       26430000
   tos _ formalp(xreg);                                                 26435000
   if = then go del1;                                                   26440000
   tos _ actualp(xreg);                                                 26445000
   if = then go del2;                                                   26450000
                                                               <<02817>>26455000
   << check for pascal user-defined type. >>                   <<02817>>26460000
                                                               <<02817>>26465000
   if formalp(xreg) < 0 or actualp(xreg) < 0 then              <<02817>>26470000
      begin                                                    <<02817>>26475000
      if formalp(xreg) <> actualp(xreg) then                   <<02817>>26480000
         begin                                                 <<02817>>26485000
         parms := 3;                                           <<02817>>26490000
         setbit(parmmap, xreg - 2);                            <<02817>>26495000
         end;                                                  <<02817>>26500000
      go del2;                                                 <<02817>>26505000
      end;                                                     <<02817>>26510000
                                                                        26515000
   <<check mode>>                                                       26520000
                                                                        26525000
   tos _ formalp(xreg).(0:4);                                           26530000
   tos _ actualp(xreg).(0:4);                                           26535000
   assemble(ddup,cmp);                                                  26540000
   if <> then                                                           26545000
      if s0 <> 4 and s1 <> 4 then                              <<00595>>26550000
         begin                                                 <<00595>>26555000
         parms := 3;                                           <<00595>>26560000
         setbit( parmmap, xreg-2);                             <<00595>>26565000
         end;                                                  <<00595>>26570000
                                                                        26575000
   <<check structure>>                                                  26580000
                                                                        26585000
   tos _ formalp(xreg).(4:6);                                           26590000
   tos _ actualp(xreg).(4:6);                                           26595000
   assemble(ddup,cmp);                                                  26600000
   if <> then                                                           26605000
      if s1 <> 0 or s0 <> 1 and s0 <> 2 then                   <<00595>>26610000
         begin                                                 <<00595>>26615000
         parms := 3;                                           <<00595>>26620000
         setbit( parmmap, xreg-2);                             <<00595>>26625000
         end;                                                  <<00595>>26630000
                                                                        26635000
   <<check type>>                                                       26640000
                                                                        26645000
   tos _ formalp(xreg).(10:6);                                          26650000
   tos _ actualp(xreg).(10:6);                                          26655000
   assemble(ddup,cmp);                                                  26660000
   if <> then                                                           26665000
      if s0 <> 11 and s1 <> 11 then                            <<00595>>26670000
         begin                                                 <<00595>>26675000
         parms := 3;                                           <<00595>>26680000
         setbit( parmmap, xreg-2);                             <<00595>>26685000
         end;                                                  <<00595>>26690000
                                                                        26695000
   assemble(subs 6);                                                    26700000
   del2: del;                                                           26705000
   del1: del;                                                           26710000
   assemble(dabz match);                                                26715000
   go again;                                                            26720000
                                                                        26725000
   match:                                                      <<00595>>26730000
   end;                                                        <<00595>>26735000
$page "CODE SEGMENT PREPARATION PROCEDURES - EMITPLABEL"       <<00207>>26740000
$ control segment = seg21                                               26745000
procedure emitplabel;                                                   26750000
   <<allocates (if necessary) and initializes (if necessary) a          26755000
     p-label in the stt.  the stt number is placed in the symbol        26760000
     table entry and the procedure name and stt number are              26765000
     written.  it is assumed that the symbol table parameters are       26770000
     set for the procedure entry in question.  note that this           26775000
     procedure uses the condition code to indicate an error>>           26780000
   begin                                                                26785000
                                                                        26790000
   subroutine printname (segnr);                                        26795000
      <<prints the symbol table entry name and stt number of the        26800000
        external stt entry just allocated.  if the external label       26805000
        corresponds to an internal procedure, it's segment number       26810000
        is printed also>>                                               26815000
      value segnr; integer segnr;                                       26820000
      begin                                                             26825000
      tos _ @bline(3); tos _ @sname&lsl(1)+1;                           26830000
      move * _ *,(symnc);                                               26835000
      ntoa(sttnr,8,bline(21));  <<stt nr.>>                             26840000
      if segnr = -1                                                     26845000
         then bline(37) _ "?"  <<external procedure>>                   26850000
         else ntoa(segnr,8,bline(37));  <<internal proc.>>              26855000
      printline                                                         26860000
      end;                                                              26865000
                                                                        26870000
   if symtype = 7 then  <<external procedure>>                          26875000
      if sxnl = 0 or sxlsegnr <> cstnr then  <<emit p-label?>>          26880000
         begin                                                          26885000
         printname(-1);                                                 26890000
         sxnl _ sxnl+1;  <<bump p-label count now!>>                    26895000
         expandsyment(sxparms,1);  <<expand entry>>                     26900000
         if < then go nfg;  <<error?>>                                  26905000
         sxlplabel _ cstnr cat sttnr (0:8:8);  <<new p-label location>> 26910000
         sttnr _ sttnr+1                                                26915000
         end                                                            26920000
      else                                                              26925000
   else if sxsttnr = 0 then  <<internal procedure>>                     26930000
      begin                                                             26935000
      tos _ splabel;  <<load defining p-label>>                         26940000
      if < then  <<illegal p-label?>>                                   26945000
         begin                                                          26950000
         errors(43,sname);                                              26955000
         go nfg                                                         26960000
         end;                                                           26965000
      setbit0;  <<set "EXTERNAL" bit>>                                  26970000
      stt(-sttnr) _ tos;  <<insert p-label in stt>>                     26975000
      printname(ssegnr);                                                26980000
      sxsttnr _ sttnr;  <<insert stt nr. of p-label>>                   26985000
      sttnr _ sttnr+1                                                   26990000
      end;                                                              26995000
   tos _ cce;  <<ok condition code>>                                    27000000
   go getout;                                                           27005000
                                                                        27010000
   nfg:                                                                 27015000
   tos _ ccl;  <<error condition code>>                                 27020000
                                                                        27025000
   getout:                                                              27030000
   condcode _ tos  <<store condition code>>                             27035000
   end;                                                                 27040000
$page "CODE SEGMENT PREPARATION PROCEDURES - MAKEPATCHES"      <<00207>>27045000
$ control segment = seg21                                               27050000
procedure makepatches;                                                  27055000
   <<empties the patch table by making all patches.  note that this     27060000
     procedure uses the condition code to indicate an error>>           27065000
   begin                                                                27070000
   define exitproc = assemble(exit 0)#;                                 27075000
   integer array buffer(0:127);                                         27080000
   integer i,type,recd,disp,link;                                       27085000
   logical subroutine getnextpatch;                                     27090000
      <<looks at the link for the next patch.  if the patch is in       27095000
        the current record, the displacement entry in the current       27100000
        patch entry is updated.  if the patch is in another record,     27105000
        the displacement entry in the current patch entry is            27110000
        updated and the patch entry is moved to the corresponding       27115000
        list.  in both cases a value of true is returned.  if the       27120000
        patch is finished, the current patch entry is removed from      27125000
        the list and a value of false is returned.  note that in all    27130000
        cases it is assumed that the link is a negative displacement    27135000
        to the next entry>>                                             27140000
      if link = 0 then  <<finished with entry?>>                        27145000
         patch(i) _ patchp(1)  <<remove entry>>                         27150000
      else                                                              27155000
         begin                                                          27160000
         getrecddisp(double(disp-link),recd,disp);                      27165000
         if recd <> 0 then  <<list leaves record?>>                     27170000
            begin                                                       27175000
            if recd+i < 0 then  <<link out of segment?>>                27180000
               begin                                                    27185000
               error(81);                                               27190000
               exitproc                                                 27195000
               end;                                                     27200000
            patchp.(0:8) _ disp;  <<insert new disp>>                   27205000
            tos _ patchp(1);  <<temp save link>>                        27210000
            patchp(1) _ patch(i+recd);  <<insert new link>>             27215000
            patch(i+recd) _ patch(i);                                   27220000
            patch(i) _ tos                                              27225000
            end                                                         27230000
         else getnextpatch _ true                                       27235000
         end;                                                           27240000
   subroutine patch1;                                                   27245000
      <<makes pcal and llbl patches to the current record>>             27250000
      do begin                                                          27255000
         link _ buffer(disp);  <<save link>>                            27260000
         tos _ if < then %033400 else %031000;                          27265000
         tos _ tos+patchp(2);  <<insert stt nr.>>                       27270000
         buffer(disp) _ tos;  <<insert instruction>>                    27275000
         link _ link.(2:14)  <<strip flag bits>>                        27280000
         end until not getnextpatch;                                    27285000
   subroutine patch2;                                                   27290000
      <<makes pb address or own/data pointer patch to the current       27295000
        record>>                                                        27300000
      begin                                                             27305000
      buffer(disp) _ buffer(disp)+patchp(2);  <<correct adr>>           27310000
      patch(i) _ patchp(1)  <<remove entry>>                            27315000
      end;                                                              27320000
   subroutine patch3;                                                   27325000
      <<makes patches for external or common variables>>                27330000
      do begin                                                          27335000
         link _ buffer(disp).(8:8);  <<save link>>                      27340000
         buffer(disp).(8:8) _ patchp(2)  <<db address>>                 27345000
         end until not getnextpatch;                                    27350000
   subroutine patch4;                                                   27355000
      <<makes patches for format strings>>                              27360000
      do begin                                                          27365000
         link _ buffer(disp).(2:14);  <<save link>>                     27370000
         tos _ patchp(2);  <<word data label>>                          27375000
         if buffer(disp) < 0 then tos _ tos&lsl(1);  <<byte label>>     27380000
         buffer(disp) _ tos  <<insert data label>>                      27385000
         end until not getnextpatch;                                    27390000
   subroutine patch5;                                          <<04102>>27395000
      << nops toolbox symbolic debug calls >>                  <<04102>>27400000
      do                                                       <<04102>>27405000
         begin                                                 <<04102>>27410000
         link := buffer(disp).(2:14);  << link to next pcal >> <<04102>>27415000
         buffer(disp) := 0;            << nop current pcal >>  <<04102>>27420000
         end                                                   <<04102>>27425000
      until not getnextpatch;                                  <<04102>>27430000
   condcode _ ccl;  <<error condition code>>                            27435000
   i _ 127;                                                             27440000
   do begin                                                             27445000
      if patch(i) <> -1 then  <<non-empty patch list?>>                 27450000
         begin                                                          27455000
         if segrecd+i = trecd1  <<code in buffer?>>                     27460000
            then move buffer _ tbuf1,(tdisp1)  <<in buffer>>            27465000
            else freaddir'(segfnum,buffer,segrecd+i);  <<on disc>>      27470000
         while patch(i) <> -1 do  <<make patches in list>>              27475000
            begin                                                       27480000
            @patchp _ @ptable(patch(i));  <<set entry pointer>>         27485000
            disp _ patchp.(0:8);  <<record disp of patch>>              27490000
            type _ patchp.(8:8);  <<patch entry type>>                  27495000
            case type-1 of                                              27500000
               begin                                                    27505000
               patch1;  <<pcal instruction>>                            27510000
               patch2;  <<pb adr or own/data data label>>               27515000
               patch3;  <<external/common variable>>                    27520000
               patch4;  << format string >>                    <<04102>>27525000
               patch5;  << nop symbolic debug pcals >>         <<04102>>27530000
               end                                                      27535000
            end;                                                        27540000
         if segrecd+i = trecd1  <<code in buffer?>>                     27545000
            then move tbuf1 _ buffer,(tdisp1)  <<in buffer>>            27550000
            else fwritedir'(segfnum,buffer,segrecd+i)  <<on disc>>      27555000
         end;                                                           27560000
      i _ i-1                                                           27565000
      end until <;                                                      27570000
   usedpatch _ 0;  <<reset used space count>>                           27575000
   @dlavail _ @ptable;  <<reset dl available area pointer>>             27580000
   condcode _ cce  <<ok condition code>>                                27585000
   end;                                                                 27590000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER9S"         <<00207>>27595000
$ control segment = seg21                                               27600000
procedure header9s;                                                     27605000
   <<header type 9 for common array.  note that this procedure uses the 27610000
     condition code to indicate an error>>                              27615000
   begin                                                                27620000
   logical flag := false; <<blank common?>>                    <<cm.dm>>27625000
   double pointer sdatalabeld;                                 <<01124>>27630000
                                                               <<01124>>27635000
   logical subroutine searchsymcom(type,dlabel);               <<01124>>27640000
      value dlabel,type;                                       <<01124>>27645000
      integer dlabel,type;                                     <<01124>>27650000
   begin                                                       <<01124>>27655000
      @sdatalabeld := @symp2;                                  <<01124>>27660000
      while @sdatalabeld < @symp(symnw) do                     <<01124>>27665000
         begin                                                 <<01124>>27670000
         if ds2 = sdatalabeld  then                            <<01124>>27675000
            begin                                              <<01124>>27680000
            searchsymcom := true;                              <<01124>>27685000
            return;                                            <<01124>>27690000
            end;                                               <<01124>>27695000
         @sdatalabeld := @sdatalabeld+2;                       <<01124>>27700000
         end;                                                  <<01124>>27705000
   end;                                                        <<01124>>27710000
                                                               <<01124>>27715000
   if headp(2).(4:4) = 4 then  <<name = "COM'">>                        27720000
      begin                                                             27725000
      tos _ @headp(xreg)&lsl(1);                                        27730000
      tos _ @blankcommon&lsl(1);                                        27735000
      assemble(inca,incb);                                              27740000
      if * = *,(4) then flag := true;                          <<cm.fx>>27745000
      end;                                                              27750000
                                                                        27755000
   <<* * * allocate common array * * *>>                                27760000
                                                                        27765000
   if searchsym(headp(2),symcommon) then                       <<01124>>27770000
      begin  << old common >>                                  <<01124>>27775000
      if headp(1) <> snwca and not flag then                   <<01124>>27780000
         warns2(67,sname,ename);                               <<01124>>27785000
      if headp(1) > snwca then snwca := headp(1);<<new length>><<01124>>27790000
      end                                                      <<01124>>27795000
   else                                                        <<01124>>27800000
      begin << new common array >>                             <<01124>>27805000
      createsyment(6,headp(2),buf); <<create sym. tab. entry>> <<01124>>27810000
      if < then go nfg;                                        <<01124>>27815000
      snwca := headp(1); <<length of common array>>            <<01124>>27820000
      nrcoment := nrcoment+1;<< flag that common arrays exist>><<01124>>27825000
      end;                                                     <<01124>>27830000
                                                               <<01124>>27835000
   <<* * * process data labels * * *>>                         <<01124>>27840000
                                                               <<01124>>27845000
   tos := @headp+symnamenw+2;                                  <<01124>>27850000
   while @ps0 < @headp(headnw) do                              <<01124>>27855000
      begin                                                    <<01124>>27860000
      if not searchsymcom(ps0.(0:1),ps0(1)) then               <<01124>>27865000
         begin                                                 <<01124>>27870000
         expandsyment(symp2,2);<<make room for new data label>><<01124>>27875000
         if < then go nfg;                                     <<01124>>27880000
         symp2 := ps0.(0:1); <<type>>                          <<01124>>27885000
         symp2(1) := ps0(1);  <<data label>>                   <<01124>>27890000
         end;                                                  <<01124>>27895000
      tos := ps0.(2:14); tos := ps1.(1:1);                     <<01124>>27900000
      tos := tos+tos+tos+2; <<next address set>>               <<01124>>27905000
      end;                                                     <<01124>>27910000
   if @ps0 <> @headp(headnw) then  << bounds check >>          <<01501>>27915000
      begin                                                    <<01501>>27920000
      errors2(1,ename,headp(2));                               <<01501>>27925000
      go nfg;                                                  <<01501>>27930000
      end;                                                     <<01501>>27935000
   tos _ cce;  <<ok condition code>>                                    27940000
   go getout;                                                           27945000
                                                                        27950000
   nfg:                                                                 27955000
   tos _ ccl;  <<error condition code>>                                 27960000
                                                                        27965000
   getout:                                                              27970000
   condcode _ tos  <<store condition code>>                             27975000
   end;                                                                 27980000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER9S'"        <<01124>>27985000
$ control segment = seg23                                      <<01124>>27990000
procedure header9s';                                           <<01124>>27995000
   begin comment                                               <<01124>>28000000
                                                               <<01124>>28005000
      this procedure allocates the space for the               <<01124>>28010000
      common arrays.                                           <<01124>>28015000
;                                                              <<01124>>28020000
   nrcoment := 0;                                              <<01124>>28025000
   @symp := @stable; <<start of table>>                        <<01124>>28030000
   while @symp < @stable(usedsymbol) do                        <<01124>>28035000
      begin                                                    <<01124>>28040000
      symentparms; <<set up parameters>>                       <<01124>>28045000
      if symtype = 6 then                                      <<01124>>28050000
         begin <<common array>>                                <<01124>>28055000
         ssaca := nwsdb;  <<s.a. common array>>                <<01124>>28060000
         nwsdb := nwsdb+snwca; <<adj. sec. db array>>          <<01124>>28065000
         if overflow then overflowflag:=1;                     <<02816>>28070000
         tos := @symp2;                                        <<01124>>28075000
         while @ps0 < @symp(symnw) do                          <<01124>>28080000
            begin                                              <<01124>>28085000
            tos := ps0(1)+ssaca;                               <<01124>>28090000
            if lps1 then tos := tos+ssaca;                     <<01124>>28095000
            if not searchcommon(s0,ps1) then                   <<01124>>28100000
               begin                                           <<01124>>28105000
               createcoment(s0,ps1);                           <<01124>>28110000
               if < then go nfg;  <<error>>                    <<01124>>28115000
               end;                                            <<01124>>28120000
            del;                                               <<01124>>28125000
            tos := tos+2;                                      <<01124>>28130000
            end;                                               <<01124>>28135000
         del;                                                  <<01124>>28140000
         end;                                                  <<01124>>28145000
      @symp := @symp+symnw;                                    <<01124>>28150000
      end;                                                     <<01124>>28155000
                                                               <<01124>>28160000
   tos := cce;  <<ok condition code>>                          <<01124>>28165000
   go getout;                                                  <<01124>>28170000
                                                               <<01124>>28175000
   nfg:                                                        <<01124>>28180000
   tos := ccl;  <<error condition code>>                       <<01124>>28185000
                                                               <<01124>>28190000
   getout:                                                     <<01124>>28195000
   condcode := tos  <<store condition code>>                   <<01124>>28200000
   end;                                                        <<01124>>28205000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER10S"        <<01124>>28210000
$ control segment = seg21                                               28215000
procedure header10s;                                                    28220000
   <<header type 10 for logical units.  note that this procedure uses   28225000
     the condition code to indicate an error>>                          28230000
   begin                                                                28235000
   luspecified _ true;  <<set flag>>                                    28240000
   tos _ @headp(1);  <<entry pointer>>                                  28245000
   xreg _ 6;                                                            28250000
   do begin                                                             28255000
      logicalunits(xreg) _ logicalunits(xreg) lor lps0(xreg);           28260000
      xreg _ xreg-1                                                     28265000
      end until <                                                       28270000
   end;                                                                 28275000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER1P"         <<00207>>28280000
$ control segment = seg21                                               28285000
procedure header1p (rlflag);                                            28290000
   <<header type 1 for procedure calls.  note that this procedure uses  28295000
     the condition code to indicate an error>>                          28300000
   value rlflag;                                                        28305000
   logical rlflag;                                                      28310000
   begin                                                                28315000
   array parms1(0:4)=q;                                        <<00595>>28320000
   array parms2(0:4)=q;                                        <<00595>>28325000
   integer pointer procname = q+11;                            <<00595>>28330000
   integer pointer procparms = q+12;                           <<00595>>28335000
   integer nwparms = q+13;                                     <<00595>>28340000
   integer pointer newparms = q+14;                            <<00595>>28345000
                                                                        28350000
   subroutine upgrade;                                                  28355000
      <<upgrades a procedure or parameter descriptor: selects the non-  28360000
        universal descriptor, non-universal mode, non-universal type    28365000
        and overrides an array structure with a simple variable         28370000
        structure>>                                                     28375000
      begin                                                             28380000
      if sxparms(xreg) = 0 then tos _ procparms(xreg)                   28385000
      else if procparms(xreg) = 0 then tos _ sxparms(xreg)              28390000
      else                                                              28395000
         begin                                                          28400000
         tos _ sxparms(xreg);                                           28405000
         tos.(0:4) _ min2(sxparms(xreg).(0:4),procparms(xreg).(0:4));   28410000
         tos.(4:6) _ min2(sxparms(xreg).(4:6),procparms(xreg).(4:6));   28415000
         tos.(10:6) _ min2(sxparms(xreg).(10:6),procparms(xreg).(10:6)) 28420000
         end;                                                           28425000
      newparms(xreg) _ tos  <<insert new descriptor>>                   28430000
      end;                                                              28435000
                                                                        28440000
   <<* * * initialize local variables * * *>>                           28445000
                                                                        28450000
   tos _ @headp(2);  <<procedure name>>                                 28455000
   tos := procname.(4:3)+1+@procname;  <<proc. parm. info>>             28460000
   assemble(ddup,zrob);                                                 28465000
   tos := parmlen(*);  <<parm. info length>>                            28470000
   tos _ 0;                                                             28475000
                                                                        28480000
   <<* * * process procedure * * *>>                                    28485000
                                                                        28490000
   if (headp(2).(3:1) = 1) and not symdbug then                <<04102>>28495000
      createpatchent(5, unitadr + headp(1))  << patch the pcal <<04102>>28500000
   else                                                        <<04102>>28505000
      createpatchent(1, unitadr + headp(1)); << nop the pcal >><<04102>>28510000
   if < then go nfg;  <<error?>>                                        28515000
   if not searchsym(procname,if rlflag then symrlproc else symproc) then28520000
      begin                                                             28525000
      createsyment(7,procname,procparms);  <<create sym. tab. entry>>   28530000
      if < then go nfg;  <<error?>>                                     28535000
      sxnl _ 0;  <<init. nr. p-labels>>                                 28540000
      emitplabel;                                                       28545000
      if < then go nfg;  <<error?>>                                     28550000
      tos _ sxlsttnr  <<stt nr.>>                                       28555000
      end                                                               28560000
   else if symtype = 7 then  <<old external procedure>>                 28565000
      begin                                                             28570000
      emitplabel;                                                       28575000
      if < then go nfg; <<error?>>                                      28580000
                                                                        28585000
      <<* * * check parameter consistency * * *>>                       28590000
                                                                        28595000
      parmcheck(sxparms,procparms,parms1);                     <<00595>>28600000
      parmcheck(procparms,sxparms,parms2);                     <<00595>>28605000
      tos := 0;  <<flag - bad parm in bit map>>                <<00595>>28610000
      xreg := 4;                                               <<00595>>28615000
      do begin                                                 <<00595>>28620000
         parms1(xreg) := parms1(xreg) land parms2(xreg);       <<00595>>28625000
         if <> then tos := tos+1;  <<set flag!>>               <<00595>>28630000
         xreg := xreg-1;                                       <<00595>>28635000
         end until =;                                          <<00595>>28640000
      parms1 := min2(parms1,parms2);                           <<00595>>28645000
      if tos <> 0 or parms1 < 3 then                           <<00595>>28650000
         case parms1 of                                        <<00595>>28655000
            begin                                              <<00595>>28660000
            ;         <<no error>>                             <<00595>>28665000
            begin     <<bad function>>                         <<00595>>28670000
            errors2(49,procname,ename);                        <<00595>>28675000
            preperror := preperror+1;                          <<00595>>28680000
            end;                                               <<00595>>28685000
            begin     <<bad nr parms>>                         <<00595>>28690000
            errors2(50,procname,ename);                        <<00595>>28695000
            preperror := preperror+1;                          <<00595>>28700000
            end;                                               <<00595>>28705000
            begin     <<bad parms>>                            <<00595>>28710000
            errors2(45,procname,ename);                        <<00595>>28715000
            printbitmap( parms1(1));                           <<00595>>28720000
            preperror := preperror+1;                          <<00595>>28725000
            end;                                               <<00595>>28730000
            end; <<case>>                                      <<00595>>28735000
      @newparms _ if procparms.(0:2) > sxparms.(0:2) then               28740000
         @procparms else @sxparms;                                      28745000
                                                                        28750000
      <<upgrade procedure descriptor>>                                  28755000
                                                                        28760000
      if min2(sxparms.(0:2),procparms.(0:2)) >= 1 then                  28765000
         begin                                                          28770000
         xreg _ 1;                                                      28775000
         upgrade                                                        28780000
         end;                                                           28785000
                                                                        28790000
      <<upgrade parameter descriptors>>                                 28795000
                                                                        28800000
      if sxparms.(0:2) = 3 and procparms.(0:2) = 3 then                 28805000
         begin                                                          28810000
         xreg _ 2;                                                      28815000
         tos _ sxparms.(2:6);  <<nr. parameters>>                       28820000
         while <> do                                                    28825000
            begin                                                       28830000
            upgrade;                                                    28835000
            assemble(incx,deca)                                         28840000
            end                                                         28845000
         end;                                                           28850000
                                                                        28855000
      <<insert new parameter info>>                                     28860000
                                                                        28865000
      tos _ parmlen(newparms);                                          28870000
      tos _ parmlen(sxparms);                                           28875000
      assemble(ddup,cmp);                                               28880000
      if > then  <<expand entry?>>                                      28885000
         begin                                                          28890000
         expandsyment(sxparms,s1-s0);  <<expand entry>>                 28895000
         if < then go nfg  <<error?>>                                   28900000
         end;                                                           28905000
                                                                        28910000
      move sxparms _ newparms,(s1);  <<insert parm. info>>              28915000
      tos _ sxlsttnr  <<stt nr.>>                                       28920000
      end                                                               28925000
   else  <<internal procedure>>                                         28930000
      begin                                                             28935000
      parmcheck(sparms,procparms,parms1);                      <<00595>>28940000
      preperror := preperror+1;                                <<00595>>28945000
      case parms1 of                                           <<00595>>28950000
         begin                                                 <<00595>>28955000
         preperror := preperror-1;                             <<00595>>28960000
         errors2(49,procname,ename);                           <<00595>>28965000
         errors2(50,procname,ename);                           <<00595>>28970000
         begin                                                 <<00595>>28975000
            errors2(45,procname,ename);                        <<00595>>28980000
            printbitmap(parms1(1));                            <<00595>>28985000
         end;                                                  <<00595>>28990000
         end;                                                  <<00595>>28995000
      if ssegnr = cstnr then  <<use local p-label?>>                    29000000
         tos _ ssttnr  <<stt nr.>>                                      29005000
      else  <<use external p-label>>                                    29010000
         begin                                                          29015000
         emitplabel;                                                    29020000
         if < then go nfg;  <<error?>>                                  29025000
         tos _ sxsttnr  <<stt nr.>>                                     29030000
         end                                                            29035000
      end;                                                              29040000
   patchp(2) _ tos;  <<insert stt nr.>>                                 29045000
   tos _ cce;  <<ok condition code>>                                    29050000
   go getout;                                                           29055000
                                                                        29060000
   nfg:                                                                 29065000
   tos _ ccl;  <<error condition code>>                                 29070000
                                                                        29075000
   getout:                                                              29080000
   condcode _ tos  <<store condition code>>                             29085000
   end;                                                                 29090000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER2P"         <<00207>>29095000
$ control segment = seg21                                               29100000
procedure header2p;                                                     29105000
   <<header type 2 for pb addresses.  note that this procedure uses the 29110000
     condition code to indicate an error>>                              29115000
   begin                                                                29120000
   tos _ @headp(1);  <<pb address pointer>>                             29125000
   tos _ headnw-1;  <<pb address counter>>                              29130000
   while <> do                                                          29135000
      begin                                                             29140000
      createpatchent(2,unitadr+ps1);  <<create patch entry>>            29145000
      if < then  <<error?>>                                             29150000
         begin                                                          29155000
         tos _ ccl;  <<error condition code>>                           29160000
         go getout                                                      29165000
         end;                                                           29170000
      patchp(2) _ unitadr;  <<correction term>>                         29175000
      assemble(incb,deca)                                               29180000
      end;                                                              29185000
   tos _ cce;  <<ok condition code>>                                    29190000
                                                                        29195000
   getout:                                                              29200000
   condcode _ tos  <<store condition code>>                             29205000
   end;                                                                 29210000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER3P"         <<00207>>29215000
$ control segment = seg21                                               29220000
procedure header3p;                                                     29225000
   <<header type 3 for own/data variables.  note that this procedure    29230000
     uses the condition code to indicate an error>>                     29235000
   begin                                                                29240000
   tos _ @headp(1);  <<address pointer>>                                29245000
   tos _ headnw-1;  <<address counter>>                                 29250000
   while <> do                                                          29255000
      begin                                                             29260000
      createpatchent(2,unitadr+ps1.(1:15));  <<create patch entry>>     29265000
      if < then  <<error?>>                                             29270000
         begin                                                          29275000
         tos _ ccl;  <<error condition code>>                           29280000
         go getout                                                      29285000
         end;                                                           29290000
      tos _ sdbadr;  <<word correction term>>                           29295000
      if lps2.(0:1) then tos _ tos&lsl(1);  <<byte correction term>>    29300000
      patchp(2) _ tos;  <<insert correction term>>                      29305000
      assemble(incb,deca)                                               29310000
      end;                                                              29315000
   tos _ cce;  <<ok condition code>>                                    29320000
                                                                        29325000
   getout:                                                              29330000
   condcode _ tos  <<store condition cdoe>>                             29335000
   end;                                                                 29340000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER4P"         <<00207>>29345000
$ control segment = seg21                                               29350000
procedure header4p;                                                     29355000
   <<header type 4 for sec. db/own/data initial values>>                29360000
   begin                                                                29365000
   if headp(2) < 0                                                      29370000
      then bufferdatabytes(sdbadr&lsl(1)+headp(1),headp(4),headp(3),    29375000
         headp(2).(1:15))                                               29380000
      else bufferdatawords(sdbadr+headp(1),headp(3),headnw-3,headp(2))  29385000
   end;                                                                 29390000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER7P"         <<00207>>29395000
$ control segment = seg21                                               29400000
procedure header7p;                                                     29405000
   <<header type 7 for external variable.  note that this procedure     29410000
     uses the condition code to indicate an error>>                     29415000
   begin                                                                29420000
   if not searchsym(headp(2),symglobal) then  <<not global?>>           29425000
      begin                                                             29430000
      errors(63,headp(2));                                              29435000
      go nfg                                                            29440000
      end;                                                              29445000
   if headp(1) <> 0 and sgtn <> 0 and headp(1) <> sgtn then             29450000
      begin                                                             29455000
      errors(64,headp(2));                                              29460000
      go nfg                                                            29465000
      end;                                                              29470000
   tos _ @headp(2)+headp(2).(4:3)+1;  <<word following name>>           29475000
   if logical(headp(xreg).(0:1)) then  <<traced?>>                      29480000
      begin                                                             29485000
      pustbuf(ps0).(8:8) _ sgdba;  <<insert db adr.>>                   29490000
      @ps0 _ @ps0+1  <<skip pust adr.>>                                 29495000
      end;                                                              29500000
   tos _ @headp(headnw)-@ps0;  <<address counter>>                      29505000
   while <> do                                                          29510000
      begin                                                             29515000
      if ps1 <> -1 then  <<null list?>>                                 29520000
         begin                                                          29525000
         createpatchent(3,unitadr+ps1);  <<create patch entry>>         29530000
         if < then go nfg;  <<error?>>                                  29535000
         patchp(2) _ sgdba  <<insert prim. db address>>                 29540000
         end;                                                           29545000
      assemble(incb,deca)                                               29550000
      end;                                                              29555000
   tos _ cce;  <<ok condition code>>                                    29560000
   go getout;                                                           29565000
                                                                        29570000
   nfg:                                                                 29575000
   tos _ ccl;  <<error condition code>>                                 29580000
                                                                        29585000
   getout:                                                              29590000
   condcode _ tos  <<store condition code>>                             29595000
   end;                                                                 29600000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER9P"         <<00207>>29605000
$ control segment = seg21                                               29610000
procedure header9p;                                                     29615000
   <<header type 9 for common array.  note that this procedure uses     29620000
     the condition code to indicate an error>>                          29625000
   begin                                                                29630000
   integer dbadr := 0; <<data label db adr.>>                  <<01124>>29635000
                                                                        29640000
   <<* * * process data labels * * *>>                                  29645000
                                                                        29650000
   searchsym(headp(2),symcommon);  <<get sym. tab. entry>>              29655000
   tos _ @headp(2)+symnamenw;  <<address set pointer>>                  29660000
   while @ps0 < @headp(headnw) do                                       29665000
      begin                                                             29670000
      tos _ 0;  <<for procedure result>>                                29675000
      tos _ ps1(1);  <<data label>>                                     29680000
      tos _ tos+ssaca;  <<word data label>>                    <<01124>>29685000
      if ps2 < 0 then tos _ tos+ssaca;  <<byte data label>>    <<01124>>29690000
      tos _ ps2.(0:1);  <<type bits>>                          <<01124>>29695000
      searchcommon(*,*);  <<find data label entry>>                     29700000
      dbadr := (@comp-@comtab)&lsr(1)+nwpdb-nrcoment;  <<db adr.>>      29705000
      if lps0.(1:1) then pustbuf(ps0(2)).(8:8) := dbadr;  <<traced?>>   29710000
      tos _ ps0.(2:14);  <<list counter>>                               29715000
      @ps1 _ ps1.(1:1)+2+@ps1;  <<set pointer to first list>>           29720000
      assemble(test);                                                   29725000
      while <> do                                                       29730000
         begin                                                          29735000
         if ps1 <> -1 then  <<patch code?>>                             29740000
            begin                                                       29745000
            createpatchent(3,unitadr+ps1);  <<create patch>>            29750000
            if < then go nfg;  <<error?>>                               29755000
            patchp(2) := dbadr  <<data label adr.>>                     29760000
            end;                                                        29765000
         assemble(incb,deca)                                            29770000
         end;                                                           29775000
      del                                                               29780000
      end;                                                              29785000
   tos _ cce;  <<ok condition code>>                                    29790000
   go getout;                                                           29795000
                                                                        29800000
   nfg:                                                                 29805000
   tos _ ccl;  <<error condition code>>                                 29810000
                                                                        29815000
   getout:                                                              29820000
   condcode _ tos  <<store condition code>>                             29825000
   end;                                                                 29830000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER11P"        <<00207>>29835000
$ control segment = seg21                                               29840000
procedure header11p;                                                    29845000
   <<header type 11 for format strings.  note that this procedure uses  29850000
     the condition code to indicate an error>>                          29855000
   begin                                                                29860000
   createpatchent(4,unitadr+headp(1));  <<create patch entry>>          29865000
   if < then  <<error?>>                                                29870000
      begin                                                             29875000
      tos _ ccl;  <<error condition code>>                              29880000
      go getout                                                         29885000
      end;                                                              29890000
   patchp(2) _ formatadr;  <<insert s.a. string>>                       29895000
   bufferdatawords(formatadr,headp(3),headnw-3,1);  <<insert string>>   29900000
   formatadr _ formatadr+headnw-3;  <<adj. s.a. format area>>           29905000
   tos _ cce;  <<ok condition code>>                                    29910000
                                                                        29915000
   getout:                                                              29920000
   condcode _ tos  <<store condition code>>                             29925000
   end;                                                                 29930000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADERSIP"        <<04102>>29935000
$control segment = seg21                                       <<04102>>29940000
procedure headersip(firstsi);                                  <<04102>>29945000
   logical firstsi;               << false after first header ><<04102>>29950000
                                                               <<04102>>29955000
   << this subroutine processes toolbox si headers 12, 13      <<04102>>29960000
   << and 14.                                                  <<04102>>29965000
                                                               <<04102>>29970000
   begin << headersip >>                                       <<04102>>29975000
                                                               <<04102>>29980000
      if symdbug then                                          <<04102>>29985000
         begin                                                 <<04102>>29990000
         if firstsi then                                       <<04102>>29995000
            begin                                              <<04102>>30000000
            toolboxid := toolboxid + 1;                        <<04102>>30005000
            firstsi := false;                                  <<04102>>30010000
            end;                                               <<04102>>30015000
         headp(1) := toolboxid;                                <<04102>>30020000
         corebufsi(headp, headnw);                             <<04102>>30025000
         end;                                                  <<04102>>30030000
                                                               <<04102>>30035000
   end; << headersip >>                                        <<04102>>30040000
$page "CODE SEGMENT PREPARATION PROCEDURES - HEADER15P"        <<02817>>30045000
$control segment = seg21                                       <<02817>>30050000
procedure header15p;                                           <<02817>>30055000
                                                               <<02817>>30060000
<<*************************************************************<<02817>>30065000
<<                                                             <<02817>>30070000
<< this procedure process usl file header type 15 (private     <<02817>>30075000
<< procedure pcal) for the prep operation.  for each entry in  <<02817>>30080000
<< the header, an stt entry for the private procedure is allo- <<02817>>30085000
<< cated and initialized with a local p-label, and an entry in <<02817>>30090000
<< the patch table is created for correction of pcals to the   <<02817>>30095000
<< private procedure.                                          <<02817>>30100000
<<                                                             <<02817>>30105000
<< global input:                                               <<02817>>30110000
<<                                                             <<02817>>30115000
<<    headnw - this is the number of words in the header.      <<02817>>30120000
<<                                                             <<02817>>30125000
<<    headp - this is a pointer to the 1st word of the header. <<02817>>30130000
<<                                                             <<02817>>30135000
<<    sttppnr - this is the next stt entry to be used for a    <<02817>>30140000
<<       private procedure p-label.  it will be returned       <<02817>>30145000
<<       incremented by the number of p-labels generated.      <<02817>>30150000
<<                                                             <<02817>>30155000
<<    unitadr - this is the pb-relative address of the first   <<02817>>30160000
<<       word of code for the rbm being processed.             <<02817>>30165000
<<                                                             <<02817>>30170000
<< global output:                                              <<02817>>30175000
<<                                                             <<02817>>30180000
<<    stt - this is a core image of the stt for the segment    <<02817>>30185000
<<       being constructed.  the entries for the p-labels gen- <<02817>>30190000
<<       erated by this procedure will be updated.             <<02817>>30195000
<<                                                             <<02817>>30200000
<<*************************************************************<<02817>>30205000
                                                               <<02817>>30210000
begin << header15p >>                                          <<02817>>30215000
                                                               <<02817>>30220000
integer pointer headerentry;      << current entry >>          <<02817>>30225000
integer pointer headerend;        << end of header + 1 >>      <<02817>>30230000
                                                               <<02817>>30235000
<< header15p >>                                                <<02817>>30240000
                                                               <<02817>>30245000
   @headerentry := @headp(1);                                  <<02817>>30250000
   @headerend   := @headp + headnw;                            <<02817>>30255000
                                                               <<02817>>30260000
   while @headerentry < @headerend do                          <<02817>>30265000
      begin                                                    <<02817>>30270000
      createpatchent(1, unitadr + headerentry);                <<02817>>30275000
      if < then                                                <<02817>>30280000
         go abort;                                             <<02817>>30285000
      patchp(2) := sttppnr;                                    <<02817>>30290000
      stt(-sttppnr) := unitadr + headerentry(1);               <<02817>>30295000
      sttppnr := sttppnr + 1;                                  <<02817>>30300000
      @headerentry := @headerentry + 2;                        <<02817>>30305000
      end;                                                     <<02817>>30310000
   condcode := cce;                                            <<02817>>30315000
   return;                                                     <<02817>>30320000
                                                               <<02817>>30325000
abort:                                                         <<02817>>30330000
   condcode := ccl;                                            <<02817>>30335000
                                                               <<02817>>30340000
end; << header15p >>                                           <<02817>>30345000
$page "CODE SEGMENT PREPARATION PROCEDURES - SCANSEGMENT"               30350000
$ control segment = seg21                                               30355000
procedure scansegment (segadr);                                         30360000
   <<this procedure scans a segment and calculates it's attributes:     30365000
     creates a symbol table entry for each active entry point in        30370000
        the segment, using cstnr as the segment number                  30375000
     creates a symbol table entry for each global variable and          30380000
        common array                                                    30385000
     calculates:                                                        30390000
        the next available stt number (sttnr)                           30395000
        the segment length (seglen) not including the stt               30400000
        the address of the primary o.b. entry point (obadr) if any      30405000
        the global storage requirements (nwpdb and nwsdb)               30410000
     note that this procedure uses the condition code to indicate       30415000
     an error>>                                                         30420000
   value segadr;                                                        30425000
   integer segadr;                                                      30430000
   begin                                                                30435000
   switch headersw := h6, h7, ok, h9, h10, ok, hsi, hsi, hsi,  <<04102>>30440000
                      h15;                                     <<04102>>30445000
   integer pointer parms;  <<parm. info pointer>>                       30450000
                                                                        30455000
   subroutine header6;                                                  30460000
      <<header type 6 for global variables>>                            30465000
      begin                                                             30470000
      tos _ 5; tos _ @headp(2)&lsl(1); assemble(inca,zero);             30475000
      createsyment(*,*,*);  <<create sym. tab. entry>>                  30480000
      if < then go nfg;  <<error?>>                                     30485000
      sgtn _ headp(1); <<data type descriptor>>                         30490000
      sgdba _ headp(2).(0:8)  <<prim. db adr.>>                         30495000
      end;                                                              30500000
                                                                        30505000
   <<* * * initialize parameters * * *>>                                30510000
                                                                        30515000
   seglen  := 0;                                               <<02817>>30520000
   sttnr   := 1;                                               <<02817>>30525000
   sttppnr := 0;                                               <<02817>>30530000
   if active then  <<segment active?>>                                  30535000
      begin                                                             30540000
      while getactivefamily(segadr) do                         <<02815>>30545000
         if active then  <<entry point active?>>                        30550000
            begin                                                       30555000
                                                                        30560000
            <<* * * create symbol table entry * * *>>                   30565000
                                                                        30570000
            if searchsym(ename,symany) then  <<mult. def.?>>            30575000
               begin                                                    30580000
               tos:=73; go errors1;                            <<04121>>30585000
               end;                                                     30590000
            if not programfile and bitmap1&csr(enttype) then            30595000
               begin                                                    30600000
               tos := 13; go error1                                     30605000
               end;                                                     30610000
            tos := map10(enttype);  <<type nr.>>                        30615000
            tos := @ename&lsl(1);  <<name>>                             30620000
            tos := if secondaryproc then @parms else @eparms;           30625000
            createsyment(*,*,*);  <<create sym. tab. entry>>            30630000
            if < then go nfg;  <<error?>>                               30635000
            if primaryob or primaryproc then                   <<04102>>30640000
               pmapnw:=pmapnw+double(entnamenw+prientpmaplen)  <<04102>>30645000
            else                                               <<04102>>30650000
               pmapnw:=pmapnw+double(entnamenw+secentpmaplen); <<04102>>30655000
            splabel _ cstnr cat sttnr (0:8:8);  <<defining p-label>>    30660000
               case symtype-1 of                                        30665000
               begin                                                    30670000
                                                                        30675000
               <<* * * primary outer block * * *>>                      30680000
                                                                        30685000
               begin                                                    30690000
               if obadr = 0 then                                        30695000
                  begin                                                 30700000
                  obadr _ entfileadr;  <<save o.b. address>>            30705000
                  end                                                   30710000
               else                                                     30715000
                  begin                                                 30720000
                  tos := 61; go error1                                  30725000
                  end;                                                  30730000
               obstackest _ estackest  <<stack estimate>>               30735000
               end;                                                     30740000
                                                                        30745000
               <<* * * secondary outer block * * *>>                    30750000
                                                                        30755000
               begin                                                    30760000
               tos _ entfileadr;  <<save entry address>>                30765000
               getfather;  <<get primary ob entry>>                     30770000
               if obadr <> entfileadr then  <<different ob?>>           30775000
                  begin                                                 30780000
                  tos := 62; go error1                                  30785000
                  end;                                                  30790000
               if obadr = 0 then obadr _ entfileadr;                    30795000
               getentry(*)  <<restore entry>>                           30800000
               end;                                                     30805000
                                                                        30810000
               <<* * * primary procedure * * *>>                        30815000
                                                                        30820000
               begin                                                    30825000
               sxsttnr _ 0;  <<stt nr. of p-label>>                     30830000
               @parms := @sparms;  <<save parm. info pointer>>          30835000
               if estackest > procstackest then                         30840000
                  procstackest _ estackest  <<stack estimate>>          30845000
               end;                                                     30850000
                                                                        30855000
               <<* * * secondary procedure * * *>>                      30860000
                                                                        30865000
               begin                                                    30870000
               sxsttnr := 0  <<stt nr. of p-label>>                     30875000
               end                                                      30880000
               end;                                                     30885000
                                                                        30890000
            <<* * * process code module * * *>>                         30895000
                                                                        30900000
            if bitmap5&csr(enttype) then  <<code module?>>              30905000
               begin                                                    30910000
               tos _ ecode;  <<code module descriptor>>                 30915000
               if < then  <<fatal error?>>                              30920000
                  begin                                                 30925000
                  tos := 46; go errors1                                 30930000
                  end;                                                  30935000
               testbit1;                                                30940000
               if <> then warns(47,ename);  <<non-fatal error?>>        30945000
               if not programfile then  <<sl segment?>>                 30950000
                  begin                                                 30955000
                  assemble(adds 4);                                     30960000
                  move as3 _ etpdb,(4);                                 30965000
                  assemble(or,or; or,del);                              30970000
                  if <> then  <<global storage required?>>              30975000
                     begin                                              30980000
                     tos := 14; go errors1                              30985000
                     end                                                30990000
                  end;                                                  30995000
               seglen _ tos.(2:14)+seglen;  <<adj. segment length>>     31000000
               if overflow then                                         31005000
                 begin getsegentry;go bigseg; end;                      31010000
               ssapust _ nwsdb;  <<s.a. of pust>>                       31015000
               tos _ enwpust;  <<pust length>>                          31020000
               if <> then  <<is there a pust?>>                         31025000
                  begin                                                 31030000
                  nwstlt _ nwstlt+1;  <<adj. stlt length>>              31035000
                  if primaryob then obpustadr _ nwsdb;  <<pust adr.>>   31040000
                  if s0 > nwpustbuf then nwpustbuf _ s0  <<new max.?>>  31045000
                  end;                                                  31050000
               ssasdb _ tos+nwsdb;  <<s.a. of sdb/own/data array>>      31055000
               nwpdb _ nwpdb+etpdb;  <<nr. words primary db>>           31060000
               nwsdb _ nwsdb+etsdb;  <<nr. words secondary db>>         31065000
               if overflow then  <<too much db?>>                       31070000
                  begin                                                 31075000
                  tos := 38; go error1                                  31080000
                  end;                                                  31085000
                                                                        31090000
               <<* * * process headers * * *>>                          31095000
                                                                        31100000
               while getnextheader(false,bitmap7) do                    31105000
                  begin                                                 31110000
                  go headersw(headtype-6); go ok;                       31115000
                                                                        31120000
                  h6:   header6; go ok;  <<global variable>>            31125000
                  h7:   if not programfile then  <<sl segment?>>        31130000
                           begin                                        31135000
                           tos := 111; go errors1                       31140000
                           end;                                         31145000
                        go ok;  <<external variable>>                   31150000
                  h9:   if not programfile then  <<sl segment?>>        31155000
                           begin                                        31160000
                           tos := 112; go errors1                       31165000
                           end;                                         31170000
                        header9s; go test;  <<common array>>            31175000
                  h10:  if not programfile then  <<sl segment?>>        31180000
                           begin                                        31185000
                           tos := 113; go errors1                       31190000
                           end;                                         31195000
                        header10s; go ok; <<logical units>>             31200000
                  hsi:  siseen := true; go ok;                 <<04102>>31205000
                  h15:  sttppnr := sttppnr + (headnw & lsr(1));<<02817>>31210000
                        go ok;                                 <<02817>>31215000
                                                                        31220000
                  test: if < then go nfg;  <<error?>>                   31225000
                  ok:                                                   31230000
                  end;                                                  31235000
               end;                                                     31240000
            sttnr _ sttnr+1  <<bump stt number>>                        31245000
            end;                                                        31250000
                                                                        31255000
      <<* * * check validity of segment * * *>>                         31260000
                                                                        31265000
      if seglen > maxcode then  <<code segment overflow?>>              31270000
         begin                                                          31275000
       bigseg:                                                          31280000
         tos:=40;                                                       31285000
         go errors1                                                     31290000
         end;                                                           31295000
      if sttnr + sttppnr > 256 then  << stt overflow? >>       <<02817>>31300000
         begin                                                          31305000
         tos:=41;                                                       31310000
         go errors1                                                     31315000
         end                                                            31320000
      end;                                                              31325000
   tos := cce;  <<ok condition code>>                                   31330000
   go getout;                                                           31335000
                                                                        31340000
   error1: error(*); go nfg;                                            31345000
   errors1: errors(*,ename);                                            31350000
                                                                        31355000
   nfg:                                                                 31360000
   tos := ccl;  <<error condition code>>                                31365000
                                                                        31370000
   getout:                                                              31375000
   condcode := tos  <<store condition code>>                            31380000
   end;                                                                 31385000
$page "CODE SEGMENT PREPARATION PROCEDURES - GETCHECKSUM"               31390000
$control segment=seg21                                                  31395000
procedure getchecksum(fnum,segrecord,codelength,checksum);     <<04257>>31400000
value fnum,segrecord,codelength;                               <<04257>>31405000
integer fnum,segrecord,codelength;                             <<04257>>31410000
logical checksum;                                              <<04257>>31415000
                                                               <<04257>>31420000
<< this procedure generates the checksum for a segment. >>     <<04257>>31425000
<<   fnum      : program or sl file num where segment   >>     <<04257>>31430000
<<               resides.                               >>     <<04257>>31435000
<<   segrecord : segment beginning record number.       >>     <<04257>>31440000
<<   codelength : segment code length.                  >>     <<04257>>31445000
<< algorithm :                                          >>     <<04257>>31450000
<<   checksum := sum of (each instruction xor it's      >>     <<07389>>31455000
<<                       offset from pb)                >>     <<04257>>31460000
                                                               <<04257>>31465000
begin                                                          <<04257>>31470000
                                                               <<04257>>31475000
   logical array instrbuf(0:127);                              <<04257>>31480000
   integer instrdisp,recdisp;                                  <<04257>>31485000
                                                               <<04257>>31490000
   checksum:=0;                                                <<04257>>31495000
   instrdisp:=0;                                               <<04257>>31500000
   while codelength > instrdisp do                             <<04257>>31505000
      begin                                                    <<04257>>31510000
         freaddir'(fnum,instrbuf,segrecord);                   <<04257>>31515000
         recdisp:=0;                                           <<04257>>31520000
         while recdisp < 128 and codelength > instrdisp do     <<04257>>31525000
            begin                                              <<04257>>31530000
               checksum:= checksum +                           <<04257>>31535000
                          (instrbuf(recdisp) xor               <<07389>>31540000
                          logical(instrdisp));                 <<04257>>31545000
               recdisp:=recdisp+1;                             <<04257>>31550000
               instrdisp:=instrdisp+1;                         <<04257>>31555000
            end;                                               <<04257>>31560000
         segrecord:=segrecord+1;                               <<04257>>31565000
      end;                                                     <<04257>>31570000
   if programfile then                                         <<04257>>31575000
      totalcksum:=integer(logical(totalcksum)+checksum);       <<04257>>31580000
end;                                                           <<04257>>31585000
$page "CODE SEGMENT PREPARATION PROCEDURES - PREPARESEGMENT"   <<00207>>31590000
$ control segment = seg21                                               31595000
procedure preparesegment (segadr,codefnum,coderecd);                    31600000
   <<this procedure scans a segment and prepares it's code segment.     31605000
     takes:                                                             31610000
         the segment entry address in the usl file (segadr)             31615000
         the file number where the code is to be placed (codefnum)      31620000
         the record number where the code is to start (coderecd)        31625000
     the following global variables need to be initialized before       31630000
     the procedure is entered:                                          31635000
         cstnr - the logical segment number of the segment              31640000
         sttnr - the first available stt entry in the segment           31645000
     when the procedure is finished the following global variables      31650000
     have been adjusted:                                                31655000
         segflags - segment attributes                                  31660000
         seglen - the final segment length (including the stt)          31665000
     note that this procedure uses the condition code to indicate       31670000
     an error>>                                                         31675000
   value segadr,codefnum,coderecd;                                      31680000
   integer segadr,codefnum,coderecd;                                    31685000
   begin                                                                31690000
   define exitproc = assemble(exit 3)#;                                 31695000
   switch headersw :=  h1,  h2,  h3,  h4,  ok,                 <<02817>>31700000
                       ok,  h7,  h8,  h9,  ok,                 <<02817>>31705000
                      h11,  si,  si,  si, h15;                 <<04102>>31710000
   byte array b0 (0:37)=pb := "   NAME            STT  CODE ENTRY SEG"; 31715000
   integer array pmaprecord(0:maxpmapreclen-1);                <<04102>>31720000
   logical       firstsi;         << false after first si      <<04102>>31725000
                                  << header in each procedure  <<04102>>31730000
                                  << is processed.             <<04102>>31735000
   integer       segnamenw;       << # words used by seg name ><<04102>>31740000
                                                                        31745000
   subroutine header8;                                                  31750000
      <<header type 8 for primary db values>>                           31755000
      begin                                                             31760000
      if nwpdb = 0 then return;                                <<06557>>31765000
      tos _ 0;  <<db address>>                                          31770000
      tos _ @headp+headnw-nwpdb+nrcoment;  <<init. value pointer>>      31775000
      tos _ 0;  <<db address>>                                          31780000
      tos _ nwpdb-nrcoment;  <<address counter>>                        31785000
      while <> do                                                       31790000
         begin                                                          31795000
         tos _ ps2(s1);  <<init. value>>                                31800000
         if testbit(headp(1),s2&lsl(1)) then  <<data label?>>           31805000
            begin                                                       31810000
            tos _ tos+sdbadr;  <<correct word data label>>              31815000
            if testbit(headp(1),s2&lsl(1)+1) then tos _ tos+sdbadr      31820000
            end;                                                        31825000
         ps3(s2) _ tos;  <<insert init. value>>                         31830000
         assemble(incb,deca)                                            31835000
         end;                                                           31840000
      tos _ tos+1;  <<put 1 on tos>>                                    31845000
      bufferdatawords(*,*,*,*)                                          31850000
      end;                                                              31855000
                                                                        31860000
   condcode _ ccl;  <<error condition code>>                            31865000
   segflags _ 0;  <<init. segment flags>>                               31870000
   segfnum _ codefnum;  <<file nr. for code segment>>                   31875000
   segrecd _ coderecd;  <<starting rec. nr. of segment>>                31880000
   seglen _ 0;  <<init. segment length>>                                31885000
   tfnum1 _ codefnum; trecd1 _ coderecd; tdisp1 _ 0;                    31890000
   getentry(segadr);  <<get segment entry>>                             31895000
   if active then  <<segment active?>>                                  31900000
      begin                                                             31905000
                                                               <<04102>>31910000
      <<* * * build pmap segment record. * * *>>               <<04102>>31915000
                                                               <<04102>>31920000
      if fpmap then begin                                      <<04102>>31925000
      namenw:=entnamenw;                                       <<04102>>31930000
      move ipmap'name := ename,(entnamenw);                    <<04102>>31935000
      ipmap'type := pmapsegtype;                               <<04102>>31940000
      ipmap'sttlen := 0;                                       <<04102>>31945000
      ipmap'segnum := 0;                                       <<04102>>31950000
      ipmap'seglen := 0;                                       <<04102>>31955000
      end;                                                     <<04102>>31960000
      << record will be written when first active procedure is <<04102>>31965000
      << detected.                                             <<04102>>31970000
                                                                        31975000
      <<* * * process segment name * * *>>                              31980000
                                                                        31985000
      tos _ @bline; tos _ @ename&lsl(1)+1;                              31990000
      move * _ *,(entnc);  <<segment name>>                             31995000
      ntoa(cstnr,8,bline(18));  <<segment nr.>>                         32000000
      tos _ @stt; ps0 _ -1;  <<init. stt array>>                        32005000
      assemble(dup,decb); tos _ -255; assemble(move 3);                 32010000
      while getactivefamily(segadr) do                         <<02815>>32015000
         if active then  <<entry point active?>>                        32020000
            begin                                                       32025000
            segprinted _ 1;  <<segment name bit>>                       32030000
            if = then  <<print segment name?>>                          32035000
               begin                                                    32040000
               printline;  <<print segment name>>                       32045000
               move bline := b0,(38);  <<column headings>>              32050000
               printline;                                               32055000
               if fpmap then                                   <<04102>>32060000
               corebufpmap(pmaprecord,namenw+segpmaplen);      <<04102>>32065000
               end;                                                     32070000
                                                                        32075000
            <<* * * get entry point address * * *>>                     32080000
                                                                        32085000
            if bitmap5&csr(enttype) then  <<code module?>>              32090000
               begin                                                    32095000
               unitadr _ seglen;  <<s.a. of prog. unit code in seg.>>   32100000
               seglen _ seglen+enwc <<adj. segment length>>             32105000
               end;                                                     32110000
                                                                        32115000
            <<* * * process entry point * * *>>                         32120000
                                                                        32125000
            searchsym(ename,if (2 <= enttype <= 3)                      32130000
               then symob else symproc);  <<get sym. tab. entry>>       32135000
            symtabadr _ @symp;  <<current sym. tab. adr.>>              32140000
            xreg := if primaryob or primaryproc then 2 else 1;          32145000
            tos _ entp1(xreg);  <<s.a. of entry point>>                 32150000
            if (2 <= enttype <= 3) then ssacode _ unitadr+s0;           32155000
            entrypoint(*);  <<print entry name>>                        32160000
                                                               <<04102>>32165000
            <<* * * build pmap entry point record. * * *>>     <<04102>>32170000
                                                               <<04102>>32175000
            if fpmap then                                      <<04102>>32180000
            if primaryob or primaryproc then                   <<04102>>32185000
               begin                                           <<04102>>32190000
               move ipmap'name := ename,(entnamenw);           <<04102>>32195000
               namenw:=entnamenw;                              <<04102>>32200000
               ipmap'type := pmapproctype;                     <<04102>>32205000
               ipmap'flags:= 0;                                <<04102>>32210000
               if hidden then ipmap'hidden:=1;                 <<04102>>32215000
               ipmap'procstart:=unitadr;                       <<04102>>32220000
               ipmap'proclen:=enwc;                            <<04102>>32225000
               ipmap'procentry:=unitadr+epusa;                 <<04102>>32230000
               ipmap'tboxlink1:=0; <<known later>>             <<04102>>32235000
               ipmap'tboxlink2:=0;                             <<04102>>32240000
               ipmap'tboxid:=0;                                <<04102>>32245000
               << corebufpmap will be done after toolboxid is  <<04102>>32250000
               << known.                                       <<04102>>32255000
               end                                             <<04102>>32260000
            else                                               <<04102>>32265000
               begin                                           <<04102>>32270000
               move ipmap'name := ename,(entnamenw);           <<04102>>32275000
               namenw:=entnamenw;                              <<04102>>32280000
               ipmap'type := pmapsectype;                      <<04102>>32285000
               ipmap'flags:= 0;                                <<04102>>32290000
               if hidden then ipmap'hidden:=1;                 <<04102>>32295000
               ipmap'secentry:=unitadr+epusepa;                <<04102>>32300000
               ipmap'secentnum:=0;                             <<04102>>32305000
               corebufpmap(pmaprecord,entnamenw+secentpmaplen);<<04102>>32310000
               end;                                            <<04102>>32315000
                                                                        32320000
            <<* * * process code module * * *>>                         32325000
                                                                        32330000
            if bitmap5&csr(enttype) then                                32335000
               begin                                                    32340000
               tos _ segflags;  <<load flag word>>                      32345000
               if privledged then                                       32350000
                  begin                                                 32355000
                  if not usercap2.(9:1) then  <<no capability?>>        32360000
                     begin                                              32365000
                     error(44);                                         32370000
                     return                                             32375000
                     end;                                               32380000
                  setbit0                                               32385000
                  end;                                                  32390000
               if warning then setbit1;                                 32395000
               segflags _ tos;                                          32400000
               sdbadr _ nwpdb+ssasdb;  <<s.a. of sec. db array>>        32405000
               formatadr _ sdbadr+enwsdb;  <<s.a of format area>>       32410000
                                                                        32415000
               <<* * * process pust header * * *>>                      32420000
                                                                        32425000
               if enwpust <> 0 then  <<is there a pust?>>               32430000
                  begin                                                 32435000
                  nwstlt _ nwstlt+1;  <<adj. stlt length>>              32440000
                  while getnextheader(false,%(2)100000) do              32445000
                     begin                                              32450000
                     if headp(1) <> -1 then  <<patch code?>>            32455000
                        begin                                           32460000
                        createpatchent(4,unitadr+headp(1));             32465000
                        if < then return;  <<error?>>                   32470000
                        patchp(2) _ nwpdb+ssapust  <<s.a. of pust>>     32475000
                        end;                                            32480000
                     move pustbuf(2) _ headp,(headnw);  <<move header>> 32485000
                     tos _ nwpdb+ssasdb;  <<f.a.+1 of pust>>            32490000
                     tos _ unitadr+epusa;  <<s.a. prim. entry point>>   32495000
                     pustdbuf _ tos;                                    32500000
                     tos _ unitadr;  <<s.a. of code module>>            32505000
                     tos _ unitadr+enwc;  <<f.a.+1 of code module>>     32510000
                     pustdbuf(1) _ tos                                  32515000
                     end;                                               32520000
                  uslentryparms  <<restore entry parm's>>               32525000
                  end;                                                  32530000
                                                                        32535000
               <<* * * process headers and code * * *>>                 32540000
                                                                        32545000
               firstsi := true;                                <<04102>>32550000
               while getnextheader(true,bitmap9) do                     32555000
                  begin                                                 32560000
                  xreg _ headtype;                                      32565000
                  if < then  <<code module?>>                           32570000
                     corebuf1(headp,headnw)                             32575000
                  else                                                  32580000
                     begin                                              32585000
                     go headersw(xreg-1); go ok;                        32590000
                                                                        32595000
                     h1: header1p(false); go test;  <<pcal>>            32600000
                     h2: header2p; go test;  <<pb address>>             32605000
                     h3: header3p; go test;  <<own/data variables>>     32610000
                     h4: header4p; go ok;  <<sdb/own/data values>>      32615000
                     h7: header7p; go test;  <<external variable>>      32620000
                     h8: header8; go ok;  <<primary db values>>         32625000
                     h9: header9p; go test;  <<common array>>           32630000
                     h11: header11p; go test;  <<format string>>        32635000
                     si:  headersip(firstsi); << toolbox header<<04102>>32640000
                          go ok;                               <<04102>>32645000
                     h15: header15p; go test;  << private proc.<<02817>>32650000
                                                                        32655000
                     test: if < then return;  <<error?>>                32660000
                     ok:                                                32665000
                     end                                                32670000
                  end;                                                  32675000
                                                               <<04102>>32680000
               <<* * * finish pmap procedure record. * * *>>   <<04102>>32685000
                                                               <<04102>>32690000
               if fpmap then begin                             <<04102>>32695000
               if not firstsi then                             <<04102>>32700000
                  ipmap'tboxid:=toolboxid;                     <<04102>>32705000
               corebufpmap(pmaprecord,entnamenw+prientpmaplen);<<04102>>32710000
               end;                                            <<04102>>32715000
                                                                        32720000
               <<* * * insert pust in program file * * *>>              32725000
                                                                        32730000
               if enwpust <> 0 then  <<was there a pust?>>              32735000
                  begin                                                 32740000
                  @symp _ symtabadr;  <<current sym. tab. entry>>       32745000
                  symentparms;                                          32750000
                  bufferdatawords(nwpdb+ssapust,pustbuf,enwpust,1)      32755000
                  end                                                   32760000
               end                                                      32765000
            end;                                                        32770000
                                                                        32775000
      <<* * * append stt to segment and clean up * * *>>                32780000
                                                                        32785000
      appendstt(coderecd);                                     <<04257>>32790000
      if < then return  <<error?>>                                      32795000
      end;                                                              32800000
   condcode _ cce  <<ok condition code>>                                32805000
   end;                                                                 32810000
$page "CODE SEGMENT PREPARATION PROCEDURES - ENTRYPOINT"       <<00207>>32815000
$ control segment = seg21                                               32820000
procedure entrypoint (saentry);                                         32825000
   <<prints the entry point name and inserts the local p-label in the   32830000
     stt.  it is assumed that the current symbol table entry is that    32835000
     of the entry point>>                                               32840000
   value saentry;                                                       32845000
   integer saentry;                                                     32850000
   begin                                                                32855000
   tos _ @bline(3); tos _ @sname&lsl(1)+1;                              32860000
   move * _ *,(symnc);  <<entry point name>>                            32865000
   ntoa(ssttnr,8,bline(21));  <<stt nr.>>                               32870000
   ntoa(unitadr,8,bline(27));  <<s.a. of code module>>                  32875000
   ntoa(unitadr+saentry,8,bline(33));  <<s.a. of entry point>>          32880000
   printline;                                                           32885000
   stt(-ssttnr) _ (unitadr+saentry) cat sname (1:1:1)  <<p-label>>      32890000
   end;                                                                 32895000
$page "CODE SEGMENT PREPARATION PROCEDURES - APPENDSTT"        <<00207>>32900000
$ control segment = seg21                                               32905000
procedure appendstt(coderecd);                                 <<04257>>32910000
value coderecd;                                                <<04257>>32915000
integer coderecd;                                              <<04257>>32920000
   <<checks the validity of the prepared segment, appends the stt to    32925000
     the code segment and fixes the external stt nr. entries in the     32930000
     symbol table>>                                                     32935000
   begin                                                                32940000
logical checksum;                                              <<04257>>32945000
integer codelen;                                               <<04257>>32950000
integer cksumdisp,cksumrecd;                                   <<04257>>32955000
integer temppatch;                                             <<04127>>32960000
   byte array b0 (0:13)=pb _ "SEGMENT LENGTH";                          32965000
   logical bitmap0 _ %(2)0000111100011000;                              32970000
   array patchbuf(0:127);                                      <<00629>>32975000
   integer pointer pasegname := @patchbuf;                     <<00629>>32980000
   double pointer dpasegname = pasegname;                      <<00629>>32985000
   define                                                      <<00629>>32990000
      paprogname   = patchbuf#,                                <<00629>>32995000
      paspare      = pasegname(8)#,                            <<00629>>33000000
      pachecksum   = pasegname(9)#,                            <<00629>>33005000
      papreptime   = dpasegname(5)#,                           <<00629>>33010000
      papatchtime  = dpasegname(6)#;                           <<00629>>33015000
                                                               <<00629>>33020000
   codelen:=seglen;                                            <<04257>>33025000
   temppatch :=initpatch;                                      <<04127>>33030000
   tos _ seglen;  <<segment length>>                                    33035000
   if <> then  <<non-null segment?>>                                    33040000
      begin                                                             33045000
      if initpatch >= 0 then  <<append a patch area?>>         <<00629>>33050000
         begin                                                 <<00629>>33055000
         if initpatch > maxcode then go toobig;                <<00629>>33060000
         seglen := tos+initpatch+sttnr+(if programfile then 19 <<00629>>33065000
                   else 15);                                   <<00629>>33070000
         tos := seglen.(14:2);                                 <<00629>>33075000
         if <> then assemble(ldi 4;xch,sub); <<padding>>       <<00629>>33080000
         seglen := seglen+s0;  <<final segment length>>        <<00629>>33085000
         initpatch := initpatch+tos;<<expand patch by padding>><<00629>>33090000
         if not programfile then  <<sl file?>>                 <<00629>>33095000
            move pasegname := slrsegname,(8)                   <<00629>>33100000
         else                                                  <<00629>>33105000
            begin                                              <<00629>>33110000
            <<blank program name and segment name>>            <<00629>>33115000
            tos := @paprogname;  ps0 := "  ";                  <<00629>>33120000
            assemble(dup,incb); tos := 11; assemble(move 3);   <<00629>>33125000
            tos := @paprogname&lsl(1);                         <<00629>>33130000
            move * := bfilename while ans; <<program name>>    <<00629>>33135000
            @pasegname := @paprogname+4;                       <<00629>>33140000
            tos := @pasegname&lsl(1);                          <<00629>>33145000
            tos := @ename&lsl(1)+1;                            <<00629>>33150000
            move * := *,(entnc);  <<segment name>>             <<00629>>33155000
            end;                                               <<00629>>33160000
         paspare := 0;                                         <<00629>>33165000
         pachecksum := 0;                                      <<00629>>33170000
         tos := calendar;                                      <<00629>>33175000
         tos := clock;                                         <<00629>>33180000
         del;  <<del secs, tenths of secs>>                    <<00629>>33185000
         papreptime := tos;                                    <<00629>>33190000
         papatchtime := 0d;                                    <<00629>>33195000
         cksumdisp:=tdisp1+(if programfile then 13             <<04257>>33200000
                            else 9);                           <<04257>>33205000
         cksumrecd:=trecd1;                                    <<04257>>33210000
         if cksumdisp >= 128 then                              <<04257>>33215000
            begin                                              <<04257>>33220000
               cksumrecd:=cksumrecd+1;                         <<04257>>33225000
               cksumdisp:=cksumdisp-128;                       <<04257>>33230000
            end;                                               <<04257>>33235000
                                                               <<04257>>33240000
         corebuf1(patchbuf,if programfile then 18 else 14);    <<00629>>33245000
         <<initialize patch area to halt 16's>>                <<00629>>33250000
         tos := @patchbuf;  ps0 := %30376;                     <<00629>>33255000
         assemble(dup,incb); tos := 127; assemble(move 3);     <<00629>>33260000
         tos := initpatch;                                     <<00629>>33265000
         while s0 > 128 do                                     <<00629>>33270000
            begin                                              <<00629>>33275000
            corebuf1(patchbuf,128);                            <<00629>>33280000
            tos := tos-128;                                    <<00629>>33285000
            end;                                               <<00629>>33290000
         corebuf1(patchbuf,s0);                                <<00629>>33295000
         corebuf1(initpatch,1);                                <<00629>>33300000
         assemble(del,zero); <<padding already done!>>         <<00629>>33305000
         end                                                   <<00629>>33310000
      else                                                     <<00629>>33315000
         begin                                                 <<00629>>33320000
         tos _ (tos+sttnr+3)&lsr(2)&lsl(2)-seglen-sttnr;  <<padding>>   33325000
         seglen _ seglen+sttnr+s0;  <<final segment length>>            33330000
         end;                                                  <<00629>>33335000
                                                                        33340000
      <<* * * append stt to code segment * * *>>                        33345000
                                                                        33350000
      if sttnr > p256 then  <<stt overflow?>>                           33355000
         begin                                                          33360000
         error(41);                                                     33365000
         go nfg                                                         33370000
         end;                                                           33375000
      tos _ sttnr-1;  <<nr. stt entries>>                               33380000
      setbit1;  <<set "UNCALLABLE" bit>>                                33385000
      stt _ tos;                                                        33390000
      corebuf1(stt(1-sttnr-s0),sttnr+s0);  <<append stt>>               33395000
      makepatches;  <<empty patch table>>                               33400000
      if < then go nfg;  <<error?>>                                     33405000
      if tdisp1 <> 0 then fwritedir'(tfnum1,tbuf1,trecd1);              33410000
                                                                        33415000
   if checksumspecified then                                   <<04257>>33420000
      begin                                                    <<04257>>33425000
         getchecksum(tfnum1,coderecd,codelen,checksum);        <<04257>>33430000
         repairrecord'(tfnum1,cksumrecd,cksumdisp,             <<04257>>33435000
                       integer(checksum));                     <<04257>>33440000
         if not programfile and cksumrecd = trecd1 then        <<04552>>33445000
            freaddir'(tfnum1,tbuf1,trecd1); <<update tbuf1>>   <<04552>>33450000
      end;                                                     <<04257>>33455000
      <<* * * print code segment length * * *>>                         33460000
                                                                        33465000
      move bline(3) _ b0,(14);  <<"SEGMENT LENGTH">>                    33470000
      ntoa(seglen,8,bline(27));  <<segment length>>                     33475000
      printline;                                                        33480000
      if seglen > maxcode then  <<segment overflow?>>                   33485000
         begin                                                          33490000
toobig:  error(40);                                            <<00629>>33495000
         go nfg                                                         33500000
         end;                                                           33505000
      if seglen > sdbmaxcode then warn(48);                    <<00.dm>>33510000
                                                                        33515000
      <<* * * fix symbol table procedure entries * * *>>                33520000
                                                                        33525000
      @symp _ @stable;                                                  33530000
      while @symp < @stable(usedsymbol) do                              33535000
         begin                                                          33540000
         symentparms;                                                   33545000
         if bitmap0&csr(symtype) then sxsttnr _ 0;  <<clear stt nr.>>   33550000
         @symp _ @symp+symnw  <<next entry>>                            33555000
         end                                                            33560000
      end;                                                              33565000
   initpatch := temppatch;                                     <<04127>>33570000
   tos _ cce;  <<ok condition code>>                                    33575000
   go getout;                                                           33580000
                                                                        33585000
   nfg:                                                                 33590000
   tos _ ccl;  <<error condition code>>                                 33595000
                                                                        33600000
   getout:                                                              33605000
   condcode _ tos                                                       33610000
   end;                                                                 33615000
$page "CODE SEGMENT PREPARATION PROCEDURES - SCANRL"           <<00207>>33620000
$ control segment = seg23                                               33625000
procedure scanrl;                                                       33630000
   <<this procedure scans the usl to determine which procedures are     33635000
     external and tries to satisfy them using the specified rl library  33640000
     file.  symbol table entries and rl table entries are made for all  33645000
     directly referenced and indirectly referenced rl procedures.  the  33650000
     rl procedures are then scaned to determine their global            33655000
     requirements.  global variables returned:                          33660000
         the next available stt number (sttnr)                          33665000
         the segment length not including the stt (seglen)              33670000
         the global storage requirements (nwsdb)                        33675000
         segflags.(0:1) set if the segment contains priv. instructions  33680000
         segflags.(1:1) set if the segment contains a non-fatal error   33685000
     note that this procedure uses the condition code to indicate an    33690000
     error>>                                                            33695000
   begin                                                                33700000
   array parms(0:4)=q;                                         <<00595>>33705000
   byte array b0 (0:10)=pb _ ":RL SEGMENT";                             33710000
   define exitproc = assemble(exit 0)#;                                 33715000
   switch headersw :=  h1,  ok,  ok,  ok,  ok,                 <<02817>>33720000
                       ok,  ok,  ok,  h9, h10,                 <<02817>>33725000
                       ok, hsi, hsi, hsi, h15;                 <<04102>>33730000
                                                                        33735000
   logical subroutine searchrlib (name);                                33740000
      <<searches the rl library for the entry point having the          33745000
        specified name.  if found, the result true is returned and the  33750000
        entry parameters are set; otherwise the result false is         33755000
        returned>>                                                      33760000
      integer array name;                                               33765000
      begin                                                             33770000
      tos _ rlibrec0(rlfhi+hash(name));  <<first rec. in hash list>>    33775000
      while <> do                                                       33780000
         begin                                                          33785000
         freaddir'(rlibfnum,rlibdir,s0);                                33790000
         @rlibp _ @rlibdir(2);  <<init. entry pointer>>                 33795000
         while @rlibp < @rlibdir+rlibdir(1) do                          33800000
            begin                                                       33805000
            tos _ rlibp.(4:3)+1;  <<nr. words for name>>                33810000
            @rlibp1 _ @rlibp+s0;  <<init. secondary pointer>>           33815000
            tos _ tos+4+parmlen(rlibparms);  <<nr. words for entry>>    33820000
            if ps3.(4:4) = rlibname.(4:4) then  <<nr. char's same?>>    33825000
               begin                                                    33830000
               tos _ @ps3&lsl(1)+1; tos _ @rlibname&lsl(1)+1;           33835000
               if * = *,(rlibname.(4:4)) then  <<name's match?>>        33840000
                  begin                                                 33845000
                  ddel;  <<remove temp's>>                              33850000
                  searchrlib _ true;                                    33855000
                  return                                                33860000
                  end                                                   33865000
               end;                                                     33870000
            @rlibp _ tos+@rlibp  <<next entry>>                         33875000
            end;                                                        33880000
         del;  <<remove rec. nr.>>                                      33885000
         tos _ rlibdir  <<next rec. nr. in hash list>>                  33890000
         end;                                                           33895000
      del  <<remove rec. nr.>>                                          33900000
      end;                                                              33905000
                                                                        33910000
   subroutine createrlent (infoadr,symentry);                           33915000
      <<creates an entry in the rl procedure table and initializes the  33920000
        entry with the address of the info block and the address of the 33925000
        symbol table entry>>                                            33930000
      value infoadr;                                                    33935000
      double infoadr;                                                   33940000
      integer array symentry;                                           33945000
      begin                                                             33950000
      makeroomindl(3);                                                  33955000
      if < then exitproc;  <<error?>>                                   33960000
      @rlentp _ @dlavail;  <<init. entry pointer>>                      33965000
      tos _ @rlentp; tos _ @s4; tos _ 3;                                33970000
      assemble(move 2);                                                 33975000
      @dlavail _ tos;  <<reset available area pointer>>                 33980000
      nrrlent _ nrrlent+1  <<bump nr. entries>>                         33985000
      end;                                                              33990000
                                                                        33995000
   subroutine header1a;                                                 34000000
      <<searches the rl for the given procedure if it is not satisfied  34005000
        already.  if the procedure is satisfiable by the rl, creates    34010000
        a symbol table entry and a rl table entry (if necessary).  if   34015000
        a procedure is determined to be external, a symbol table entry  34020000
        is created at this time>>                                       34025000
      begin                                                             34030000
      if not searchsym(headp(2),symproc) then  <<new external?>>        34035000
         if searchrlib(headp(2)) then  <<satisfied by rl?>>             34040000
            begin                                                       34045000
            tos _ @rlibparms;  <<rl parm. info>>                        34050000
            tos _ @headp(2); tos _ tos+ps0.(4:3)+1;  <<parm info>>      34055000
            parmcheck(*,*,parms);                              <<00595>>34060000
            preperror := preperror+1;                          <<00595>>34065000
            case parms of                                      <<00595>>34070000
               begin                                           <<00595>>34075000
               preperror := preperror-1;                       <<00595>>34080000
               errors2(49,headp(2),ename);                     <<00595>>34085000
               errors2(50,headp(2),ename);                     <<00595>>34090000
               begin                                           <<00595>>34095000
                  errors2(45,headp(2),ename);                  <<00595>>34100000
                  printbitmap(parms(1));                       <<00595>>34105000
               end;                                            <<00595>>34110000
               end;                                            <<00595>>34115000
            if rlibfatal then  <<fatal error?>>                         34120000
               begin                                                    34125000
               errors(46,headp(2));                                     34130000
               exitproc                                                 34135000
               end;                                                     34140000
            if rlibwarning then warns(47,headp(2));  <<non-fatal?>>     34145000
            if searchrltab(rlibinfo) then  <<new entry point?>>         34150000
               begin                                                    34155000
               createsyment(9,rlibname,rlibparms);                      34160000
               if < then exitproc;  <<error?>>                          34165000
               pmapnw:=pmapnw+double(symnamenw+secentpmaplen); <<04102>>34170000
               srlindex := @rlentp-@rltable  <<primary entry index>>    34175000
               end                                                      34180000
            else  <<new procedure>>                                     34185000
               begin                                                    34190000
               createsyment(8,rlibname,rlibparms);                      34195000
               if < then exitproc;  <<error?>>                          34200000
               pmapnw:=pmapnw+double(symnamenw+prientpmaplen); <<04102>>34205000
               srlcode _ rlibcode;  <<code module descriptor>>          34210000
               createrlent(rlibinfo,symp);  <<create rl entry>>         34215000
               seglen _ seglen+rlibnwc;  <<adj seg length>>             34220000
               if overflow then go bigseg;                              34225000
               end;                                                     34230000
            splabel _ cstnr cat sttnr (0:8:8);  <<entry p-label>>       34235000
            sxsttnr _ 0;                                                34240000
            srlentry _ rlibentry;  <<code module entry point>>          34245000
            sttnr _ sttnr+1  <<bump stt nr.>>                           34250000
            end                                                         34255000
         else  <<external procedure>>                                   34260000
            begin                                                       34265000
            tos _ 7;                                                    34270000
            tos _ @headp(2)&lsl(1);                                     34275000
            tos _ @headp(xreg); tos _ tos+ps0.(4:3)+1;                  34280000
            createsyment(*,*,*);  <<create sym. tab. entry>>            34285000
            if < then exitproc;  <<error?>>                             34290000
            sxnl _ 0  <<init. nr. labels>>                              34295000
            end                                                         34300000
      end;                                                              34305000
                                                                        34310000
   subroutine header1b;                                                 34315000
      <<checks to see if the rl external is satisfied within the rl.    34320000
        if so, a symbol table entry is created and a rl table entry is  34325000
        created (if necessary).  note that if the external is not       34330000
        satisfied an external symbol table entry is not created>>       34335000
      begin                                                             34340000
      if logical(headp(6).(0:1)) then  <<satisfied by rl?>>             34345000
         if not searchsym(headp(6),symrlproc) then  <<new entry point?>>34350000
            begin                                                       34355000
            if logical(headp(1).(0:1)) then  <<fatal error?>>           34360000
               begin                                                    34365000
               errors(46,headp(6));                                     34370000
               exitproc                                                 34375000
               end;                                                     34380000
            if logical(headp(1).(1:1)) then warns(47,headp(6));         34385000
            buf := 0;  <<null parm. info>>                              34390000
            if searchrltab(headdp(1)) then  <<new entry point?>>        34395000
               begin                                                    34400000
               createsyment(11,headp(6),buf);  <<create sym. tab. ent.>>34405000
               if < then exitproc;  <<error?>>                          34410000
               pmapnw:=pmapnw+double(symnamenw+secentpmaplen); <<04102>>34415000
               srlindex := @rlentp-@rltable  <<primary entry index>>    34420000
               end                                                      34425000
            else  <<new procedure>>                                     34430000
               begin                                                    34435000
               createsyment(10,headp(6),buf);  <<create sym. tab. ent.>>34440000
               if < then exitproc;  <<error?>>                          34445000
               pmapnw:=pmapnw+double(symnamenw+prientpmaplen); <<04102>>34450000
               srlcode _ headp(1);  <<code module descriptor>>          34455000
               createrlent(headdp(1),symp);  <<create rl table entry>>  34460000
               seglen _ seglen+srlnwc;  <<adj seg length>>              34465000
               if overflow then goto bigseg;                            34470000
               end;                                                     34475000
            splabel _ cstnr cat sttnr (0:8:8);  <<entry p-label>>       34480000
            sxsttnr _ 0;  <<init. extn. p-label stt nr.>>               34485000
            srlentry _ headp(4);  <<code module entry adr.>>            34490000
            sttnr _ sttnr+1  <<bump stt nr.>>                           34495000
            end                                                         34500000
      end;                                                              34505000
                                                                        34510000
   condcode _ ccl;  <<error condition code>>                            34515000
                                                                        34520000
   <<* * * open rl library file * * *>>                                 34525000
                                                                        34530000
  rlibfnum _ fopen(rlibfname,%(2)10000000011,%(2)111110000);            34535000
   if < then  <<error?>>                                                34540000
      begin                                                             34545000
      tos _ 30;                                                         34550000
      tos _ 0d; fcheck(0,s0);                                           34555000
      errorn(*,*);                                                      34560000
      return                                                            34565000
      end;                                                              34570000
                                                                        34575000
   <<* * * check for equality of rl library and rl file * * *>>         34580000
                                                                        34585000
   assemble(dzro,dzro; dzro,zero);                                      34590000
   fgetinfo(rlibfnum,,,,,,s5,,s6,,,,,,,,,,,ds4);                        34595000
   if rlfnum <> 0 then fgetinfo(rlfnum,,,,,,s2,,,,,,,,,,,,,ds1);        34600000
   tos _ @s2&lsl(1); tos _ @s6&lsl(1); tos _ 6;                         34605000
   assemble(cmpb 3);                                                    34610000
   assemble(subs 6);                                                    34615000
   if = then  <<same files?>>                                           34620000
      begin                                                             34625000
      fixuprl;  <<complete any binding>>                                34630000
      tos _ @rlrec0;  <<record 0 buffer>>                               34635000
      tos _ @rldir;  <<directory record buffer>>                        34640000
      tos _ true                                                        34645000
      end                                                               34650000
   else  <<different file>>                                             34655000
      begin                                                             34660000
      flock(rlibfnum,true);  <<get file exclusively>>                   34665000
      makeroomindl(progdlbufs2);                                        34670000
      if < then return;  <<error?>>                                     34675000
      freaddir'(rlibfnum,dlavail,0);  <<read record 0>>                 34680000
      if tos <> rlfilecode or dlavail <> rlfileid then  <<type rl?>>    34685000
         begin                                                          34690000
         error(22);                                                     34695000
         return                                                         34700000
         end;                                                           34705000
      tos _ @dlavail;  <<record 0 buffer>>                              34710000
      tos _ @dlavail+128;  <<directory record buffer>>                  34715000
      @dlavail _ @dlavail+p256;                                         34720000
      tos _ false                                                       34725000
      end;                                                              34730000
   rlibequalrl _ tos;                                                   34735000
   @rlibdir _ tos;                                                      34740000
   @rlibrec0 _ tos;                                                     34745000
   @rltable _ @dlavail;                                                 34750000
                                                                        34755000
   <<* * * get directly referenced rl procedures * * *>>                34760000
                                                                        34765000
   seglen  := 0;                                               <<02817>>34770000
   sttnr   := 1;                                               <<02817>>34775000
   sttppnr := 0;                                               <<02817>>34780000
   tos _ uslsl;  <<first segment entry adr.>>                           34785000
   do begin                                                             34790000
      getentry(s0);  <<get segment entry>>                              34795000
      if active then  <<active segment?>>                               34800000
         while getfamily(s0) do  <<get entry points>>                   34805000
            if active and bitmap5&csr(enttype) then                     34810000
               while getnextheader(false,%(2)10) do                     34815000
                  header1a;  <<pcal header>>                            34820000
      del;                                                              34825000
      tos _ ebl;  <<next segment entry adr.>>                           34830000
      if <> then getbrother;                                            34835000
      end until =;                                                      34840000
                                                                        34845000
   <<* * * get indirectly referenced rl procedures * * *>>              34850000
                                                                        34855000
      @entp:=@rlseg;  << pointer to rl seg entry so >>         <<04780>>34860000
                      << ename is "RLSEG"           >>         <<04780>>34865000
   uslinfoincore _ false;  <<clear flag>>                               34870000
   infoadr _ double(-maxhead);                                          34875000
   headrecd _ -255;                                                     34880000
   tos _ 0;  <<rl entry table index>>                                   34885000
   while @rltable(s0) <> @rltable+3*nrrlent do                          34890000
      begin                                                             34895000
      @rlentp _ @rltable(xreg);  <<init. entry pointer>>                34900000
      @symp _ rlentp(2);  <<init. sym. tab. pointer>>                   34905000
      symentparms;                                                      34910000
      setuprlheaders(rlentdp+3d+double(logical(srlnwc)));      <<04755>>34915000
      ssasdb _ nwsdb;  <<s.a. of sec. db array>>                        34920000
      nwsdb _ nwsdb+headp(3);  <<adj. sec. db count>>                   34925000
      if overflow then  <<data segment overflow?>>                      34930000
         begin                                                          34935000
         error(38);                                                     34940000
         return                                                         34945000
         end;                                                           34950000
      while getnextrlheader do                                          34955000
         begin                                                          34960000
         go headersw(headtype-1); go ok;                                34965000
                                                                        34970000
         h1: header1b; go ok;  <<pcal>>                                 34975000
         h9: header9s; go test;  <<common array>>                       34980000
         h10: header10s; go ok;  <<logical units>>                      34985000
         hsi: siseen := true; go ok;                           <<04102>>34990000
         h15: sttppnr := sttppnr + (headnw & lsr(1)); go ok;   <<02817>>34995000
                                                                        35000000
         test: if < then return;  <<error?>>                            35005000
         ok:                                                            35010000
         end;                                                           35015000
      tos _ tos+3  <<next entry index>>                                 35020000
      end;                                                              35025000
                                                                        35030000
   <<* * * check validity of segment * * *>>                            35035000
                                                                        35040000
   if seglen>maxcode then                                               35045000
     begin bigseg: tos_40; go rlsegerror; end;                          35050000
   if sttnr + sttppnr > 256 then  << stt overflow? >>          <<02817>>35055000
     begin tos_41;go rlsegerror; end;                                   35060000
   goto lok;                                                            35065000
                                                                        35070000
 rlsegerror:                                                            35075000
   move bbuf_b0,(11);                                                   35080000
   errors(*,buf);                                                       35085000
   return;                                                              35090000
                                                                        35095000
 lok:                                                                   35100000
   condcode _ cce  <<ok condition code>>                                35105000
   end;                                                                 35110000
$page "CODE SEGMENT PREPARATION PROCEDURES - PREPARERL"        <<00207>>35115000
$ control segment = seg23                                               35120000
procedure preparerl (coderecd);                                         35125000
   <<this procedure composes the rl code segment and initializes the    35130000
     global variables associated with the rl procedures.  the code      35135000
     segment is placed in the program file beginning at record segrecd. 35140000
     global variables returned:                                         35145000
         segflags.(0:1) set if the segment contains priv. instructions  35150000
         segflags.(1:1) if the segment contains a non-fatal error       35155000
     note that this procedure uses the condition code to indicate an    35160000
     error>>                                                            35165000
   value coderecd;                                                      35170000
   integer coderecd;                                                    35175000
   begin                                                                35180000
   byte array b0 (0:9)=pb _ "RL SEGMENT";                               35185000
   switch headersw :=  h1,  h2,  h3,  h4,  ok,                 <<02817>>35190000
                       ok,  h7,  ok,  h9,  ok,                 <<02817>>35195000
                      h11, hsi, hsi, hsi, h15;                 <<04102>>35200000
   integer array pmaprecord(0:maxpmapreclen-1);                <<04102>>35205000
   byte    array pmaprecordb(*) = pmaprecord;                  <<04102>>35210000
   logical    firstsi;            << false after first si >>   <<04102>>35215000
                                  << header in each procedure  <<04102>>35220000
                                  << is processed.             <<04102>>35225000
   condcode _ ccl;  <<error condition code>>                            35230000
   segflags _ 0;  <<init. segment flags>>                               35235000
   tos _ coderecd; assemble(zero,ddup);                                 35240000
   seglen _ tos; segrecd _ tos;                                         35245000
   tdisp1 _ tos; trecd1 _ tos;                                          35250000
   infoadr _ double(-maxhead);                                          35255000
   headrecd _ -255;                                                     35260000
                                                                        35265000
   <<* * * process segment name * * *>>                                 35270000
                                                                        35275000
   move bline _ b0,(10);  <<"RL SEGMENT">>                              35280000
   ntoa(cstnr,8,bline(18));  <<segment nr.>>                            35285000
                                                               <<04102>>35290000
   <<* * * build pmap segment record. * * *>>                  <<04102>>35295000
                                                               <<04102>>35300000
   if fpmap then begin                                         <<04102>>35305000
   move pmaprecordb(1):="$RL0";                                <<04102>>35310000
   namenw:=3;                                                  <<04102>>35315000
   ipmap'type:=pmapsegtype;                                    <<04102>>35320000
   ipmap'namenumch:=4;                                         <<04102>>35325000
   ipmap'sttlen:=0;                                            <<04102>>35330000
   ipmap'segnum:=0;                                            <<04102>>35335000
   ipmap'seglen:=0;                                            <<04102>>35340000
   end;                                                        <<04102>>35345000
   << the record will be written when first procedure is de-   <<04102>>35350000
   << tected.                                                  <<04102>>35355000
                                                                        35360000
   <<* * * process rl procedures * * *>>                                35365000
                                                                        35370000
   tos _ @stt; ps0 _ -1;  <<init. stt array>>                           35375000
   assemble(dup,decb); tos _ -255; assemble(move 3);                    35380000
   @rlentp _ @rltable;  <<init. entry pointer>>                         35385000
   tos _ nrrlent;  <<entry counter>>                                    35390000
   while <> do                                                          35395000
      begin                                                             35400000
      segprinted _ 1;  <<segment name bit>>                             35405000
      if = then                                                <<04102>>35410000
         begin                                                 <<04102>>35415000
         printline;               << print segment name >>     <<04102>>35420000
         if fpmap then                                         <<04102>>35425000
         corebufpmap(pmaprecord,3+segpmaplen);<<$rl0 rec>>     <<04102>>35430000
         end;                                                  <<04102>>35435000
      @symp _ rlentp(2);  <<init. entry pointer>>                       35440000
      symentparms;                                                      35445000
      symtabadr _ @symp;  <<save sym. tab. entry adr.>>                 35450000
                                                                        35455000
      <<* * * process procedure entry points * * *>>                    35460000
                                                                        35465000
      unitadr _ seglen;  <<s.a of code module>>                         35470000
      seglen _ seglen+srlnwc;  <<adj. segment length>>                  35475000
      entrypoint(srlentry);  <<print entry name>>                       35480000
                                                               <<04102>>35485000
      <<* * * build pmap procedure record. * * *>>             <<04102>>35490000
                                                               <<04102>>35495000
      if fpmap then  begin                                     <<04102>>35500000
               move ipmap'name := sname,(symnamenw);           <<04102>>35505000
               namenw:=symnamenw;                              <<04102>>35510000
               ipmap'type := pmapproctype;                     <<04102>>35515000
               ipmap'flags:= 0;                                <<04102>>35520000
               ipmap'procstart:=unitadr;                       <<04102>>35525000
               ipmap'proclen:=srlnwc;                          <<04102>>35530000
               ipmap'procentry:=unitadr+srlentry;              <<04102>>35535000
               ipmap'tboxlink1:=0; <<known later>>             <<04102>>35540000
               ipmap'tboxlink2:=0;                             <<04102>>35545000
               ipmap'tboxid:=0;                                <<04102>>35550000
      end;                                                     <<04102>>35555000
                                                               <<04102>>35560000
      @symp _ @stable;                                                  35565000
      while @symp < @stable(usedsymbol) do                              35570000
         begin                                                          35575000
         symentparms;                                                   35580000
         if (symtype = 9 or  symtype = 11) and                          35585000
            srlindex = @rlentp-@rltable then                            35590000
            entrypoint(srlentry);  <<print entry point>>                35595000
         @symp _ @symp+symnw  <<next entry>>                            35600000
         end;                                                           35605000
      @symp _ symtabadr;  <<restore entry pointer>>                     35610000
      symentparms;                                                      35615000
                                                                        35620000
      <<* * * process code module * * *>>                               35625000
                                                                        35630000
      tos _ (rlentdp+3d)&dlsl(9);                                       35635000
      tos _ tos&lsr(9);                                                 35640000
      if s0+srlnwc+6 < maxhead then  <<fits into buffer?>>              35645000
         begin                                                          35650000
         freadmr''(rlibfnum,head,maxhead,s1);                           35655000
         corebuf1(head(s0),srlnwc);                            <<04755>>35660000
         @headp _ tos+@head+srlnwc;  <<init. header pointer>>  <<04755>>35665000
         headrecd _ tos;  <<save rec. nr.>>                             35670000
         headnw _ 6  <<phoney header length>>                           35675000
         end                                                            35680000
      else                                                              35685000
         begin                                                          35690000
         masterbuf(progfnum,rlibfnum,tbuf1,trecd1,tdisp1,               35695000
            true,rlentdp+3d,buf,srlnwc);                       <<04755>>35700000
         setuprlheaders(rlentdp+3d+double(logical(srlnwc)));   <<04755>>35705000
         ddel                                                           35710000
         end;                                                           35715000
      tos _ segflags;                                                   35720000
      if sprivileged then  <<priv. mode?>>                              35725000
         begin                                                          35730000
         if not usercap2.(9:1) then  <<has capability?>>                35735000
            begin                                                       35740000
            error(44);                                                  35745000
            return                                                      35750000
            end;                                                        35755000
         setbit0                                                        35760000
         end;                                                           35765000
      if srlwarning then setbit1;  <<non-fatal error?>>                 35770000
      segflags _ tos;                                                   35775000
                                                                        35780000
      <<* * * process headers * * *>>                                   35785000
                                                                        35790000
      sdbadr _ nwpdb+ssasdb;  <<s.a. of sec. db array>>                 35795000
      formatadr _ sdbadr+headp(4);  <<s.a. of format area>>             35800000
      firstsi := true;                                         <<04102>>35805000
      while getnextrlheader do                                          35810000
         begin                                                          35815000
         go headersw(headtype-1); go ok;                                35820000
                                                                        35825000
         h1:   @headp _ @headp+4;  <<adj. header pointer>>              35830000
               header1p(true);  <<pcal>>                                35835000
               if < then return;  <<error?>>                            35840000
               @headp _ @headp-4;  <<reset header pointer>>             35845000
               go ok;                                                   35850000
         h2: header2p; go test;  <<pb address>>                         35855000
         h3: header3p; go test;  <<own/data variables>>                 35860000
         h4: header4p; go ok;  <<sdb/own/data values>>                  35865000
         h7: header7p; go test;  <<external variable>>                  35870000
         h9: header9p; go test;  <<common array>>                       35875000
         h11: header11p; go test;  <<format string>>                    35880000
         hsi: headersip(firstsi); go ok; << toolbox si >>      <<04102>>35885000
         h15: header15p; go test; << private procs >>          <<02817>>35890000
                                                                        35895000
         test: if < then return;  <<error?>>                            35900000
         ok:                                                            35905000
         end;                                                           35910000
                                                               <<04102>>35915000
      <<* * * finish pmap procedure record. * * *>>            <<04102>>35920000
                                                               <<04102>>35925000
      if fpmap then  begin                                     <<04102>>35930000
      @symp := rlentp(2) ;        << restore entry pointer >>  <<04102>>35935000
      symentparms;                                             <<04102>>35940000
      if not firstsi then                                      <<04102>>35945000
         ipmap'tboxid:=toolboxid;                              <<04102>>35950000
      corebufpmap(pmaprecord,symnamenw+prientpmaplen);         <<04102>>35955000
                                                               <<04102>>35960000
      <<* * * generate pmap secondary entry point records * * *<<04102>>35965000
                                                               <<04102>>35970000
      @symp := @stable;                                        <<04102>>35975000
      while @symp < @stable(usedsymbol) do                     <<04102>>35980000
         begin                                                 <<04102>>35985000
         symentparms;                                          <<04102>>35990000
         if (symtype = 9 or symtype = 11) and                  <<04102>>35995000
            srlindex = @rlentp - @rltable then                 <<04102>>36000000
            begin                                              <<04102>>36005000
            move ipmap'name := sname,(symnamenw);              <<04102>>36010000
            namenw:=symnamenw;                                 <<04102>>36015000
            ipmap'type := pmapsectype;                         <<04102>>36020000
            ipmap'flags:= 0;                                   <<04102>>36025000
            ipmap'secentry:=unitadr+srlentry;                  <<04102>>36030000
            ipmap'secentnum:=0;                                <<04102>>36035000
            corebufpmap(pmaprecord,symnamenw+secentpmaplen);   <<04102>>36040000
            end;                                               <<04102>>36045000
         @symp := @symp + symnw;                               <<04102>>36050000
         end;                                                  <<04102>>36055000
      end;                                                     <<04102>>36060000
      @rlentp _ @rlentp+3;  <<next entry>>                              36065000
      tos _ tos-1                                                       36070000
      end;                                                              36075000
                                                                        36080000
   <<* * * append stt to code segment * * *>>                           36085000
                                                                        36090000
   appendstt(coderecd);                                        <<04257>>36095000
   if < then return;  <<error?>>                                        36100000
   condcode _ cce  <<ok condition code>>                                36105000
   end;                                                                 36110000
$page "CODE SEGMENT PREPARATION PROCEDURES - SETUPRLHEADERS"   <<00207>>36115000
$ control segment = seg23                                               36120000
procedure setuprlheaders (adr);                                         36125000
   <<loads the header set preamble block and initializes the header     36130000
     parameters>>                                                       36135000
   value adr;                                                           36140000
   double adr;                                                          36145000
   begin                                                                36150000
   equate maxrecds = maxhead/128-1;                                     36155000
   tos _ adr&dlsl(9);                                                   36160000
   tos _ tos&lsr(9);                                                    36165000
   if not (headrecd <= s1 <= headrecd+maxrecds) then  <<out of buffer?>>36170000
      begin                                                             36175000
      headrecd _ s1;  <<save rec. nr.>>                                 36180000
      freadmr''(rlibfnum,head,maxhead,headrecd)                         36185000
      end                                                               36190000
   else tos _ tos+(s1-headrecd)&lsl(7);  <<adj. buffer disp.>>          36195000
   @headp _ tos+@head;  <<init. header pointer>>                        36200000
   headnw _ 6  <<phoney header length>>                                 36205000
   end;                                                                 36210000
$page "CODE SEGMENT PREPARATION PROCEDURES - GETNEXTRLHEADER"  <<00207>>36215000
$ control segment = seg23                                               36220000
logical procedure getnextrlheader;                                      36225000
   <<loads the next header in the header list and sets the header       36230000
     parameters.  if there are no more headers, the value false is      36235000
     returned; otherwise the value true is returned>>                   36240000
   begin                                                                36245000
   @headp _ @headp+headnw;  <<next header>>                             36250000
   if headp <> -1 then  <<end of list?>>                                36255000
      begin                                                             36260000
      headnw _ hnw;  <<nr. words for header>>                           36265000
      headtype _ htype;  <<header type nr.>>                            36270000
      if @headp+headnw >= @head+maxhead then  <<out of buffer?>>        36275000
         begin                                                          36280000
         headrecd _ headrecd+(@headp-@head)&lsr(7);                     36285000
         freadmr''(rlibfnum,head,maxhead,headrecd);                     36290000
         @headp := @head+(@headp-@head).(9:7)  <<reset header pointer>> 36295000
         end;                                                           36300000
      getnextrlheader _ true                                            36305000
      end                                                               36310000
   end;                                                                 36315000
$page "CODE SEGMENT PREPARATION PROCEDURES - CREATEPMAPSCRATCH"<<04102>>36320000
$control segment=seg23                                         <<04102>>36325000
procedure createpmapscratch(nrpmapsegs, status);               <<04102>>36330000
   value nrpmapsegs;                                           <<04102>>36335000
   integer nrpmapsegs;            << # of segments in pmap >>  <<04102>>36340000
   integer status;                << status code returned >>   <<04102>>36345000
                                                               <<04102>>36350000
begin << createpmapscratch >>                                  <<04102>>36355000
                                                               <<04102>>36360000
   << purge any existing pmap scratch file. >>                 <<04102>>36365000
                                                               <<04102>>36370000
   pmapfilenr := fopen(pmapscratch, %2002, %500);              <<04102>>36375000
   if = then                                                   <<04102>>36380000
      begin                                                    <<04102>>36385000
      fclose(pmapfilenr, 4, 0);                                <<04102>>36390000
      if < then                                                <<04102>>36395000
         begin                                                 <<04102>>36400000
         error(msg'cantclosescratch);                          <<04102>>36405000
         status := status'bad;                                 <<04102>>36410000
         return;                                               <<04102>>36415000
         end;                                                  <<04102>>36420000
      end;                                                     <<04102>>36425000
                                                               <<04102>>36430000
   << open a new temporary pmap scratch file. >>               <<04102>>36435000
                                                               <<04102>>36440000
   pmapfilenr := fopen(pmapscratch, %2000, %424, 128,,,,,,     <<04102>>36445000
                       (pmapnw & dlsr(7)) + 6d, 16,,           <<04102>>36450000
                       progfilecode);                          <<04102>>36455000
   if <> then                                                  <<04102>>36460000
      begin                                                    <<04102>>36465000
      error(msg'cantopenscratch);                              <<04102>>36470000
      status := status'bad;                                    <<04102>>36475000
      return;                                                  <<04102>>36480000
      end;                                                     <<04102>>36485000
                                                               <<04102>>36490000
   << make record 0 look like that of a program file. >>       <<04102>>36495000
   pmapbuf := 0;                  << clear record 0 >>         <<04102>>36500000
   move pmapbuf(1) := pmapbuf, (127);                          <<04102>>36505000
   pmapbuf     := %4000;          << means record 0 was zeroed <<04102>>36510000
   pmapbuf(1)  := nrpmapsegs;     << # of segments in the pmap <<04102>>36515000
   pmapbuf(16) := 1;              << pmap area begins in rec 1 <<04102>>36520000
   fwritedir'(pmapfilenr, pmapbuf, 0);                         <<04102>>36525000
                                                               <<04102>>36530000
   << construct entry type table >>                            <<04102>>36535000
   typetablelen:=nrpmaptype+1;             <<pmap records :    <<04102>>36540000
   segtypelen:=segpmaplen;                 <<!----------------!<<04102>>36545000
   pritypelen:=prientpmaplen;              <<!typetablelen    !<<04102>>36550000
   sectypelen:=secentpmaplen;              <<!len of type 0   !<<04102>>36555000
   move pmapbuf := typetable,(typetablelen);                   <<06556>>36560000
   fwritedir'(pmapfilenr,pmapbuf,1);                           <<06556>>36565000
                                           <<!  popinters     !<<04102>>36570000
   << skip words for segment pmap pointer    !                !<<04102>>36575000
   pmaprecnr:=1+(nrpmapsegs*2+typetablelen)<<!----------------!<<04102>>36580000
                /128;                      <<! pmap records   !<<04102>>36585000
   pmapbufdisp:=(nrpmapsegs*2+typetablelen)<<!                !<<04102>>36590000
                mod 128;                   <<!----------------!<<04102>>36595000
   status:=status'ok;                                          <<04102>>36600000
end; <<createpmapscratch >>                                    <<04102>>36605000
$page "CODE SEGMENT PREPARATION PROCEDURES - CREATESISCRATCH"  <<04102>>36610000
$control segment=seg23                                         <<04102>>36615000
procedure createsiscratch(status);                             <<04102>>36620000
   integer status;                << status code returned >>   <<04102>>36625000
                                                               <<04102>>36630000
begin << createsiscratch >>                                    <<04102>>36635000
                                                               <<04102>>36640000
   << purge any existing si scratch file. >>                   <<04102>>36645000
                                                               <<04102>>36650000
   sifilenr := fopen(siscratch, %2002, %500);                  <<04102>>36655000
   if = then                                                   <<04102>>36660000
      begin                                                    <<04102>>36665000
      fclose(sifilenr, 4, 0);                                  <<04102>>36670000
      if < then                                                <<04102>>36675000
         begin                                                 <<04102>>36680000
         error(msg'cantclosescratch);                          <<04102>>36685000
         status := status'bad;                                 <<04102>>36690000
         return;                                               <<04102>>36695000
         end;                                                  <<04102>>36700000
      end;                                                     <<04102>>36705000
                                                               <<04102>>36710000
   << open a new temporary si scratch file. >>                 <<04102>>36715000
                                                               <<04102>>36720000
   sifilenr := fopen(siscratch, %2000, %421, 128,,,,,,         <<04102>>36725000
                     fixr(real(uslfl & dlsr(7)) * 1.15), 32);  <<04102>>36730000
   if <> then                                                  <<04102>>36735000
      begin                                                    <<04102>>36740000
      error(msg'cantopenscratch);                              <<04102>>36745000
      status := status'bad;                                    <<04102>>36750000
      return;                                                  <<04102>>36755000
      end;                                                     <<04102>>36760000
                                                               <<04102>>36765000
   << start writing at record 0, word 0. >>                    <<04102>>36770000
   sirecnr := 0;                                               <<04102>>36775000
   sibufdisp := 0;                                             <<04102>>36780000
   status := status'ok;                                        <<04102>>36785000
                                                               <<04102>>36790000
end; << createsiscratch >>                                     <<04102>>36795000
$page "CODE SEGMENT PREPARATION PROCEDURES - ACTIVATETOOLBOX"  <<04102>>36800000
$control segment=seg23                                         <<04102>>36805000
procedure activatetoolbox(segpointer, nrpmapsegs, status);     <<04102>>36810000
   value nrpmapsegs;                                           <<04102>>36815000
   integer array segpointer;      << pmap seg rec pointers >>  <<04102>>36820000
   integer nrpmapsegs;            << # of pmap segments >>     <<04102>>36825000
   integer status;                << status code returned >>   <<04102>>36830000
                                                               <<04102>>36835000
begin << activatetoolbox >>                                    <<04102>>36840000
                                                               <<04102>>36845000
   integer       tboxerror;       << returned by createprocess <<04102>>36850000
   integer       tboxpin;         << pin of toolbox son process<<04102>>36855000
   integer array itemnrs(0:3);    << parameter codes >>        <<04102>>36860000
   integer array items(0:2);      << parameters >>             <<04102>>36865000
   integer       zero := 0;       << for call by reference >>  <<04102>>36870000
                                                               <<04102>>36875000
   <<* * * copy segment pointers to the pmap scratch file. * * <<04102>>36880000
                                                               <<04102>>36885000
   if pmaprecnr <> 1 then                                      <<04102>>36890000
      begin                                                    <<04102>>36895000
      fwritedir'(pmapfilenr, pmapbuf, pmaprecnr);              <<04102>>36900000
      pmaprecnr := 1;                                          <<04102>>36905000
      freaddir'(pmapfilenr, pmapbuf, pmaprecnr);               <<04102>>36910000
      end;                                                     <<04102>>36915000
   pmapbufdisp:=typetablelen;                                  <<04102>>36920000
   corebufpmap(segpointer, nrpmapsegs * 2);                    <<04102>>36925000
   fwritedir'(pmapfilenr, pmapbuf, pmaprecnr);                 <<04102>>36930000
                                                               <<04102>>36935000
   if symdbug then                                             <<04102>>36940000
      begin                                                    <<04102>>36945000
                                                               <<04102>>36950000
      <<* * * close the pmap scratch file. * * *>>             <<04102>>36955000
                                                               <<04102>>36960000
      fclose(pmapfilenr, %12, 0); << save temp, return unused ><<04102>>36965000
      if <> then                                               <<04102>>36970000
         begin                                                 <<04102>>36975000
         error(msg'cantclosescratch);                          <<04102>>36980000
         status := status'bad;                                 <<04102>>36985000
         return;                                               <<04102>>36990000
         end;                                                  <<04102>>36995000
                                                               <<04102>>37000000
      <<* * * close the si scratch file. * * *>>               <<04102>>37005000
                                                               <<04102>>37010000
      corebufsi(zero, 1);         << si terminator >>          <<04102>>37015000
      fwritedir'(sifilenr, sibuf, sirecnr);                    <<04102>>37020000
      fclose(sifilenr, 2, 0);     << save temp, keep unused >> <<04102>>37025000
      if <> then                                               <<04102>>37030000
         begin                                                 <<04102>>37035000
         error(msg'cantclosescratch);                          <<04102>>37040000
         status := status'bad;                                 <<04102>>37045000
         return;                                               <<04102>>37050000
         end;                                                  <<04102>>37055000
                                                               <<04102>>37060000
      <<* * * create toolbox process. * * *>>                  <<04102>>37065000
                                                               <<04102>>37070000
      itemnrs    := 3;            << load option flags >>      <<04102>>37075000
      itemnrs(1) := 11;           << info string pointer >>    <<04102>>37080000
      itemnrs(2) := 12;           << info string byte length >><<04102>>37085000
      itemnrs(3) := 0;            << end-of-list >>            <<04102>>37090000
      items      := 1;            << wake up if son terminates <<04102>>37095000
      items(1)   := @tboxfiles;   << info string >>            <<04102>>37100000
      items(2)   := 20;           << info string length >>     <<04102>>37105000
                                                               <<04102>>37110000
      createprocess(tboxerror, tboxpin, segsym, itemnrs,       <<04102>>37115000
                    items);                                    <<04102>>37120000
      if <> then                                               <<04102>>37125000
         begin                                                 <<04102>>37130000
         warn(msg'cantprepsymdebug);                           <<04102>>37135000
         symdbug := false;                                     <<04102>>37140000
         end                                                   <<04102>>37145000
      else                                                     <<04102>>37150000
         begin                                                 <<04102>>37155000
         activate(tboxpin, 2);                                 <<04102>>37160000
         if <> then                                            <<04102>>37165000
            begin                                              <<04102>>37170000
            warn(msg'cantprepsymdebug);                        <<04102>>37175000
            symdbug := false;                                  <<04102>>37180000
            end                                                <<04102>>37185000
         else                                                  <<04102>>37190000
            kill(tboxpin);                                     <<04102>>37195000
         end;                                                  <<04102>>37200000
                                                               <<04102>>37205000
      <<* * * open the scratch files again. * * *>>            <<04102>>37210000
                                                               <<04102>>37215000
      pmapfilenr := fopen(pmapscratch, %2002, %520);           <<04102>>37220000
      if <> then                                               <<04102>>37225000
         begin                                                 <<04102>>37230000
         error(msg'cantopenscratch);                           <<04102>>37235000
         status := status'bad;                                 <<04102>>37240000
         return;                                               <<04102>>37245000
         end;                                                  <<04102>>37250000
                                                               <<04102>>37255000
      if symdbug then                                          <<04102>>37260000
         begin                                                 <<04102>>37265000
         sifilenr := fopen(siscratch, %2002, %520);            <<04102>>37270000
         if <> then                                            <<04102>>37275000
            begin                                              <<04102>>37280000
            error(msg'cantopenscratch);                        <<04102>>37285000
            status := status'bad;                              <<04102>>37290000
            return;                                            <<04102>>37295000
            end;                                               <<04102>>37300000
         end;                                                  <<04102>>37305000
      end;                                                     <<04102>>37310000
                                                               <<04102>>37315000
   status := status'ok;                                        <<04102>>37320000
                                                               <<04102>>37325000
end; << activatetoolbox >>                                     <<04102>>37330000
$page "CODE SEGMENT PREPARATION PROCEDURES - PREPAREPROGRAM"            37335000
$ control segment = seg20                                               37340000
procedure prepareprogram;                                               37345000
   <<prepares a program file from the current usl file>>                37350000
   begin                                                                37355000
                                                                        37360000
   << general-purpose variables: >>                                     37365000
                                                                        37370000
   byte    array b0(0:8) = pb := "$NEWPASS ";                           37375000
   double        oldtimer;        << initial elapsed time >>            37380000
   double        oldproctime;     << initial process time >>            37385000
   logical       newprog   := 0;  << new program file? >>               37390000
   integer       progrecd  := 0;  << record counter/number >>           37395000
   double        nwcode    := 0d; << # words of code >>                 37400000
   integer       errorflag := 0;  << error flag >>                      37405000
   integer       saflut    := -1; << starting address of flut >>        37410000
   integer       savedlarea1;     << old dl area limit >>               37415000
   integer       satrapcom := -1; << starting addr of trapcom>><<04102>>37420000
   logical       foption;         << actual prog file foptions><<04102>>37425000
   logical       fcode;           << actual program file code ><<04102>>37430000
   integer       currentseg;      << addr of current seg entry >>       37435000
   integer       status;          << status returned from procs>>       37440000
   integer       cstindex;        << loop index >>                      37445000
   double  array segpointer(0:255); << pmap segment pointers >><<04102>>37450000
   array          tempbuf(*) = segpointer;                     <<04781>>37455000
   integer       zero := 0;       << for call by reference >>  <<04102>>37460000
   integer       permfnum;                                     <<04781>>37465000
   logical       permflag;                                     <<04781>>37470000
   integer       ferr;                                         <<04781>>37475000
                                                               <<04102>>37480000
   << variables for program file pmap generation. >>           <<04102>>37485000
                                                               <<04102>>37490000
   integer array seginfo(0:1);    << last 2 words of pmap seg- <<04102>>37495000
                                  << ment record.              <<04102>>37500000
   integer       saverecnr;       << save area for pmap rec # ><<04102>>37505000
   integer       savebufdisp;     << save area for pmap displ. <<04102>>37510000
   integer       nrextn;          << program file extent       <<04102>>37515000
   double        pfsizeword;      << program file size in word <<04102>>37520000
   double        pfsizerecord;    << prog file size in record  <<04102>>37525000
   double        tempsize;                                     <<04102>>37530000
   integer       errorcode;                                    <<04102>>37535000
$page "CODE SEGMENT PREPARATION PROCEDURE - PREPAREPROGRAM"             37540000
subroutine fclose'(fnum,disp);                                 <<04781>>37545000
                                                               <<04781>>37550000
   value fnum,disp;                                            <<04781>>37555000
   integer fnum,disp;                                          <<04781>>37560000
                                                               <<04781>>37565000
begin                                                          <<04781>>37570000
   fgetinfo(fnum,,,,,,,,,,,,,,,,nrextn);                       <<04781>>37575000
   if (disp = save or disp = tempfile) and nrextn = 1 then     <<04781>>37580000
      disp := disp + %(2)1000;                                 <<04781>>37585000
   fclose(fnum,disp,0);                                        <<04781>>37590000
   if < then                                                   <<04781>>37595000
      fcheck(fnum,ferr)                                        <<04781>>37600000
   else                                                        <<04781>>37605000
      ferr := -1;                                              <<04781>>37610000
end;                                                           <<04781>>37615000
                                                               <<04781>>37620000
subroutine copyprogfile;                                       <<04781>>37625000
                                                               <<04781>>37630000
begin                                                          <<04781>>37635000
   tos := 0d;                                                  <<04781>>37640000
   fgetinfo(permfnum,,,,,,,,,,,ds1);                           <<04781>>37645000
   tos := feof(progfnum);                                      <<04781>>37650000
   if s1 > s0 then << old perm prog file is big enough >>      <<04781>>37655000
      begin                                                    <<04781>>37660000
         while s0 > 0 do                                       <<04781>>37665000
            begin                                              <<04781>>37670000
               s0:=s0-1;                                       <<04781>>37675000
               freaddir'(progfnum,tempbuf,s0);                 <<04781>>37680000
               fwritedir'(permfnum,tempbuf,s0);                <<04781>>37685000
            end;                                               <<04781>>37690000
      end                                                      <<04781>>37695000
   else                                                        <<04781>>37700000
      begin                                                    <<04781>>37705000
         errorflag := 1;                                       <<04781>>37710000
         error(msg'pfiletoosmall);                             <<04781>>37715000
      end;                                                     <<04781>>37720000
   fclose'(permfnum,nochange);                                 <<04781>>37725000
   fclose'(progfnum,nochange);                                 <<04781>>37730000
   ddel;del;                                                   <<04781>>37735000
end;                                                           <<04781>>37740000
$page                                                                   37745000
   subroutine postscan(segnamenw);                             <<04102>>37750000
      value segnamenw;                                         <<04102>>37755000
      integer segnamenw;          << # words in seg name >>    <<04102>>37760000
      begin                                                             37765000
      if seglen <> 0 then  <<null segment?>>                            37770000
         begin                                                          37775000
         pmap(cstnr) _ sttnr;  <<save first avail. stt nr.>>            37780000
         sttppcount(cstnr) := sttppnr;                         <<02817>>37785000
         pmapnw:=pmapnw+double(segnamenw+segpmaplen);          <<04102>>37790000
         << adj. nr. rec's >>                                  <<01113>>37795000
         tos := seglen;                                        <<01113>>37800000
         if initpatch >= 0 then tos := tos+initpatch+19;       <<01113>>37805000
         progrecd := progrecd + (tos + sttppnr + 127) / 128;   <<04102>>37810000
         cstnr _ cstnr+1  <<bump segment nr.>>                          37815000
         end                                                            37820000
      end;                                                              37825000
                                                                        37830000
   subroutine postprepare(segnamenw);                          <<04102>>37835000
      value segnamenw;                                         <<04102>>37840000
      integer segnamenw;          << # words in seg name >>    <<04102>>37845000
                                                               <<04102>>37850000
      begin                                                             37855000
      if seglen <> 0 then  <<null segment?>>                            37860000
         begin                                                          37865000
         tos _ seglen;  <<segment length>>                              37870000
         tos.(0:1) _ segprivileged;  <<priv. mode bit>>                 37875000
         pdescrip(cstnr) _ tos;  <<store seg. descriptor>>              37880000
         pwarning _ logical(pwarning) lor logical(segwarning);          37885000
         pmode _ logical(pmode) lor segprivileged;                      37890000
         nwcode _ nwcode+double(logical(seglen));  <<adj. total code>>  37895000
         progrecd _ progrecd+(seglen+127)&lsr(7);  <<next rec. nr.>>    37900000
                                                               <<04102>>37905000
         if fpmap then                                         <<04102>>37910000
         begin                                                 <<04102>>37915000
         saverecnr   := pmaprecnr;                             <<04102>>37920000
         savebufdisp := pmapbufdisp;                           <<04102>>37925000
         getrecddisp(segpointer(cstnr) + double(segnamenw),    <<04102>>37930000
                     pmaprecnr, pmapbufdisp);                  <<04102>>37935000
         if saverecnr <> pmaprecnr then                        <<04102>>37940000
            begin                                              <<04102>>37945000
            fwritedir'(pmapfilenr, pmapbuf, saverecnr);        <<04102>>37950000
            freaddir'(pmapfilenr, pmapbuf, pmaprecnr);         <<04102>>37955000
            end;                                               <<04102>>37960000
         seginfo    := cstnr cat sttnr (0:8:8);                <<04102>>37965000
         seginfo(1) := seglen;                                 <<04102>>37970000
         corebufpmap(seginfo, 2);                              <<04102>>37975000
         if saverecnr <> pmaprecnr then                        <<04102>>37980000
            begin                                              <<04102>>37985000
            fwritedir'(pmapfilenr, pmapbuf, pmaprecnr);        <<04102>>37990000
            freaddir'(pmapfilenr, pmapbuf, saverecnr);         <<04102>>37995000
            end;                                               <<04102>>38000000
         pmaprecnr   := saverecnr;                             <<04102>>38005000
         pmapbufdisp := savebufdisp;                           <<04102>>38010000
         end;                                                  <<04102>>38015000
                                                               <<04102>>38020000
         cstnr _ cstnr+1  <<bump segment nr.>>                          38025000
         end                                                            38030000
      else clearline  <<clear segment name if not printed>>             38035000
      end;                                                              38040000
$page                                                                   38045000
   << initialization. >>                                                38050000
                                                                        38055000
   oldtimer     := timer;                                               38060000
   oldproctime  := proctime;                                            38065000
   savedlarea1  := @dlarea1;                                            38070000
   preperror    := 0;                                                   38075000
   overflowflag := 0;                                                   38080000
   siseen       := false;                                      <<04102>>38085000
   toolboxid    := 0;                                          <<04102>>38090000
                                                                        38095000
   << allocate dl buffers. >>                                           38100000
                                                                        38105000
   makeroomindl(progdlbufs1);                                           38110000
   if < then                                                            38115000
      go nfg;                                                           38120000
   @symbol       := @dlarea1      - 95;                                 38125000
   @patch        := @symbol       - 128;                                38130000
   @stt          := @patch        - 1;                                  38135000
   @dirtydata    := @stt          - 271;                                38140000
   @stable       := @dirtydata;                                         38145000
   @dlarea1      := @stable;                                            38150000
                                                                        38155000
   @logicalunits := @dlarea2;                                           38160000
   @prog0        := @logicalunits + 7;                                  38165000
   @pmap         := @prog0        & lsl(1) + 56;                        38170000
   @common       := @prog0        + p512;                      <<06093>>38175000
   @comtab       := @common       + 19;                                 38180000
   @dlavail      := @comtab       + 512;                                38185000
                                                                        38190000
   << initialize dl buffers. >>                                         38195000
                                                                        38200000
   symbol := 0;                   << symbol hash table >>               38205000
   move symbol(1) := symbol, (94);                                      38210000
   usedsymbol := 0;                                                     38215000
                                                                        38220000
   patch := -1;                   << patch record table >>              38225000
   move patch(1) := patch, (127);                                       38230000
   usedpatch := 0;                                                      38235000
                                                                        38240000
   dirtydata := 0;                << data segment table >>              38245000
   move dirtydata(1) := dirtydata, (15);                                38250000
   trecd2 := 0;                                                         38255000
                                                                        38260000
   prog0 := 0;                    << program file record 0 >>  <<04102>>38265000
   move prog0(1) := prog0, (255);                              <<04102>>38270000
                                                                        38275000
   common := %177774;             << common table >>           <<04102>>38280000
   move common(1) := common, (bnd4);                                    38285000
   nrcoment := 0;                                                       38290000
                                                                        38295000
   logicalunits := 0;             << logical unit table >>              38300000
   move logicalunits(1) := logicalunits, (34);                          38305000
   luspecified := false;                                                38310000
                                                                        38315000
   << prepare to make first pass over program units. >>                 38320000
                                                                        38325000
   pmapnw       := 0d;                                         <<04102>>38330000
   cstnr        := 0;                                                   38335000
   nwpdb        := 0;                                                   38340000
   nwsdb        := 0;                                                   38345000
   obadr        := 0;                                                   38350000
   pflags       := %4000;                                      <<04102>>38355000
   procstackest := 0;                                                   38360000
   nwpustbuf    := 0;                                                   38365000
   nwstlt       := nwstltpreface;                                       38370000
   obpustadr    := -1;                                                  38375000
   programfile  := true;                                                38380000
   putinfo;                       << save info buffer >>                38385000
                                                                        38390000
   << perform first pass over usl program units. >>                     38395000
                                                                        38400000
   currentseg := uslsl;                                                 38405000
   while currentseg <> 0 do                                             38410000
      begin                                                             38415000
      getentry(currentseg);                                             38420000
      scansegment(entfileadr);                                          38425000
      if < then                                                         38430000
         go nfg;                                                        38435000
      postscan(entnamenw);                                     <<04102>>38440000
      currentseg := ebl;                                                38445000
      end;                                                              38450000
                                                                        38455000
   if cstnr = 0 then                                                    38460000
      begin                                                             38465000
      error(msg'noprogtoprep);    << no active segments >>              38470000
      go nfg;                                                           38475000
      end;                                                              38480000
                                                                        38485000
   if obadr = 0 then                                                    38490000
      begin                                                             38495000
      error(msg'noouterblock);    << no outer block >>                  38500000
      go nfg;                                                           38505000
      end;                                                              38510000
                                                                        38515000
   <<* * * scan rl procedures * * *>>                                   38520000
                                                                        38525000
   if rlibfname <> " " then  <<search rl?>>                             38530000
      begin                                                             38535000
      scanrl;                                                           38540000
      if < then go nfg;  <<error?>>                                     38545000
      postscan(3);                                             <<04102>>38550000
      end;                                                              38555000
                                                                        38560000
   if not siseen then                                          <<04102>>38565000
      symdbug := false;                                        <<04102>>38570000
   if symdbug then fpmap:=1;                                   <<04102>>38575000
   pmapnw := pmapnw + 1d;         << for 0 terminator >>       <<04102>>38580000
                                                                        38585000
   <<* * * partially initialize record 0,1 * * *>>                      38590000
                                                                        38595000
   if cstnr > maxcst then  <<too many segments?>>                       38600000
      begin                                                             38605000
      error(39);                                                        38610000
      go nfg                                                            38615000
      end;                                                              38620000
   @pdescrip _ @prog0+(cstnr+57)&lsr(1);  <<init. seg. descrip. pntr>>  38625000
   pns _ cstnr;  <<nr. segments>>                                       38630000
   psag := if cstnr <= 66 then 1                               <<06093>>38635000
      else if cstnr <= 152 then 2                              <<06093>>38640000
      else if cstnr <= 237 then 3 else 4;                      <<06093>>38645000
                                                                        38650000
   <<* * * allocate space for common arrays * * *>>            <<01124>>38655000
                                                               <<01124>>38660000
   if nrcoment <> 0 then                                       <<01124>>38665000
      begin                                                    <<01124>>38670000
      header9s';  << allocate db area for common arrays >>     <<01124>>38675000
      if < then go nfg;                                        <<01124>>38680000
      end;                                                     <<01124>>38685000
                                                               <<04553>>38690000
   <<* * * check db overflow * * *>>                           <<04553>>38695000
                                                               <<04553>>38700000
   if overflowflag then                                        <<04553>>38705000
      begin                                                    <<04553>>38710000
         error(38);                                            <<04553>>38715000
         go nfg;                                               <<04553>>38720000
      end;                                                     <<04553>>38725000
                                                               <<01124>>38730000
   <<* * * open program file * * *>>                                    38735000
                                                                        38740000
                                                               <<04102>>38745000
   <<  estimate program file size  >>                          <<04102>>38750000
                                                               <<04102>>38755000
   pfsizeword:=double(nwpdb+       << primary db      >>       <<04102>>38760000
                      nwsdb+       << secondary db    >>       <<04102>>38765000
                      nrcoment+    << common labels   >>       <<04102>>38770000
                      nwstlt);     << stlt            >>       <<04102>>38775000
   if searchsym(blankcommon,symcommon) then                    <<04102>>38780000
      pfsizeword:=pfsizeword+double(snwca); << common data >>  <<04102>>38785000
   pfsizerecord:=(pfsizeword+127d)&dlsr(7)+ << nr. rec's   >>  <<04102>>38790000
                 double(psag+               <<record(s) 0,1>>  <<04102>>38795000
                        progrecd+      <<nr. rec's for code>>  <<04102>>38800000
                        25 + 2 * cstnr); << ent. and ext. >>   <<04525>>38805000
   tempsize:=pfsizerecord; <<save program file size without>>  <<04102>>38810000
                           <<pmap and si info              >>  <<04102>>38815000
   if symdbug then                                             <<04102>>38820000
         pfsizerecord:=pfsizerecord                            <<04102>>38825000
                       +uslfl&dlsr(7)        << si rec's   >>  <<04102>>38830000
                       +(pmapnw+double(cstnr*2+  <<pmap rec's>><<04102>>38835000
                        nrpmaptype+1)+127d)&dlsr(7)            <<04102>>38840000
   else                                                        <<04102>>38845000
      if fpmap then                                            <<04102>>38850000
         pfsizerecord:=pfsizerecord+(pmapnw+double(cstnr*2+    <<04102>>38855000
                                   nrpmaptype+1)+127d)&dlsr(7);<<04102>>38860000
   nrextn:=integer(pfsizerecord/tempsize);                     <<04102>>38865000
   if nrextn > 16 then nrextn:=16;                             <<04525>>38870000
                                                               <<04102>>38875000
   << check program file domain :                >>            <<04102>>38880000
   <<   if it is old permanent file,             >>            <<04102>>38885000
   <<    --check file code, set eof to record 0; >>            <<04102>>38890000
   <<      then create a new file.               >>            <<04781>>38895000
   <<      if new file can not be created then   >>            <<04781>>38900000
   <<      set progfnum := permfnum.             >>            <<04781>>38905000
   <<   if it is old temperary file,             >>            <<04102>>38910000
   <<    --purge it then create a new file;      >>            <<04102>>38915000
   <<   if it is not existed,                    >>            <<04102>>38920000
   <<    --create a new file;                    >>            <<04102>>38925000
   <<   if it is $newpass,                       >>            <<04102>>38930000
   <<    --create a new file.                    >>            <<04102>>38935000
                                                               <<04102>>38940000
   permflag := false;                                          <<04781>>38945000
   if bfilename = b0,(8) then go newfile;                      <<04102>>38950000
                                                               <<04102>>38955000
   << fopen an old perm/temp file               >>             <<04102>>38960000
   <<  necessary to specify the file size and   >>             <<04102>>38965000
   <<  file code in case of :file command       >>             <<04102>>38970000
   <<  specifying the file                      >>             <<04102>>38975000
                                                               <<04102>>38980000
   permfnum:=fopen(bfilename,%(2)10000000011,%(2)101010100,    <<04781>>38985000
                   ,,,,,,pfsizerecord,nrextn,,progfilecode);   <<04102>>38990000
   if < then      << open failed? >>                           <<04102>>38995000
      begin                                                    <<04102>>39000000
         fcheck(0,errorcode);                                  <<04102>>39005000
         if errorcode=58 then  << no $oldpass >>               <<04102>>39010000
            begin                                              <<04102>>39015000
               move bfilename:=b0,(9);                         <<04102>>39020000
               go newfile;                                     <<04102>>39025000
            end;                                               <<04102>>39030000
         if not (52<=errorcode<=53) then  << error other than  <<04102>>39035000
            begin                         << nonexistent file  <<04102>>39040000
               errorn(msg'cantopenprogfile,double(errorcode)); <<04102>>39045000
               go nfg;                                         <<04102>>39050000
            end;                                               <<04102>>39055000
      end                                                      <<04102>>39060000
   else         << open succeeded >>                           <<04102>>39065000
      begin                                                    <<04102>>39070000
         fgetinfo(permfnum,,foption,,,,,,fcode);               <<04781>>39075000
         if foption.(14:2)=1 then  << old permanent file >>    <<04102>>39080000
            begin                                              <<04102>>39085000
               if fcode <> progfilecode then                   <<04102>>39090000
                  begin                                        <<04102>>39095000
                     error(msg'badprogfile);                   <<04102>>39100000
                     go badfile;                               <<04102>>39105000
                  end;                                         <<04102>>39110000
               fcontrol(permfnum,6,i);                         <<04781>>39115000
               permflag := true;                               <<04781>>39120000
               go newfile;                                     <<04781>>39125000
            end;                                               <<04102>>39130000
         if foption.(14:2)=2 then  << old temparary file >>    <<04102>>39135000
            begin                                              <<04781>>39140000
               fclose(permfnum,4,0);                           <<04781>>39145000
               permfnum := 0;                                  <<04781>>39150000
            end;                                               <<04781>>39155000
      end;                                                     <<04102>>39160000
   newfile:                                                    <<04102>>39165000
                                                               <<04102>>39170000
   << fopen as a new file >>                                   <<04102>>39175000
                                                               <<04102>>39180000
   progfnum:=fopen(bfilename,%(2)10000000000,%(2)101010100,    <<04102>>39185000
                  ,,,,,,pfsizerecord,nrextn,,progfilecode);    <<04102>>39190000
   if < then                                                   <<04102>>39195000
      begin                                                    <<04102>>39200000
         if permflag then                                      <<04781>>39205000
            progfnum := permfnum                               <<04781>>39210000
         else                                                  <<04781>>39215000
            begin                                              <<04781>>39220000
               fcheck(0,errorcode);                            <<04781>>39225000
               errorn(msg'cantopenprogfile,double(errorcode)); <<04781>>39230000
               go nfg;                                         <<04781>>39235000
            end;                                               <<04781>>39240000
      end;                                                     <<04102>>39245000
                                                               <<04102>>39250000
   blankline;                                                  <<04102>>39255000
   tos:=progfnum;                                              <<04102>>39260000
   move bline:="PROGRAM FILE ",2;                              <<04102>>39265000
   fgetinfo (*,*);                                             <<04102>>39270000
   printline;                                                  <<04102>>39275000
   blankline;                                                  <<04102>>39280000
                                                               <<04102>>39285000
                                                                        39290000
   <<* * * allocate blank common and initialize data labels * * *>>     39295000
                                                                        39300000
   if nrcoment <> 0 then    << common data label >>            <<06293>>39305000
      begin                                                    <<06293>>39310000
         allocatecommon;                                       <<06293>>39315000
         if < then go to nfg;                                  <<06293>>39320000
      end;                                                     <<06293>>39325000
                                                                        39330000
   <<* * * compose flut * * *>>                                         39335000
                                                                        39340000
   if luspecified then saflut _ composeflut;  <<logical units?>>        39345000
                                                                        39350000
   <<* * * compose stlt * * *>>                                         39355000
                                                                        39360000
   sastlt _ -1;  <<init. stlt adr.>>                                    39365000
   if nwstlt <> nwstltpreface then composestlt;  <<traced?>>            39370000
                                                                        39375000
   if searchsym (trapcom',symcommon) then satrapcom := ssaca + nwpdb;   39380000
   <<* * * partially initialize record 0,1 * * *>>                      39385000
                                                                        39390000
   tos _ pflags;                                                        39395000
   tos.(2:1) _ zerodb;  <<zero db?>>                                    39400000
   tos := usercap2;  <<user's resource capabilities>>                   39405000
   tos := capability;  <<capabilities specified>>                       39410000
   if = then  <<use ia,ba default?>>                                    39415000
      begin                                                             39420000
      tos := %(2)0110000000;  <<ia,ba mask>>                            39425000
      assemble(delb,and)  <<ia,ba subset>>                              39430000
      end                                                               39435000
   else  <<check for legal subset>>                                     39440000
      begin                                                             39445000
      assemble(ddup,and; lcmp,del);  <<subset>>                         39450000
      if <> then  <<illegal specification?>>                            39455000
         begin                                                          39460000
         error(33);                                                     39465000
         go nfg                                                         39470000
         end;                                                           39475000
      tos := capability; <<capabilities specified>>            <<01504>>39480000
      if ls0 land %600 <> 0 then                               <<01504>>39485000
         tos := tos lor (usercap2 land %600);                  <<01504>>39490000
      end;                                                              39495000
   tos.(6:10) _ tos;  <<prog. capabilities>>                            39500000
   pflags _ tos;  <<flag word>>                                         39505000
   tos _ nwpdb+nwsdb;  <<global size>>                                  39510000
   if overflow or overflowflag or s0 > maxdata then            <<02816>>39515000
      begin                                                             39520000
      error(38);                                                        39525000
      go nfg                                                            39530000
      end;                                                              39535000
   pgs _ tos;  <<global area size>>                                     39540000
   psas _ psag+(pgs+127)&lsr(7);  <<rec. nr. of segment set>>           39545000
   if initstack = -1 then  <<calculate default stack size?>>            39550000
      begin                                                             39555000
      tos _ obstackest+procstackest+p256;  <<stack estimate>>           39560000
      if luspecified then tos := tos+p384; << formatter est. >>         39565000
      tos := sdbdefaultstack;                                  <<00.dm>>39570000
      assemble(ddup,cmp);                                               39575000
      if > then assemble(xch);  <<leave largest on tos>>                39580000
      if nwstlt <> nwstltpreface then tos := tos+461  <<trace est.>>    39585000
      end                                                               39590000
   else  <<use specified value>>                                        39595000
      begin                                                             39600000
      tos := initstack;                                                 39605000
      if < then  <<illegal value?>>                                     39610000
         begin                                                          39615000
         error(70);                                                     39620000
         go nfg                                                         39625000
         end                                                            39630000
      end;                                                              39635000
   piss _ tos;  <<stack estimate>>                                      39640000
   if initdl = -1 then  <<calculate default dl size?>>                  39645000
      tos := defaultdl  <<default dl size>>                             39650000
   else  <<use specified value>>                                        39655000
      begin                                                             39660000
      tos := initdl;                                                    39665000
      if < then  <<illegal value?>>                                     39670000
         begin                                                          39675000
         error(71);                                                     39680000
         go nfg                                                         39685000
         end                                                            39690000
      end;                                                              39695000
   pidl := tos;  <<dl size>>                                            39700000
   if initmaxdata = -1 then  <<calculate default maxdata size?>>        39705000
      tos := defaultmaxdata  <<default maxdata size>>                   39710000
   else  <<use specified value>>                                        39715000
      begin                                                             39720000
      tos := initmaxdata;                                               39725000
      if < then  <<illegal value?>>                                     39730000
         begin                                                          39735000
         error(72);                                                     39740000
         go nfg                                                         39745000
         end                                                            39750000
      end;                                                              39755000
   pmaxd := tos;  <<max. data segment size>>                            39760000
   psastlt _ sastlt;  <<db adr. of stlt>>                               39765000
   psaflut _ saflut;  <<db adr. of flut>>                               39770000
   psatrapcom := satrapcom;  <<db adr. of trapcom'>>           <<00.bv>>39775000
                                                                        39780000
   <<* * * truncate dl area 2 tables * * *>>                            39785000
                                                                        39790000
   tos _ @pdescrip(cstnr);  <<new s.a. common hash link table>>         39795000
   tos _ @common;  <<old s.a. common hash link table>>                  39800000
   tos _ 19;  <<table length>>                                          39805000
   @common _ s2;  <<update pointer>>                                    39810000
   assemble(move 2);                                                    39815000
   tos _ @comtab;  <<old s.a. of common table>>                         39820000
   tos _ nrcoment&lsl(1);  <<table length>>                             39825000
   @comtab _ s2;  <<update pointer>>                                    39830000
   assemble(move 2);                                                    39835000
   tos _ @rltable;  <<old s.a. of rl table>>                            39840000
   tos _ 3*nrrlent;  <<table length>>                                   39845000
   @rltable _ s2;  <<update pointer>>                                   39850000
   assemble(move 2);                                                    39855000
   @dlavail _ tos;                                                      39860000
   makeroomindl(nwpustbuf);                                             39865000
   if < then go nfg;  <<error?>>                                        39870000
   @pustbuf _ @dlavail;  <<s.a. pust buffer>>                           39875000
   @ptable _ @pustbuf+nwpustbuf;  <<s.a. patch table>>                  39880000
   @dlavail _ @ptable;  <<s.a. dl available area>>                      39885000
                                                               <<04102>>39890000
   <<* * * open the pmap scratch file * * *>>                  <<04102>>39895000
                                                               <<04102>>39900000
   if fpmap then                                               <<04102>>39905000
   begin                                                       <<04102>>39910000
   createpmapscratch(cstnr, status);                           <<04102>>39915000
   if status <> status'ok then                                 <<04102>>39920000
      go nfg;                                                  <<04102>>39925000
   end;                                                        <<04102>>39930000
                                                               <<04102>>39935000
   <<* * * open the si scratch file * * *>>                    <<04102>>39940000
                                                               <<04102>>39945000
   if symdbug then                                             <<04102>>39950000
      begin                                                    <<04102>>39955000
      createsiscratch(status);                                 <<04102>>39960000
      if status <> status'ok then                              <<04102>>39965000
         go nfg;                                               <<04102>>39970000
      end;                                                     <<04102>>39975000
                                                                        39980000
   <<* * * prepare usl program units * * *>>                            39985000
                                                                        39990000
   cstnr _ 0;  <<re-init. segment nr.>>                                 39995000
   nwstlt _ nwstltpreface;  <<re-init. nr. words in stlt>>              40000000
   progrecd _ psas;  <<rec. nr. of first segment>>                      40005000
   getinfo;  <<re-load info block if possible>>                         40010000
   getentry(uslsl);  <<get first segment entry>>                        40015000
   do begin                                                             40020000
      sttppnr := pmap(cstnr); << 1st stt for private procs >>  <<02817>>40025000
      sttnr   := sttppnr + sttppcount(cstnr); << 1st extern stt<<02817>>40030000
      if fpmap then                                            <<04102>>40035000
      segpointer(cstnr) := double(pmaprecnr) * 128d +          <<04102>>40040000
                           double(pmapbufdisp);                <<04102>>40045000
      preparesegment(entfileadr,progfnum,progrecd);                     40050000
      if < then go nfg;  <<error?>>                                     40055000
      postprepare(entnamenw);                                  <<04102>>40060000
      tos _ ebl;  <<next segment entry>>                                40065000
      if <> then getentry(*)                                            40070000
      end until =;                                                      40075000
                                                                        40080000
   <<* * * prepare rl segment * * *>>                                   40085000
                                                                        40090000
   if rlibfname <> " " then  <<search rl?>>                             40095000
      begin                                                             40100000
      sttppnr := pmap(cstnr); << 1st stt for private procs >>  <<02817>>40105000
      sttnr   := sttppnr + sttppcount(cstnr); << 1st extern stt<<02817>>40110000
      if fpmap then                                            <<04102>>40115000
      segpointer(cstnr) := double(pmaprecnr) * 128d +          <<04102>>40120000
                           double(pmapbufdisp);                <<04102>>40125000
      @entp:=@rlseg;  << pointer to rl seg entry so >>         <<04780>>40130000
                      << ename is "RLSEG"           >>         <<04780>>40135000
      preparerl(progrecd);                                              40140000
      if < then go nfg;  <<error?>>                                     40145000
      postprepare(3);                                          <<04102>>40150000
      end;                                                              40155000
                                                                        40160000
   <<* * * apply all active block data program units * * *>>            40165000
                                                                        40170000
   if uslbdl <> 0 then  <<block data's?>>                               40175000
      begin                                                             40180000
      applyblockdatas;                                                  40185000
      if < then go nfg  <<error?>>                                      40190000
      end;                                                              40195000
                                                                        40200000
   <<* * * complete data segment initialization * * *>>                 40205000
                                                                        40210000
   if tdisp2 <> 0 then  <<non-empty buffer?>>                           40215000
      begin                                                             40220000
      fwritedir'(progfnum,tbuf2,trecd2);                                40225000
      setbit(dirtydata,trecd2-psag)                                     40230000
      end;                                                              40235000
   if zerodb then  <<zero remaining records?>>                          40240000
      begin                                                             40245000
      tos := @tbuf2; ps0 := 0;                                          40250000
      assemble(dup,incb); tos := 127; assemble(move 3);                 40255000
      tos := psas-psag;  <<nr. rec's>>                                  40260000
      while <> do                                                       40265000
         begin                                                          40270000
         if not testbit(dirtydata,s0-1) then                            40275000
            fwritedir'(progfnum,tbuf2,s0-1+psag);                       40280000
         tos := tos-1                                                   40285000
         end                                                            40290000
      end;                                                              40295000
                                                                        40300000
   <<* * * compose external list * * *>>                                40305000
                                                                        40310000
   psax _ progrecd;  <<rec. nr. of external list>>                      40315000
   trecd1 _ progrecd;                                                   40320000
   tdisp1 _ 0;                                                          40325000
   @symp _ @stable;                                                     40330000
   while @symp < @stable(usedsymbol) do                                 40335000
      begin                                                             40340000
      symentparms;                                                      40345000
      if symtype = 7 then corebuf1(sname,symnw-2);                      40350000
      @symp _ @symp+symnw  <<next entry>>                               40355000
      end;                                                              40360000
   tbuf1(tdisp1) _ 0;  <<list terminator>>                              40365000
   fwritedir'(progfnum,tbuf1,trecd1);                                   40370000
   progrecd _ trecd1+1;  <<next avail. rec. nr.>>                       40375000
                                                                        40380000
   <<* * * compose entry point list * * *>>                             40385000
                                                                        40390000
   psae _ progrecd;  <<rec. nr. of entry point list>>                   40395000
   trecd1 _ progrecd;                                                   40400000
   tdisp1 _ 0;                                                          40405000
   @symp _ @stable;                                                     40410000
   while @symp < @stable(usedsymbol) do                                 40415000
      begin                                                             40420000
      symentparms;                                                      40425000
      if (1 <= symtype <= 2) then  <<o.b. entry point?>>                40430000
         begin                                                          40435000
         if symtype = 1 then obsymtabadr := @symp;             <<01124>>40440000
         tos _ @buf;                                                    40445000
         move buf _ sname,(symnamenw),2;                                40450000
         tos _ ssacode;  <<pb adr.>>                                    40455000
         tos _ ssttnr;  <<stt nr.>>                                     40460000
         dps2 _ tos;                                                    40465000
         corebuf1(*,tos+2-@buf)                                         40470000
         end;                                                           40475000
      @symp _ @symp+symnw  <<next entry>>                               40480000
      end;                                                              40485000
   tbuf1(tdisp1) _ 0;  <<list terminator>>                              40490000
   fwritedir'(progfnum,tbuf1,trecd1);                                   40495000
   progrecd _ trecd1+1;  <<next avail. rec. nr.>>                       40500000
                                                               <<04102>>40505000
   <<* * * pass scratch files to toolbox son process. * * *>>  <<04102>>40510000
                                                               <<04102>>40515000
   if fpmap then  begin                                        <<04102>>40520000
   corebufpmap(zero, 1);          << pmap terminator >>        <<04102>>40525000
   activatetoolbox(segpointer, cstnr, status);                 <<04102>>40530000
   if status <> status'ok then                                 <<04102>>40535000
      go nfg;                                                  <<04102>>40540000
                                                               <<04102>>40545000
   <<* * * copy pmap scratch file to program file. * * *>>     <<04102>>40550000
                                                               <<04102>>40555000
   psapmap := progrecd;                                        <<04102>>40560000
   trecd1  := progrecd;                                        <<04102>>40565000
   tdisp1  := 0;                                               <<04102>>40570000
   for cstindex := 0 until cstnr - 1 do                        <<04102>>40575000
      segpointer(cstindex) := double(progrecd) & dlsl(7) +     <<04102>>40580000
                              segpointer(cstindex) - 128d;     <<04102>>40585000
   corebuf1(typetable,typetablelen);                           <<04102>>40590000
   corebuf1(segpointer,cstnr*2);                               <<04102>>40595000
   masterbufd(progfnum, pmapfilenr, tbuf1, trecd1, tdisp1,     <<04102>>40600000
             true,double(128+typetablelen+cstnr*2),tbuf1,      <<04102>>40605000
             pmapnw);                                          <<04102>>40610000
   if tdisp1 <> 0 then                                         <<04102>>40615000
      begin                                                    <<04102>>40620000
      fwritedir'(progfnum, tbuf1, trecd1);                     <<04102>>40625000
      trecd1 := trecd1 + 1;                                    <<04102>>40630000
      end;                                                     <<04102>>40635000
   fclose(pmapfilenr, 4, 0);                                   <<04102>>40640000
   if <> then                                                  <<04102>>40645000
      begin                                                    <<04102>>40650000
      error(msg'cantclosescratch);                             <<04102>>40655000
      go nfg;                                                  <<04102>>40660000
      end;                                                     <<04102>>40665000
   progrecd := trecd1;                                         <<04102>>40670000
   end;                                                        <<04102>>40675000
                                                               <<04102>>40680000
   <<* * * copy si scratch file to program file. * * *>>       <<04102>>40685000
                                                               <<04102>>40690000
   if symdbug then                                             <<04102>>40695000
      begin                                                    <<04102>>40700000
      psasym := progrecd;                                      <<04102>>40705000
      trecd1 := progrecd;                                      <<04102>>40710000
      tdisp1 := 0;                                             <<04102>>40715000
      masterbufd(progfnum, sifilenr, tbuf1, trecd1, tdisp1,    <<04102>>40720000
                true, 0d, tbuf1,double(feof(sifilenr))*128d);  <<04102>>40725000
      fclose(sifilenr, 4, 0);                                  <<04102>>40730000
      if <> then                                               <<04102>>40735000
         begin                                                 <<04102>>40740000
         error(msg'cantclosescratch);                          <<04102>>40745000
         go nfg;                                               <<04102>>40750000
         end;                                                  <<04102>>40755000
      progrecd := trecd1;                                      <<04102>>40760000
      end;                                                     <<04102>>40765000
                                                                        40770000
   <<* * * complete initialization of record 0,1 * * *>>                40775000
                                                                        40780000
   @symp _ obsymtabadr;  <<o.b. sym. tab. adr.>>                        40785000
   symentparms;                                                         40790000
   psseg _ ssegnr;  <<starting seg. nr.>>                               40795000
   psadr _ ssacode;  <<pb starting adr.>>                               40800000
   psstt _ ssttnr;  <<starting stt nr.>>                                40805000
   if checksumspecified then                                   <<04257>>40810000
      pcksum:=1;                                               <<04257>>40815000
   if initpatch >= 0 then                                      <<04257>>40820000
      ppatch:=1;                                               <<04257>>40825000
   xreg _ cstnr-1;                                                      40830000
   do begin                                                             40835000
      pmap(xreg) _ xreg;                                                40840000
      xreg _ xreg-1                                                     40845000
      end until <;                                                      40850000
   fwritemr'(progfnum,prog0,psag&lsl(7),0);                             40855000
                                                                        40860000
   <<* * * print program file parameters * * *>>                        40865000
                                                                        40870000
   if preperror <> 0 then go nfg; << errors? >>                <<01.dm>>40875000
   blankline;                                                           40880000
   move bline _ "PRIMARY DB"; ntoa(nwpdb,8,bline(20));                  40885000
   move bline(25) _ "INITIAL STACK"; ntoa(piss,8,bline(45));            40890000
   move bline(50) _ "CAPABILITY"; ntoa(pcap,8,bline(70));               40895000
   printline;                                                           40900000
   move bline _ "SECONDARY DB"; ntoa(nwsdb,8,bline(20));                40905000
   move bline(25) _ "INITIAL DL"; ntoa(pidl,8,bline(45));               40910000
   move bline(50) _ "TOTAL CODE"; dntoa(nwcode,8,bline(70));            40915000
   printline;                                                           40920000
   move bline _ "TOTAL DB"; ntoa(nwpdb+nwsdb,8,bline(20));              40925000
   move bline(25) _ "MAXIMUM DATA";                                     40930000
   if pmaxd = -1 then bline(45) _ "?" else ntoa(pmaxd,8,bline(45));     40935000
   move bline(50) _ "TOTAL RECORDS"; ntoa(progrecd,8,bline(70));        40940000
   printline;                                                           40945000
   tos _ 0;                                                             40950000
   fgetinfo(progfnum,,,,,,,,,,,,,,,s0);                                 40955000
   if tos < psax then warn(34);  <<more than one extent?>>              40960000
   go aok;                                                              40965000
                                                                        40970000
   <<* * * deallocate dl buffers * * *>>                                40975000
                                                                        40980000
   nfg:                                                                 40985000
   if progfnum <> 0 then  <<prog. file open?>>                          40990000
      begin                                                             40995000
      fpoint(progfnum,0d);                                              41000000
      fcontrol(progfnum,6,i)  <<set eof to 0>>                          41005000
      end;                                                              41010000
   badfile:                                                             41015000
   errorflag := errorflag+1;  <<set error flag>>                        41020000
                                                                        41025000
   aok:                                                                 41030000
   uslinfoincore _ false;  <<info block modified!>>                     41035000
   infoadr := double(-maxhead);  <<clear info adr.>>                    41040000
   getinfo;  <<try to reload info block>>                               41045000
   nrrlent _ 0;  <<mark rl table empty>>                                41050000
   @dlarea1 _ savedlarea1;  <<reset dl area 1 limit>>                   41055000
   @dlavail _ @dlarea2;  <<reset dl available area limit>>              41060000
                                                                        41065000
   <<* * * close rl library file * * *>>                                41070000
                                                                        41075000
   tos _ rlibfnum;                                                      41080000
   if <> then  <<rl library file open?>>                                41085000
      begin                                                             41090000
      fclose(*,0,0);                                                    41095000
      if < then  <<error?>>                                             41100000
         begin                                                          41105000
         tos _ 23;                                                      41110000
         tos _ 0d; fcheck(rlibfnum,s0);  <<file sys. error nr.>>        41115000
         errorn(*,*)                                                    41120000
         end;                                                           41125000
      tos := 0                                                          41130000
      end;                                                              41135000
   rlibfnum _ tos;                                                      41140000
                                                                        41145000
   <<* * * close program file * * *>>                                   41150000
                                                                        41155000
   if logical(errorflag) then                                  <<04781>>41160000
      begin                                                    <<04781>>41165000
         if permfnum <> 0 then fclose(permfnum,nochange,0);    <<04781>>41170000
         if progfnum <> 0 then fclose(progfnum,nochange,0);    <<04781>>41175000
      end                                                      <<04781>>41180000
   else                                                        <<04781>>41185000
   if permflag then                                            <<04781>>41190000
      begin                                                    <<04781>>41195000
         if progfnum = permfnum then                           <<04781>>41200000
            begin                                              <<04781>>41205000
               fclose'(progfnum,save);                         <<04781>>41210000
               if ferr <> -1 then                              <<04781>>41215000
                  errorn(msg'cantcloseprogfile,double(ferr));  <<04781>>41220000
            end                                                <<04781>>41225000
         else                                                  <<04781>>41230000
            begin                                              <<04781>>41235000
               fclose'(progfnum,save);                         <<04781>>41240000
               if ferr <> -1 then                              <<04781>>41245000
                  if ferr = dup'name then                      <<04781>>41250000
                     begin                                     <<04781>>41255000
                        fclose'(permfnum,delete);              <<04781>>41260000
                        if ferr <> -1 then                     <<04781>>41265000
                           copyprogfile                        <<04781>>41270000
                        else                                   <<04781>>41275000
                           begin                               <<04781>>41280000
                              fclose'(progfnum,save);          <<04781>>41285000
                              if ferr <> -1 then               <<04781>>41290000
                                 errorn(36,double(ferr));      <<04781>>41295000
                           end;                                <<04781>>41300000
                     end                                       <<04781>>41305000
                  else                                         <<04781>>41310000
                     copyprogfile                              <<04781>>41315000
               else                                            <<04781>>41320000
                  fclose'(permfnum,delete);                    <<04781>>41325000
            end                                                <<04781>>41330000
      end                                                      <<04781>>41335000
   else                                                        <<04781>>41340000
      begin                                                    <<04781>>41345000
         fclose'(progfnum,tempfile);                           <<04781>>41350000
         if ferr <> -1 then                                    <<04781>>41355000
            errorn(msg'cantcloseprogfile,double(ferr));        <<04781>>41360000
      end;                                                     <<04781>>41365000
   permfnum:=0;                                                <<04781>>41370000
   progfnum:=0;                                                <<04781>>41375000
                                                                        41380000
   <<* * * print elapsed time and process time * * *>>                  41385000
                                                                        41390000
   if not logical(errorflag) then  <<no errors?>>                       41395000
      begin                                                             41400000
      move bline := "ELAPSED TIME   00:00:00.000";                      41405000
      tos := timer-oldtimer;  <<elapsed time>>                          41410000
      tos := 1000; assemble(ldiv); ntoa(*,10,bline(26));  <<millisec.>> 41415000
      tos := 60; assemble(div); ntoa(*,10,bline(22));  <<seconds>>      41420000
      tos := 60; assemble(div); ntoa(*,10,bline(19));  <<minutes>>      41425000
      ntoa(*,10,bline(16));  <<hours>>                                  41430000
      move bline(45) := "PROCESSOR TIME   00:00.000";                   41435000
      tos := proctime-oldproctime;  <<processor time>>                  41440000
      tos := 1000; assemble(ldiv); ntoa(*,10,bline(70));  <<millisec.>> 41445000
      tos := 60; assemble(div); ntoa(*,10,bline(66));  <<seconds>>      41450000
      ntoa(*,10,bline(63));  <<minutes>>                                41455000
      printline                                                         41460000
      end;                                                              41465000
   ejectpage                                                            41470000
   end;                                                                 41475000
$page "CODE SEGMENT PREPARATION PROCEDURES - ALLOCATECOMMON"   <<00207>>41480000
$ control segment = seg23                                               41485000
procedure allocatecommon;                                               41490000
  <<allocates the blank common array and initializes the data           41495000
     labels>>                                                           41500000
   begin                                                                41505000
   byte array b0 (0:22)=pb := "COMMON ARRAY ALLOCATION";                41510000
   byte array b1(*) = pb := "NAME              ADR   LEN";     <<02817>>41515000
                                                               <<01124>>41520000
   <<* * * put data label in buffer * * *>>                    <<01124>>41525000
                                                               <<01124>>41530000
   condcode := cce;                                            <<06293>>41535000
   nwpdb := nwpdb+nrcoment;                                    <<01124>>41540000
   if overflow then overflowflag:=1;                           <<02816>>41545000
   if nwpdb > 256 then                                         <<06293>>41550000
      begin                                                    <<06293>>41555000
         error(msg'primdboverflow);                            <<06293>>41560000
         condcode := ccl;                                      <<06293>>41565000
         return;                                               <<06293>>41570000
      end;                                                     <<06293>>41575000
   @comp := @comtab;                                           <<01124>>41580000
   tos := @buf;                                                <<01124>>41585000
   tos := nrcoment;                                            <<01124>>41590000
   do begin                                                    <<01124>>41595000
      tos := comp(1)+nwpdb;                                    <<01124>>41600000
      if logical(comp) then tos := tos+nwpdb;                  <<01124>>41605000
      ps2 := tos;                                              <<01124>>41610000
      @comp := @comp+2;                                        <<01124>>41615000
      assemble(incb,deca);                                     <<01124>>41620000
      end until =;                                             <<01124>>41625000
   bufferdatawords(nwpdb-nrcoment,buf,nrcoment,1);  <<data labels>>     41630000
                                                                        41635000
   <<* * * print common array allocation map * * *>>                    41640000
                                                                        41645000
   move bline := b0,(23);                                               41650000
   printline;                                                           41655000
   blankline;                                                           41660000
   move bline(3) := b1, (27);                                  <<02817>>41665000
   printline;                                                           41670000
   @symp := @stable;  <<init. entry pointer>>                           41675000
   do begin                                                             41680000
      symentparms;  <<set entry parm's>>                                41685000
      if symtype = 6 then  <<common array entry?>>                      41690000
         begin                                                          41695000
         tos := @bline(3); tos := @sname&lsl(1)+1;                      41700000
         move * := *,(symnc);  <<common name>>                          41705000
         if snwca = 0 then  <<basic common?>>                           41710000
            begin                                                       41715000
            bline(23) := "?";  <<db address>>                           41720000
            bline(29) := "?"  <<length>>                                41725000
            end                                                         41730000
         else  <<regular common>>                                       41735000
            begin                                                       41740000
            ntoa(nwpdb+ssaca,8,bline(23));  <<db address>>              41745000
            ntoa(snwca,8,bline(29))  <<length>>                         41750000
            end;                                                        41755000
         printline                                                      41760000
         end;                                                           41765000
      @symp := @symp+symnw  <<next entry>>                              41770000
      end until @symp = @stable(usedsymbol);                            41775000
   blankline;                                                  <<01124>>41780000
   end;                                                                 41785000
$page "CODE SEGMENT PREPARATION PROCEDURES - COMPOSEFLUT"      <<00207>>41790000
$ control segment = seg23                                               41795000
integer procedure composeflut;                                          41800000
   <<composes the fortran logical unit table (flut) and inserts it      41805000
     into the program file.  the db starting address of the flut is     41810000
     then returned>>                                                    41815000
   begin                                                                41820000
   integer saflut = composeflut;                                        41825000
   tos := @buf;  <<flut buffer>>                                        41830000
   xreg := 99;  <<logical unit nr.>>                                    41835000
   do begin                                                             41840000
      if testbit(logicalunits,xreg) then  <<logical unit specified?>>   41845000
         begin                                                          41850000
         ps0 := xreg&lsl(8);  <<flut entry>>                            41855000
         @ps0 := @ps0+1  <<bump table index>>                           41860000
         end;                                                           41865000
      xreg := xreg-1                                                    41870000
      end until =;                                                      41875000
   ps0 := -1;  <<table terminator>>                                     41880000
   tos := tos-@buf+1;  <<flut length>>                                  41885000
   saflut := nwpdb+nwsdb;  <<s.a. of flut>>                             41890000
   bufferdatawords(saflut,buf,s0,1);  <<insert flut>>                   41895000
   nwsdb := tos + nwsdb;  <<adj. sec. db counter>>             <<02816>>41900000
   if overflow then overflowflag:=1;                           <<02816>>41905000
   end;                                                                 41910000
$page "CODE SEGMENT PREPARATION PROCEDURES - COMPOSESTLT"      <<00207>>41915000
$ control segment = seg23                                               41920000
procedure composestlt;                                                  41925000
   <<composes the symbol table location table (stlt) for trace and      41930000
     inserts it into the program file>>                                 41935000
   begin                                                                41940000
                                                                        41945000
   <<* * * compose and insert stlt preface * * *>>                      41950000
                                                                        41955000
   sastlt _ nwpdb+nwsdb;  <<s.a. of stlt>>                              41960000
   tos _ @buf; ps0 _ 0;  <<clear buffer>>                               41965000
   assemble(dup,incb); tos _ nwstltpreface; assemble(move 3);           41970000
   buf _ sastlt+nwstlt;  <<f.a.+1 of stlt>>                             41975000
   buf(7) _ if obpustadr = -1 then -1 else nwpdb+obpustadr;             41980000
   bufferdatawords(sastlt,buf,nwstltpreface,1);  <<stlt preface>>       41985000
                                                                        41990000
   <<* * * compose and insert stlt entries * * *>>                      41995000
                                                                        42000000
   tos _ sastlt+nwstltpreface;  <<init. db adr.>>                       42005000
   @symp_ @stable;                                                      42010000
   while @symp < @stable(usedsymbol) do                                 42015000
      begin                                                             42020000
      symentparms;                                                      42025000
      if symtype = 1 or symtype = 3 then                                42030000
         begin                                                          42035000
         tos _ ssasdb-ssapust;  <<pust length>>                         42040000
         if <> then  <<is there a pust?>>                               42045000
            begin                                                       42050000
            tos _ nwpdb+ssapust;  <<s.a. of pust>>                      42055000
            bufferdatawords(s2,as0,1,1);  <<s.a. of pust>>              42060000
            assemble(del,incb)                                          42065000
            end;                                                        42070000
         del                                                            42075000
         end;                                                           42080000
      @symp _ @symp+symnw  <<next entry>>                               42085000
      end;                                                              42090000
                                                                        42095000
   nwsdb := nwsdb + nwstlt;  <<adj. sec. db counter>>          <<02816>>42100000
   if overflow then overflowflag:=1;                           <<02816>>42105000
   end;                                                                 42110000
$page "CODE SEGMENT PREPARATION PROCEDURES - APPLYBLOCKDATAS"  <<00207>>42115000
$ control segment = seg23                                               42120000
procedure applyblockdatas;                                              42125000
   <<applys all active block data program units.  note that this        42130000
     procedure uses the condition code to indicate an error>>           42135000
   begin                                                                42140000
   define fatal' = (logical(entp(2).(1:1)))#,                           42145000
          warning' = (logical(entp(2).(2:1)))#;                         42150000
   tos _ uslbdl;  <<first block data adr.>>                             42155000
   while <> do                                                          42160000
      begin                                                             42165000
      getentry(*);                                                      42170000
      if active then                                                    42175000
         begin                                                          42180000
         if fatal' then  <<fatal error?>>                               42185000
            begin                                                       42190000
            errors(46,ename);                                           42195000
            go nfg                                                      42200000
            end;                                                        42205000
         if warning' then warns(47,ename);  <<non-fatal error?>>        42210000
         do begin                                                       42215000
            if not searchsym(bdp(1),symcommon) then  <<no common?>>     42220000
               begin                                                    42225000
               warns(68,bdp(1));                               <<00299>>42230000
                 <<skip to next common declaration>>           <<00299>>42235000
               while getnextheader(false,%(2)10000) do;        <<00299>>42240000
               go nextcom;                                     <<00299>>42245000
               end;                                                     42250000
            if bdp <> snwca then  <<different length?>>                 42255000
               begin                                                    42260000
               errors(69,bdp(1));                                       42265000
               preperror := preperror+1;                       <<01.dm>>42270000
               end;                                                     42275000
            sdbadr _ nwpdb+ssaca;                                       42280000
            while getnextheader(false,%(2)10000) do                     42285000
               header4p; <<sdb/own/data init. values>>         <<00299>>42290000
nextcom:                                                       <<00299>>42295000
            end until not blockdatareset                                42300000
         end;                                                           42305000
      tos _ ebl  <<next block data entry adr.>>                         42310000
      end;                                                              42315000
   tos _ cce;  <<ok condition code>>                                    42320000
   go getout;                                                           42325000
                                                                        42330000
   nfg:                                                                 42335000
   tos _ ccl;  <<error condition code>>                                 42340000
                                                                        42345000
   getout:                                                              42350000
   condcode _ tos  <<store condition code>>                             42355000
   end;                                                                 42360000
$page "SL FILE MAINTAINENCE PROCEDURES - OPENSL"               <<00207>>42365000
<<----------------------------------------------------------------------42370000
*                                                                      *42375000
*  sl file maintainence procedures                                     *42380000
*                                                                      *42385000
---------------------------------------------------------------------->>42390000
                                                                        42395000
$ control segment = seg30                                               42400000
procedure opensl (newfile);                                             42405000
   <<preserves any information in core that may be destroyed by         42410000
     loading the sl, then loads the sl and initializes the necessary    42415000
     global parameters.  if newfile is set, record 0 is initialized     42420000
     according to the parameters in the command buffer; otherwise       42425000
     record 0 is loaded>>                                               42430000
   value newfile; logical newfile;                                      42435000
   begin                                                                42440000
   integer savedlarea1;                                        <<00.dm>>42445000
   integer extsize;    <<extent size>>                         <<00.dm>>42450000
   double flsize;      <<file size>>                           <<00.dm>>42455000
   integer flag := 0;  <<dl buffers just allocated?>>          <<00.dm>>42460000
   integer aoptions := 0;                                      <<00563>>42465000
                                                                        42470000
   subroutine clear (flag,bitmap);                                      42475000
      logical flag;                                                     42480000
      array bitmap;                                                     42485000
      begin                                                             42490000
      flag _ false;                                                     42495000
      tos _ @bitmap; ps0 _ 0;                                           42500000
      assemble(dup,incb); tos _ 15; assemble(move 3)                    42505000
      end;                                                              42510000
                                                                        42515000
   <<* * * initialize local variables * * *>>                           42520000
                                                                        42525000
   savedlarea1 _ @dlarea1;  <<save dl area 1 limit>>           <<00.dm>>42530000
                                                                        42535000
   <<* * * allocate dl buffers * * *>>                                  42540000
                                                                        42545000
   if not slbufalloc then  <<buffers allocated?>>                       42550000
      begin                                                             42555000
      makeroomindl(sldlbufs1);                                          42560000
      if < then go nfg;  <<error?>>                                     42565000
      @slmap _ @dlarea1-128;                                            42570000
      @splrec1 _ @slmap-128;                                            42575000
      @splrec0 _ @splrec1-128;                                          42580000
      @spldir _ @splrec0-128;                                           42585000
      @rtbuf _ @spldir-128;                                             42590000
      @addedsegs _ @rtbuf-16;                                           42595000
      @deletedsegs _ @addedsegs-16;                                     42600000
      @modifiedsegs _ @deletedsegs-16;                                  42605000
      @dlarea1 := @modifiedsegs;  <<new dl area 1 limit>>               42610000
      slbufalloc := true;  <<set flag>>                                 42615000
      flag := flag+1  <<set flag>>                                      42620000
      end;                                                              42625000
                                                                        42630000
   <<* * * preserve overlayable information * * *>>                     42635000
                                                                        42640000
   closesl;                                                             42645000
   if < then go nfg;  <<error?>>                                        42650000
                                                                        42655000
   <<* * * load new sl information * * *>>                              42660000
                                                                        42665000
   if scratchfnum = 0 then  <<open scratch file?>>                      42670000
      begin                                                             42675000
      scratchfnum _ fopen(,%(2)10000000000,%(2)111010100,,,,,,,160d);   42680000
      if < then  <<error?>>                                             42685000
         begin                                                          42690000
         tos _ 82;                                                      42695000
         tos _ 0d; fcheck(0,s0);                                        42700000
         errorn(*,*);                                                   42705000
         go nfg                                                         42710000
         end                                                            42715000
      end;                                                              42720000
   if newfile then  <<init. record 0 and 1?>>                           42725000
      begin                                                             42730000
      if not (minsl <= filesize <= maxsl) then                          42735000
         begin                                                          42740000
         badspec:                                                       42745000
         error(17);                                                     42750000
         go nfg                                                         42755000
         end;                                                           42760000
      splfnum _ fopen(bfilename,%(2)10000000000,%(2)111010100,,,,,,,    42765000
         double(logical(filesize)),nrextents,,slfilecode);              42770000
      if < then  <<error?>>                                             42775000
         begin                                                          42780000
         fopenerror:                                                    42785000
         tos _ 18;                                                      42790000
         tos _ 0d; fcheck(0,s0);  <<file sys. error nr.>>               42795000
         errorn(*,*);                                                   42800000
         go nfg                                                         42805000
         end;                                                           42810000
                                                                        42815000
      <<* * * initialize record 0 * * *>>                               42820000
                                                                        42825000
      tos _ @splrec0; ps0 _ 0;                                          42830000
      assemble(dup,incb); tos _ 127; assemble(move 3);                  42835000
      spllid := slfileid;  <<version nr.>>                              42840000
      splfl _ filesize;  <<file length (in records)>>                   42845000
      << get nr rec's in extent >>                             <<00.dm>>42850000
      fgetinfo(splfnum,,,,,,,,,,,,,,,splel);                   <<00.dm>>42855000
      if splel < minslel then go badspec; <<too small>>        <<00.dm>>42860000
      splfrtl _ -1;  <<s.a. of free ref. table entry list>>             42865000
      slns _ (logical(filesize)+2047)&lsr(11);  <<nr. sections>>        42870000
                                                                        42875000
      <<* * * initialize free storage maps * * *>>                      42880000
                                                                        42885000
      tos _ slns;  <<section counter>>                                  42890000
      do begin                                                          42895000
         tos _ @slmap; ps0 _ -1;  <<init. map buffer>>                  42900000
         assemble(dup,incb); tos _ 127; assemble(move 3);               42905000
         if s0 = 1 then  <<first section?>>                             42910000
            begin                                                       42915000
            xreg _ slns+1;                                              42920000
            do begin                                                    42925000
               clearbit(slmap,xreg);                                    42930000
               xreg _ xreg-1                                            42935000
               end until <                                              42940000
            end;                                                        42945000
         if s0 = slns then  <<last section?>>                           42950000
            begin                                                       42955000
            tos _ splfl.(5:11);                                         42960000
            while <> do                                                 42965000
               begin                                                    42970000
               clearbit(slmap,s0);                                      42975000
               tos _ (tos+1).(5:11)                                     42980000
               end;                                                     42985000
            del                                                         42990000
            end;                                                        42995000
         fwritedir'(splfnum,slmap,s0+1);                                43000000
         tos _ tos-1                                                    43005000
         end until =;                                                   43010000
      tos _ false;  <<bypass sl checks>>                                43015000
      slstate.(1:2) := %(2)11  <<init. state word>>                     43020000
      end                                                               43025000
   else  <<load records 0 and 1>>                                       43030000
      begin                                                             43035000
      getprivmode;  <<get into priv. mode>>                             43040000
      splfnum _ fopen(bfilename,%(2)10000000011,%(2)111110110);         43045000
      if < then  <<error?>>                                             43050000
         begin                                                          43055000
         getusermode;  <<back into user mode>>                          43060000
         go fopenerror                                                  43065000
         end;                                                           43070000
      getusermode;  <<back into user mode>>                             43075000
      assemble(adds 5);                                                 43080000
      fgetinfo(splfnum,bbuf,s4,aoptions,,,s1,,s0,,,flsize,,,,  <<00563>>43085000
               extsize,nrextents,,,ds3);                       <<00563>>43090000
      if aoptions.(7:9) <> %766 then                           <<00563>>43095000
         begin                                                 <<00563>>43100000
         error(96);                                            <<00563>>43105000
         closesl;                                              <<00563>>43110000
         go nfg;                                               <<00563>>43115000
         end;                                                  <<00563>>43120000
      if tos <> slfilecode then                                <<s7689>>43125000
         begin                                                 <<s7689>>43130000
         error(19);                                            <<s7689>>43135000
         closesl;                                              <<s7689>>43140000
         go nfg                                                <<s7689>>43145000
         end;                                                  <<s7689>>43150000
      flock(splfnum,true);  <<get file exclusively>>           <<00563>>43155000
      freadmr'(splfnum,splrec0,p384,0); <<records 0,1 and map>><<00563>>43160000
      if spllid <> slfileid then                               <<s7689>>43165000
         begin                                                 <<s7689>>43170000
         error(19);                                            <<s7689>>43175000
         closesl;                                              <<s7689>>43180000
         go nfg                                                <<s7689>>43185000
         end;                                                  <<s7689>>43190000
      if nrextents <> 1 then                                   <<00.dm>>43195000
         if integer(flsize) <> splfl or extsize <> splel then  <<00.dm>>43200000
            begin                                              <<00.dm>>43205000
            closesl;                                           <<00198>>43210000
            error(19);  <<invalid sl file>>                    <<00.dm>>43215000
            go nfg;                                            <<00.dm>>43220000
            end;                                               <<00.dm>>43225000
      bs2 _ tos;  <<insert logical device nr.>>                         43230000
      slkey _ tos;  <<sl file key>>                                     43235000
      assemble(zero,xch);                                               43240000
      if tos and bbuf = "SL." then tos _ tos+1;  <<real sl file?>>      43245000
      slstate.(1:2) := %(2)00  <<init. state word>>                     43250000
      end;                                                              43255000
   realsl _ tos;  <<sl check flag>>                                     43260000
   if bbuf = "SL.PUB.SYS " then                                <<00807>>43265000
     begin                                                     <<00807>>43270000
       getprivmode;                                            <<00807>>43275000
       initloadcache;                                          <<00807>>43280000
       getusermode;                                            <<00807>>43285000
     end;                                                      <<00807>>43290000
                                                                        43295000
   <<* * * init. global parameters * * *>>                              43300000
                                                                        43305000
   assemble(dzro,dzro);                                                 43310000
   slmaprecd _ 2; slmapmodified _ tos;                                  43315000
   libentrymodified _ tos;                                              43320000
   rtrecd _ tos; rtmodified _ tos;                                      43325000
   clear(segsadded,addedsegs);                                          43330000
   clear(segsdeleted,deletedsegs);                                      43335000
   clear(segsmodified,modifiedsegs);                                    43340000
   go getout;                                                           43345000
                                                                        43350000
   nfg:                                                                 43355000
   if logical(flag) then  <<deallocate buffers?>>                       43360000
      begin                                                             43365000
      @dlarea1 := savedlarea1;  <<restore dl area 1 limit>>             43370000
      slbufalloc := false  <<clear flag>>                               43375000
      end;                                                              43380000
                                                                        43385000
   getout:                                                              43390000
   end;                                                                 43395000
$page "SL FILE MAINTAINENCE PROCEDURES - CLOSESL"              <<00207>>43400000
$ control segment = seg30                                               43405000
procedure closesl;                                                      43410000
   <<if a sl file is opened, saves the information in core that         43415000
     has been modified: saves records 0 and 1, if modified, and         43420000
     takes the transitive closure of the reference matrix, if           43425000
     necessary.  note that this procedure uses the condition code to    43430000
     indicate an error>>                                                43435000
   begin                                                                43440000
   tos := splfnum;  <<sl file nr.>>                                     43445000
   if <> then  <<sl opened?>>                                           43450000
      begin                                                             43455000
      fixupsl(false);                                                   43460000
      fclose(splfnum,slnew,0);  <<close sl file>>                       43465000
      if < then  <<error?>>                                             43470000
         begin                                                          43475000
         tos _ 10;                                                      43480000
         tos _ 0d; fcheck(splfnum,s0);  <<file sys. error nr.>>         43485000
         errorn(*,*);                                                   43490000
         tos _ ccl;  <<error condition code>>                           43495000
         go getout                                                      43500000
         end;                                                           43505000
      slstate.(1:2) := %(2)00;  <<re-set state word>>                   43510000
      splfnum := 0  <<clear file nr.>>                                  43515000
      end;                                                              43520000
   tos _ cce;  <<ok condition code>>                                    43525000
                                                                        43530000
   getout:                                                              43535000
   condcode _ tos  <<store condition code>>                             43540000
   end;                                                        <<00207>>43545000
$page "SL FILE MAINTAINENCE PROCEDURES - FINDSLSPACE"          <<00207>>43550000
$ control segment = seg30                                               43555000
integer procedure findslspace (nrrecs);                                 43560000
   <<finds space in the sl file for a block of nrrecs records such that 43565000
     the block does not span an extent.  the first record of the block  43570000
     is returned as the result.  note that this procedure uses the      43575000
     condition code to indicate an error>>                              43580000
   value nrrecs;                                                        43585000
   integer nrrecs;                                                      43590000
   begin                                                                43595000
   integer sectionnr = q+1;                                             43600000
   integer blocknr = q+2;                                               43605000
   integer blocks = q+3;                                                43610000
                                                                        43615000
   <<* * * initialize local variables * * *>>                           43620000
                                                                        43625000
   tos _ 0;  <<section nr.>>                                            43630000
   tos _ 0;  <<block nr.>>                                              43635000
   tos _ nrrecs;  <<nr. blocks needed>>                                 43640000
                                                                        43645000
   <<* * * search free storage maps * * *>>                             43650000
                                                                        43655000
   tos _ slns;  <<section counter>>                                     43660000
   do begin                                                             43665000
      getslmap(sectionnr);  <<load section map>>                        43670000
      blocknr _ 0;                                                      43675000
      tos _ 2048;  <<block counter>>                                    43680000
      do begin                                                          43685000
         if testbit(slmap,blocknr) and                                  43690000
            (nrrecs = 1 or                                     <<00465>>43695000
            (sectionnr&lsl(11)+blocknr+1) mod splel <> 0) then <<00465>>43700000
            begin                                                       43705000
            blocks _ blocks-1;  <<adj. blocks needed>>                  43710000
            if = then go foundspace                                     43715000
            end                                                         43720000
         else <<block not usable>>                                      43725000
            begin                                                       43730000
            blocks _ nrrecs;  <<reset blocks needed>>                   43735000
            findslspace :=       <<update s.a. of space>>               43740000
            (logical (sectionnr)&lsl (11))+logical (blocknr)+1;         43745000
            end;                                                        43750000
         blocknr _ blocknr+1;                                           43755000
         tos _ tos-1                                                    43760000
         end until =;                                                   43765000
      sectionnr _ sectionnr+1;                                          43770000
      assemble(del,deca)                                                43775000
      end until =;                                                      43780000
   error(11);  <<no room>>                                              43785000
   go nfg;                                                              43790000
                                                                        43795000
   <<* * * allocate space * * *>>                                       43800000
                                                                        43805000
   foundspace:                                                          43810000
   do begin                                                             43815000
      clearbit(slmap,blocknr);  <<mark block "USED">>                   43820000
      slmapmodified _ true;  <<set modified flag>>                      43825000
      blocknr _ blocknr-1;                                              43830000
      if < then                                                         43835000
         begin                                                          43840000
         blocknr _ 2047;                                                43845000
         sectionnr _ sectionnr-1;                                       43850000
         getslmap(sectionnr)  <<load next map>>                         43855000
         end;                                                           43860000
      nrrecs _ nrrecs-1                                                 43865000
      end until =;                                                      43870000
   tos _ cce;  <<ok condition code>>                                    43875000
   go getout;                                                           43880000
                                                                        43885000
   nfg:                                                                 43890000
   tos _ ccl;  <<error condition code>>                                 43895000
                                                                        43900000
   getout:                                                              43905000
   condcode _ tos                                                       43910000
   end;                                                                 43915000
$page "SL FILE MAINTAINENCE PROCEDURES - RETURNSLSPACE"        <<00207>>43920000
$ control segment = seg30                                               43925000
procedure returnslspace (recd,nrrecs);                                  43930000
   value recd,nrrecs;                                                   43935000
   integer recd,nrrecs;                                                 43940000
   <<returns nrrecs records of space in the sl file beginning with      43945000
     recd record>>                                                      43950000
   begin                                                                43955000
   tos _ recd.(0:5);  <<starting section nr.>>                          43960000
   tos _ recd.(5:11);  <<starting block nr.>>                           43965000
   getslmap(s1);  <<load section map>>                                  43970000
   do begin                                                             43975000
      setbit(slmap,s0);  <<mark block "FREE">>                          43980000
      slmapmodified _ true;  <<set modified flag>>                      43985000
      tos _ (tos+1).(5:11);                                             43990000
      if = then  <<new section?>>                                       43995000
         begin                                                          44000000
         s1 _ s1+1;                                                     44005000
         getslmap(s1)  <<load next section map>>                        44010000
         end;                                                           44015000
      nrrecs _ nrrecs-1                                                 44020000
      end until =                                                       44025000
   end;                                                                 44030000
$page "SL FILE MAINTAINENCE PROCEDURES - SLTOTALFREESPACE"     <<00465>>44035000
$ control segment = seg30                                      <<00465>>44040000
integer procedure sltotalfreespace;                            <<00465>>44045000
begin                                                          <<00465>>44050000
   integer blocks=sltotalfreespace;                            <<00465>>44055000
                                                               <<00465>>44060000
   tos := slns-1;  <<section counter>>                         <<00465>>44065000
   do begin                                                    <<00465>>44070000
      getslmap(s0); <<load section map>>                       <<00465>>44075000
      tos := 2047;  <<block counter>>                          <<00465>>44080000
      do begin                                                 <<00465>>44085000
         if testbit( slmap, s0) then blocks:=blocks+1;         <<00465>>44090000
         tos := tos-1;                                         <<00465>>44095000
         end until <;                                          <<00465>>44100000
      assemble( del, deca);                                    <<00465>>44105000
      end until <;                                             <<00465>>44110000
end;                                                           <<00465>>44115000
$page "SL FILE MAINTAINENCE PROCEDURES - GETSLMAP"             <<00465>>44120000
$ control segment = seg30                                               44125000
procedure getslmap (sectionnr);                                         44130000
   <<loads the bit map for the specified section number>>               44135000
   value sectionnr;                                                     44140000
   integer sectionnr;                                                   44145000
   begin                                                                44150000
   sectionnr _ sectionnr+1;                                             44155000
   sectionnr _ sectionnr+1;  <<convert to rec. nr.>>                    44160000
   if slmaprecd <> sectionnr then  <<different map?>>                   44165000
      begin                                                             44170000
      saveslmap;  <<save current map>>                                  44175000
      slmaprecd _ sectionnr;                                            44180000
      freaddir'(splfnum,slmap,slmaprecd)  <<load map>>                  44185000
      end                                                               44190000
   end;                                                                 44195000
$page "SL FILE MAINTAINENCE PROCEDURES - SAVESLMAP"            <<00207>>44200000
$ control segment = seg30                                               44205000
procedure saveslmap;                                                    44210000
   <<saves the current section bit map if it has been modified>>        44215000
   begin                                                                44220000
   if slmapmodified then  <<map modified?>>                             44225000
      begin                                                             44230000
      fwritedir'(splfnum,slmap,slmaprecd);                              44235000
      slmapmodified _ false  <<clear modified flag>>                    44240000
      end                                                               44245000
   end;                                                                 44250000
$page "SL FILE MAINTAINENCE PROCEDURES - SEARCHSEGNAME"        <<00207>>44255000
$ control segment = seg30                                               44260000
integer procedure searchsegname (name);                                 44265000
   <<searches the reference table entries for the given segment         44270000
     name.  if found, the segment number is returned and the            44275000
     reference table pointer (rtp) is set to the entry; otherwise       44280000
     a -1 is returned.  note that the name is a 16 byte array           44285000
     with no character count and with trailing blanks>>                 44290000
   byte array name;                                                     44295000
   begin                                                                44300000
   integer segnr = searchsegname;                                       44305000
   for segnr _ 0 until splnrt-1 do                                      44310000
      begin                                                             44315000
      getreftabentry(segnr);                                            44320000
      if not deletedseg then                                            44325000
         begin                                                          44330000
         tos _ @slrsegname&lsl(1);                                      44335000
         if * = name,(16) and not testbit(deletedsegs,segnr) then return44340000
         end                                                            44345000
      end;                                                              44350000
   segnr _ -1                                                           44355000
   end;                                                                 44360000
$page "SL FILE MAINTAINENCE PROCEDURES - SEARCHSPL"            <<00207>>44365000
$ control segment = seg30                                               44370000
logical procedure searchspl (name);                                     44375000
   <<searches the sl directory for the entry having the specified name. 44380000
     if the entry is found the value true is returned and the entry     44385000
     parameters are set; otherwise returns the value false.  note that  44390000
     this procedure saves the previous directory record number>>        44395000
   integer array name;                                                  44400000
   begin                                                                44405000
   cleanuplibbuf;  <<save modified entry>>                              44410000
   bucketindex _ splfhi+hash(name);  <<index of hash list>>             44415000
   splrecd _ 0;                                                         44420000
   slnextrecd _ splrec0(bucketindex);  <<first rec. in list>>           44425000
   while getnextlibrecd do                                              44430000
      begin                                                             44435000
      @splp _ @spldir(2);  <<init. entry pointer>>                      44440000
      while @splp < @spldir(slrecdused) do                              44445000
         begin                                                          44450000
         splentryparms;  <<get entry parm's>>                           44455000
         if name.(4:4) = splnc then                                     44460000
            begin                                                       44465000
            tos _ @name&lsl(1)+1; tos _ @splp&lsl(1)+1;                 44470000
            if * = *,(splnc) and not testbit(deletedsegs,slsegnr) then  44475000
               begin                                                    44480000
               searchspl _ true;                                        44485000
               return                                                   44490000
               end                                                      44495000
            end;                                                        44500000
         @splp _ @splp+splnw  <<next entry>>                            44505000
         end                                                            44510000
      end                                                               44515000
   end;                                                                 44520000
$page "SL FILE MAINTAINENCE PROCEDURES - GETNEXTLIBRECD"       <<00207>>44525000
$ control segment = seg30                                               44530000
logical procedure getnextlibrecd;                                       44535000
   <<loads the next record in the current hash list and sets the        44540000
     directory record parameters.  if there are no more records in      44545000
     the list, the value false is returned>>                            44550000
   begin                                                                44555000
   cleanuplibbuf;  <<save modified record>>                             44560000
   if slrecdused <> 2 then                                     <<04124>>44565000
   splprevrecd _ splrecd;  <<save previous rec. nr.>>                   44570000
   splrecd _ slnextrecd;  <<next record>>                               44575000
   if = then return;  <<no more records?>>                              44580000
   freaddir'(splfnum,spldir,splrecd);                                   44585000
   slnextrecd _ spldir;  <<save next rec. nr.>>                         44590000
   slrecdused _ spldir(1);  <<save used space count>>                   44595000
   getnextlibrecd _ true                                                44600000
   end;                                                                 44605000
$page "SL FILE MAINTAINENCE PROCEDURES - SPLENTRYPARMS"        <<00207>>44610000
$ control segment = seg30                                               44615000
procedure splentryparms;                                                44620000
   <<calculates the parameters of the sl entry pointed to by slp>>      44625000
   begin                                                                44630000
   splnc _ splp.(4:4);  <<nr. char's in entry name>>                    44635000
   splnamenw _ splnc&lsr(1)+1;  <<nr. words for entry name>>            44640000
   @splp1 _ @splp+splnamenw;  <<secondary pointer>>                     44645000
   splnw _ splnamenw+1+parmlen(slparms)                                 44650000
   end;                                                                 44655000
$page "SL FILE MAINTAINENCE PROCEDURES - SETLIBBUF"            <<00207>>44660000
$ control segment = seg30                                               44665000
procedure setuplibbuf;                                                  44670000
   <<initializes the directory and entry parameters for stepping        44675000
     through the directory>>                                            44680000
   begin                                                                44685000
   cleanuplibbuf;  <<save modified record>>                             44690000
   bucketindex _ splfhi-1;  <<init. hash list index>>                   44695000
   tos _ 0d; splrecd _ tos; slnextrecd _ tos;                           44700000
   slrecdused _ 2;                                                      44705000
   splnw _ 2;                                                           44710000
   @splp _ @spldir  <<init. entry pointer>>                             44715000
   end;                                                                 44720000
$page "SL FILE MAINTAINENCE PROCEDURES - GETNEXTLIBENTRY"      <<00207>>44725000
$ control segment = seg30                                               44730000
logical procedure getnextlibentry;                                      44735000
   <<loads the next directory entry and sets the entry parameters.      44740000
     returns the value false when the directory has been exhausted>>    44745000
   begin                                                                44750000
   @splp _ @splp+splnw;                                                 44755000
   if @splp = @spldir(slrecdused) then  <<read next record?>>           44760000
      begin                                                             44765000
      if not getnextlibrecd then  <<next hash list?>>                   44770000
         begin                                                          44775000
         do bucketindex _ bucketindex+1                                 44780000
            until splrec0(bucketindex) <> 0;                            44785000
         if bucketindex > 127 then return;  <<all done?>>               44790000
         splrecd _ 0;                                                   44795000
         slnextrecd _ splrec0(xreg);                                    44800000
         getnextlibrecd                                                 44805000
         end;                                                           44810000
      @splp _ @spldir(2)  <<reset pointer>>                             44815000
      end;                                                              44820000
   splentryparms;  <<get entry parameters>>                             44825000
   getnextlibentry _ true                                               44830000
   end;                                                                 44835000
$page "SL FILE MAINTAINENCE PROCEDURES - DELETELIBENTRY"       <<00207>>44840000
$ control segment = seg30                                               44845000
procedure deletelibentry;                                               44850000
   <<deletes the current entry from the directory record.  if the       44855000
     record is then empty, it is removed from the directory and         44860000
     inserted in the free record list>>                                 44865000
   begin                                                                44870000
   move splp _ splp(splnw),(slrecdused-@splp+@spldir-splnw);            44875000
   slrecdused _ slrecdused-splnw;  <<adj. used space count>>            44880000
   spldir(1) _ slrecdused;                                              44885000
   if slrecdused = 2 then  <<empty record?>>                            44890000
      begin                                                             44895000
      if splrec0(bucketindex) = splrecd                                 44900000
         then splrec0(xreg) _ spldir  <<new s.a. of hash list>>         44905000
         else repairrecord'(splfnum,splprevrecd,0,spldir);              44910000
      returnslspace(splrecd,1)                                          44915000
      end;                                                              44920000
   splnw _ 0;  <<zero entry length>>                                    44925000
   libentrymodified _ true;  <<set modified flag>>                      44930000
   end;                                                                 44935000
$page "SL FILE MAINTAINENCE PROCEDURES - CLEANUPLIBBUF"        <<00207>>44940000
$ control segment = seg30                                               44945000
procedure cleanuplibbuf;                                                44950000
   <<saves the current directory record if it has been modified>>       44955000
   begin                                                                44960000
   if libentrymodified then                                             44965000
      begin                                                             44970000
      fwritedir'(splfnum,spldir,splrecd);  <<write modified record>>    44975000
      libentrymodified _ false                                          44980000
      end                                                               44985000
   end;                                                                 44990000
$page "SL FILE MAINTAINENCE PROCEDURES - FINDDIRSPACE"         <<00207>>44995000
$ control segment = seg30                                               45000000
procedure finddirspace (hashcode,length);                               45005000
   <<finds a directory record in the specified hash list that is        45010000
     capable of holding a new entry of the specified length.  if        45015000
     no record can be found, a new record is allocated and linked into  45020000
     the hash list.  the entry pointer is set to the first word of the  45025000
     new entry and the used record space count is updated.  note that   45030000
     this procedure uses the condition code to indicate an error>>      45035000
   value hashcode,length;                                               45040000
   integer hashcode,length;                                             45045000
   begin                                                                45050000
   cleanuplibbuf;  <<save modified record>>                             45055000
   bucketindex _ splfhi+hashcode;  <<index of hash list>>               45060000
   splrecd _ 0;  <<init. record nr.>>                                   45065000
   slnextrecd _ splrec0(bucketindex);                                   45070000
   if <> then  <<empty hash list?>>                                     45075000
      do assemble(nop)  <<compiler kludge>>                             45080000
         until not getnextlibrecd or 128-slrecdused >= length;          45085000
   if splrecd = 0 then  <<get new record for hash list?>>               45090000
      begin                                                             45095000
      splrecd _ findslspace(1);  <<get a record>>                       45100000
      if < then go nfg;  <<no room?>>                                   45105000
      tos _ splrec0(bucketindex);  <<new hash link>>                    45110000
      splrec0(xreg) _ splrecd;  <<new s.a. of hash list>>               45115000
      tos _ 2;  <<used record count>>                                   45120000
      assemble(ddup);                                                   45125000
      splddir _ tos;  <<update buffer>>                                 45130000
      slrecdused _ tos;                                                 45135000
      slnextrecd _ tos;                                                 45140000
      splprevrecd _ 0  <<save. previous rec. nr.>>                      45145000
      end;                                                              45150000
   @splp _ @spldir(slrecdused);  <<set entry pointer>>                  45155000
   slrecdused _ slrecdused+length;  <<adj. used space count>>           45160000
   spldir(1) _ slrecdused;                                              45165000
   libentrymodified _ true;  <<set modified flag>>                      45170000
   tos _ cce;  <<ok condition code>>                                    45175000
   go getout;                                                           45180000
                                                                        45185000
   nfg:                                                                 45190000
   tos _ ccl;  <<error condition code>>                                 45195000
                                                                        45200000
   getout:                                                              45205000
   condcode _ tos  <<store condition code>>                             45210000
   end;                                                                 45215000
$page "SL FILE MAINTAINENCE PROCEDURES - INSERTSL"             <<00207>>45220000
$ control segment = seg30                                               45225000
procedure insertsl;                                                     45230000
   <<inserts the segment corresponding to the current segment entry     45235000
     in core into the sl file>>                                         45240000
   begin                                                                45245000
   integer savedlarea1;                                                 45250000
   byte array segname (0:15);                                           45255000
   integer nrentpts _ 0;  <<nr. entry points>>                          45260000
   integer listlen _ 0;  <<external list length>>                       45265000
   integer savesttnr;                                          <<04125>>45270000
   integer segrec;                << disk address of code seg ><<04102>>45275000
   double  segpointer;            << pmap scratch file segment <<04332>>45280000
                                  <<   record pointer.         <<04102>>45285000
   integer pmapnrsects;           << # sectors for pmap info >><<04102>>45290000
   integer pmaprec;               << disk address of pmap area <<04102>>45295000
   integer sirec;                 << disk address of si area >><<04102>>45300000
   integer rec;                   << for masterbuf >>          <<04102>>45305000
   integer disp;                  << for masterbuf >>          <<04102>>45310000
   integer array bufx(0:127);     << for masterbuf >>          <<04102>>45315000
   integer zero := 0;             << for call by reference >>  <<04102>>45320000
   integer status;                << status code returned >>   <<04102>>45325000
   integer silen;                                              <<06537>>45330000
                                                                        45335000
   <<* * * allocate dl buffers * * *>>                                  45340000
                                                                        45345000
   savedlarea1 _ @dlarea1;  <<save dl area 1 limit>>                    45350000
   makeroomindl(sldlbufs2);                                             45355000
   if < then go getout;  <<error?>>                                     45360000
   @symbol _ @dlarea1-95;                                               45365000
   @patch _ @symbol-128;                                                45370000
   @stt _ @patch-1;                                                     45375000
   @stable _ @stt-255;                                                  45380000
   @dlarea1 _ @stable;                                                  45385000
   tos _ @symbol; ps0 _ 0;                                              45390000
   assemble(dup,incb); tos _ 94; assemble(move 3);                      45395000
   tos _ @patch; ps0 _ -1;                                              45400000
   assemble(dup,incb); tos _ 127; assemble(move 3);                     45405000
   assemble(dzro,zero);                                                 45410000
   usedsymbol := tos; usedpatch := tos; programfile := tos;             45415000
                                                                        45420000
   <<* * * check for duplicate segment name * * *>>                     45425000
                                                                        45430000
   if splns = 254 then  <<too many segments?>>                 <<06538>>45435000
      begin                                                             45440000
      error(39);                                                        45445000
      go getout                                                         45450000
      end;                                                              45455000
   tos _ @segname; tos _ @ename&lsl(1)+1;                               45460000
   move * := *,(entnc),2;  <<segment name>>                             45465000
   move * := bline,(16-entnc);  <<trailing blanks>>                     45470000
   if searchsegname(segname) <> -1 then                                 45475000
      begin                                                             45480000
      errors(15,ename);                                                 45485000
      go getout                                                         45490000
      end;                                                              45495000
                                                                        45500000
   <<* * * get segment number and reference table entry * * *>>         45505000
                                                                        45510000
   slrec0mod _ true;  <<set modified flag>>                             45515000
   if splfrtl = -1 then  <<use new seg. nr.>>                           45520000
      begin                                                             45525000
      cstnr := splnrt;  <<segment nr.>>                                 45530000
      if cstnr >= 255 then                                     <<06538>>45535000
         begin                                                 <<06538>>45540000
            error(msg'toomanycodesegs);                        <<06538>>45545000
            go getout;                                         <<06538>>45550000
         end;                                                  <<06538>>45555000
      if splnrt.(14:2) = 0 then  <<new ref. tab. record needed?>>       45560000
         begin                                                          45565000
         tos _ findslspace(1);  <<find a record>>                       45570000
         if < then go getout;  <<no room?>>                             45575000
         splrec1(splnrt.(0:14)) := tos  <<rec. nr.>>                    45580000
         end;                                                           45585000
         getreftabentry(cstnr);  <<get ref. table entry>>               45590000
      splnrt _ splnrt+1  <<bump nr. of ref. tab. entries>>              45595000
      end                                                               45600000
   else  <<reuse deleted seg. nr.>>                                     45605000
      begin                                                             45610000
      cstnr := splfrtl;  <<segment nr.>>                                45615000
      getreftabentry(cstnr);  <<get ref. table entry>>                  45620000
      splfrtl _ rtp  <<new s.a. of free ref. tab. entries>>             45625000
      end;                                                              45630000
   tos _ @rtp; ps0 _ 0;  <<init. ref. tab. entry>>                      45635000
   assemble(dup,incb); tos := 31; assemble(move 3);                     45640000
   tos _ @slrsegname&lsl(1);                                            45645000
   move * := segname,(16);  <<insert segment name>>                     45650000
                                                                        45655000
   <<* * * put entry points in directory * * *>>                        45660000
                                                                        45665000
   siseen := false;                                            <<04102>>45670000
   toolboxid := spllasttoolboxid;                              <<04102>>45675000
   pmapnw:=double(entnamenw+segpmaplen+1);                     <<04102>>45680000
   scansegment(entfileadr);  <<fill symbol table>>                      45685000
   if < then go abort1;  <<error?>>                                     45690000
   if not siseen then                                          <<04102>>45695000
      symdbug := false;                                        <<04102>>45700000
   if symdbug then fpmap:=1;                                   <<04102>>45705000
   @symp _ @stable;                                                     45710000
   while @symp < @stable(usedsymbol) do                                 45715000
      begin                                                             45720000
      symentparms;  <<set sym. tab. entry parms>>                       45725000
      if not shidden then  <<skip entry point?>>                        45730000
         begin                                                          45735000
         if searchspl(sname) then  <<duplicate name?>>                  45740000
            begin                                                       45745000
            errors(12,slname);                                          45750000
            go abort                                                    45755000
            end;                                                        45760000
         tos := symnw;  <<sym. tab. entry length>>                      45765000
         if symtype = 3 then tos := tos-5 else tos := tos-3;            45770000
         finddirspace(hash(sname),s0);  <<get dir. record>>             45775000
         if < then go abort;  <<no room?>>                              45780000
         tos _ symnamenw+1;  <<length of name and p-label>>             45785000
         move slname _ sname,(s0),2;  <<name and p-label>>              45790000
         tos := @sparms;  <<parm. info pointer>>                        45795000
         assemble(dxch,sub);  <<parm. info length>>                     45800000
         assemble(move 3);  <<parm. info>>                              45805000
         splp.(3:1):=if flags.(0:3)<>0 then 1 else 0;          <<paloc>>45810000
         nrentpts := nrentpts+1                                         45815000
         end;                                                           45820000
      @symp _ @symp+symnw  <<next sym. tab. entry>>                     45825000
      end;                                                              45830000
   if nrentpts = 0 then  <<no entry points?>>                           45835000
      begin                                                             45840000
      error(42);                                                        45845000
      go abort1                                                         45850000
      end;                                                              45855000
                                                               <<04102>>45860000
   <<* * * open the pmap scratch file. * * *>>                 <<04102>>45865000
                                                               <<04102>>45870000
   if fpmap then  begin                                        <<04102>>45875000
   createpmapscratch(1, status);                               <<04102>>45880000
   if status <> status'ok then                                 <<04102>>45885000
      go abort;                                                <<04102>>45890000
   end;                                                        <<04102>>45895000
                                                               <<04102>>45900000
   <<* * * open the si scratch file. * * *>>                   <<04102>>45905000
                                                               <<04102>>45910000
   if symdbug then                                             <<04102>>45915000
      begin                                                    <<04102>>45920000
      createsiscratch(status);                                 <<04102>>45925000
      if status <> status'ok then                              <<04102>>45930000
         go abort;                                             <<04102>>45935000
      end;                                                     <<04102>>45940000
                                                                        45945000
   <<* * * allocate dl buffers * * *>>                                  45950000
                                                                        45955000
   @ptable _ @dlarea2;                                                  45960000
   @dlavail _ @dlarea2;                                                 45965000
                                                                        45970000
   <<* * * prepare segment into scratch file * * *>>                    45975000
                                                                        45980000
   savesttnr := sttnr;                                         <<04125>>45985000
   sttnr     := sttnr + sttppnr;                               <<04125>>45990000
   sttppnr   := savesttnr;                                     <<04125>>45995000
   preparesegment(entfileadr,scratchfnum,0);                            46000000
   if < then go abort;  <<error?>>                                      46005000
                                                               <<04102>>46010000
   <<* * * repair pmap segment record. * * *>>                 <<04102>>46015000
                                                               <<04102>>46020000
   if fpmap then  begin                                        <<04102>>46025000
   corebufpmap(zero, 1);                                       <<04102>>46030000
   if pmaprecnr <> 1 then                                      <<04102>>46035000
      begin                                                    <<04102>>46040000
      fwritedir'(pmapfilenr, pmapbuf, pmaprecnr);              <<04102>>46045000
      pmaprecnr := 1;                                          <<04102>>46050000
      freaddir'(pmapfilenr, pmapbuf, pmaprecnr);               <<04102>>46055000
      end;                                                     <<04102>>46060000
   pmapbufdisp:=typetable+3+pmapbuf(typetable+2).(4:4)&lsr(1); <<04102>>46065000
   pmapbuf(pmapbufdisp) := cstnr cat sttnr (0:8:8);            <<04102>>46070000
   pmapbuf(pmapbufdisp + 1) := seglen;                         <<04102>>46075000
   end;                                                        <<04102>>46080000
   ejectpage;                                                           46085000
                                                                        46090000
   <<* * * attach stt map array * * *>>                                 46095000
                                                                        46100000
   tos := @buf; ps0 := -1;                                              46105000
   assemble(dup,incb); tos := 127; assemble(move 3);                    46110000
   corebuf1(buf,128);                                                   46115000
                                                                        46120000
   <<* * * compose and attach symbolic external list * * *>>            46125000
                                                                        46130000
   @symp _ @stable;                                                     46135000
   while @symp < @stable(usedsymbol) do                                 46140000
      begin                                                             46145000
      symentparms;                                                      46150000
      if symtype = 7 then  <<external entry?>>                          46155000
         begin                                                          46160000
         sname.(0:4) _ 0;  <<clear flag bits>>                          46165000
         corebuf1(sname,symnamenw);  <<external name>>                  46170000
         corebuf1(sxlplabel,symnw-symnamenw-3);  <<p-label and parm's>> 46175000
         listlen _ listlen+symnw-3  <<adj. list length>>                46180000
         end;                                                           46185000
      @symp _ @symp+symnw                                               46190000
      end;                                                              46195000
   tbuf1(tdisp1) _ 0;  <<list terminator>>                              46200000
   fwritedir'(scratchfnum,tbuf1,trecd1);                                46205000
                                                                        46210000
   <<* * * transfer segment to sl file * * *>>                          46215000
                                                                        46220000
   listlen _ (seglen+listlen+p256)&lsr(7);  <<nr. records>>             46225000
   segrec := findslspace(listlen);  << find space for segment ><<04102>>46230000
   if < then go abort;  <<no room?>>                                    46235000
   xreg _ listlen-1;                                                    46240000
   do begin                                                             46245000
      freaddir'(scratchfnum,buf,xreg);                                  46250000
      fwritedir'(splfnum, buf, segrec + xreg);                 <<04102>>46255000
      xreg _ xreg-1                                                     46260000
      end until <;                                                      46265000
                                                               <<04102>>46270000
   <<* * * pass scratch files to toolbox son process. * * *>>  <<04102>>46275000
                                                               <<04102>>46280000
   if fpmap then                                               <<04332>>46285000
   begin                                                       <<04332>>46290000
   << scratch pmap file is in the form of program pmap >>      <<04332>>46295000
   << so it is necessary to update seg pointer field.  >>      <<04332>>46300000
   << this pointer will be used when segsym program    >>      <<04332>>46305000
   << massage the scratch file using pmap intrinsic.   >>      <<04332>>46310000
   << in this case there is only one seg pointer.      >>      <<04332>>46315000
   segpointer := double(128 + typetablelen + 2);               <<04332>>46320000
   activatetoolbox(segpointer, 1, status);                     <<04102>>46325000
   if status <> status'ok then                                 <<04102>>46330000
      go abort;                                                <<04102>>46335000
                                                               <<04102>>46340000
   <<* * * copy pmap scratch file to sl file. * * *>>          <<04102>>46345000
                                                               <<04102>>46350000
   pmapnrsects:=integer((pmapnw+double(typetablelen)+127d)     <<04102>>46355000
                         &dlsr(7));                            <<04102>>46360000
   pmaprec := findslspace(pmapnrsects); << find space for pmap><<04102>>46365000
   if < then                                                   <<04102>>46370000
      go abort;                                                <<04102>>46375000
   rec := pmaprec;                                             <<04102>>46380000
   disp := 0;                                                  <<04102>>46385000
   masterbufd(splfnum, pmapfilenr, bufx, rec, disp,            <<04102>>46390000
             true,128d,buf,double(typetablelen));              <<04102>>46395000
   masterbufd(splfnum,pmapfilenr,bufx,rec,disp,true,           <<04102>>46400000
              double(128+2+typetablelen),buf,pmapnw);          <<04102>>46405000
   if disp <> 0 then                                           <<04102>>46410000
      fwritedir'(splfnum, bufx, rec);                          <<04102>>46415000
   fclose(pmapfilenr, 4, 0);                                   <<04102>>46420000
      if <> then                                               <<04102>>46425000
         begin                                                 <<04102>>46430000
         error(msg'cantclosescratch);                          <<04102>>46435000
         go abort;                                             <<04102>>46440000
         end;                                                  <<04102>>46445000
   end   else                                                  <<04102>>46450000
      pmaprec:=0;                                              <<04102>>46455000
                                                               <<04102>>46460000
   <<* * * copy si scratch file to sl file. * * *>>            <<04102>>46465000
                                                               <<04102>>46470000
   if symdbug then                                             <<04102>>46475000
      begin                                                    <<04102>>46480000
      sirec := findslspace(feof(sifilenr));                    <<04102>>46485000
      if < then                                                <<04102>>46490000
         go abort;                                             <<04102>>46495000
      silen := feof(sifilenr);                                 <<06537>>46500000
      rec := sirec;                                            <<04102>>46505000
      disp := 0;                                               <<04102>>46510000
      masterbufd(splfnum, sifilenr, bufx, rec, disp,           <<04102>>46515000
                true, 0d, buf, double(feof(sifilenr))*128d);   <<04102>>46520000
      if disp <> 0 then                                        <<04102>>46525000
         fwritedir'(splfnum, bufx, rec);                       <<04102>>46530000
      fclose(sifilenr, 4, 0);                                  <<04102>>46535000
         if <> then                                            <<04102>>46540000
            begin                                              <<04102>>46545000
            error(msg'cantclosescratch);                       <<04102>>46550000
            go abort;                                          <<04102>>46555000
            end;                                               <<04102>>46560000
      end                                                      <<04102>>46565000
   else                                                        <<04102>>46570000
      sirec := 0;                                              <<04102>>46575000
                                                                        46580000
   <<* * * initialize reference table entry * * *>>                     46585000
                                                                        46590000
   tos _ seglen;  <<segment length>>                                    46595000
   tos.(0:1) _ segprivileged;  <<load in priv. mode?>>                  46600000
   rtp _ tos;                                                           46605000
   slrsa := segrec;                                            <<04102>>46610000
   slrnr _ listlen;  <<nr. rec's for segment>>                          46615000
   tos _ nrentpts;  <<nr. entry points>>                                46620000
   tos.(4:3) _ flags.(0:3);  <<segment flags>>                          46625000
   slrflags _ tos;  <<insert segment flags>>                            46630000
   slrpmaprec := pmaprec;                                      <<04102>>46635000
   slrsirec   := sirec;                                        <<04102>>46640000
   slrsilen   := silen;                                        <<06537>>46645000
   if checksumspecified then                                   <<04257>>46650000
      slrcksum:=1;                                             <<04257>>46655000
   if initpatch >= 0 then                                      <<04257>>46660000
      slrpatch:=1;                                             <<04257>>46665000
   setbit(slrrefedsegs,cstnr);  <<set own segment bit>>                 46670000
   rtmodified _ true;  <<set modified flag>>                            46675000
                                                                        46680000
   segsadded _ true;  <<set seg. added flag>>                           46685000
   setbit(addedsegs,cstnr);  <<set added seg. bit>>                     46690000
   splns _ splns+1;  <<bump nr. segments>>                              46695000
   go getout;                                                           46700000
                                                                        46705000
   abort:                                                               46710000
   setuplibbuf;                                                         46715000
   while getnextlibentry do                                             46720000
      if slsegnr = cstnr then deletelibentry;                           46725000
                                                                        46730000
   abort1:                                                              46735000
   rtp _ splfrtl;  <<free ref. tab. entry link>>                        46740000
   splfrtl _ cstnr;  <<new s.a. of free ref. tab. list>>                46745000
   rtp(3) _ -1;  <<set deleted segment bit>>                            46750000
   rtmodified _ true;  <<set modified flag>>                            46755000
                                                                        46760000
   getout:                                                              46765000
   usedpatch _ 0;  <<mark patch table empty>>                           46770000
   @dlarea1 _ savedlarea1;  <<reset dl area 1 limit>>                   46775000
   @dlavail _ @dlarea2  <<reset dl available area limit>>               46780000
   end;                                                                 46785000
$page "SL FILE MAINTAINENCE PROCEDURES - FIXUPSL"              <<00207>>46790000
$ control segment = seg30                                               46795000
procedure fixupsl (refix);                                              46800000
   <<restores segment linkage after segments have been added,           46805000
     deleted or modified:                                               46810000
     1. steps thru the directory and removes any entries that are       46815000
        from deleted segments                                           46820000
     2. frees the space taken up by a segment that has been deleted     46825000
     3. frees the reference table entry of those segments that have     46830000
        deleted                                                         46835000
     4. restores segment linkage by binding and re-binding              46840000
     5. takes the transitive closure of the referenced segment          46845000
        matrix                                                          46850000
     the refix flag indicates that the transitive closure operation     46855000
     is not to be performed>>                                           46860000
   value refix;                                                         46865000
   logical refix;                                                       46870000
   begin                                                                46875000
   integer i;                                                           46880000
                                                                        46885000
   subroutine clear (flag,bitmap);                                      46890000
      logical flag;                                                     46895000
      array bitmap;                                                     46900000
      begin                                                             46905000
      flag _ false;                                                     46910000
      tos _ @bitmap; ps0 _ 0;                                           46915000
      assemble(dup,incb); tos _ 15; assemble(move 3)                    46920000
      end;                                                              46925000
   if segsadded or segsdeleted or segsmodified then                     46930000
      begin                                                             46935000
      if segsdeleted then                                               46940000
         begin                                                          46945000
                                                                        46950000
         <<* * * remove directory entries * * *>>                       46955000
                                                                        46960000
         setuplibbuf;                                                   46965000
         while getnextlibentry do                                       46970000
            if testbit(deletedsegs,slsegnr) then deletelibentry;        46975000
                                                                        46980000
         <<* * * remove segments * * *>>                                46985000
                                                                        46990000
         for i _ 0 until splnrt-1 do                                    46995000
            if testbit(deletedsegs,i) then                              47000000
               begin                                                    47005000
               getreftabentry(i);                                       47010000
               returnslspace(slrsa,slrnr);  <<delete segment>>          47015000
               rtp _ splfrtl;  <<free ref. tab. entry link>>            47020000
               splfrtl _ i;  <<new s.a. of free list>>                  47025000
               slrdeletedbit _ true;  <<set segment deleted bit>>       47030000
               rtmodified _ true  <<set modified flag>>                 47035000
               end;                                                     47040000
         slrec0mod _ true                                               47045000
         end;                                                           47050000
      bindsegs;                                                         47055000
      if not refix then                                                 47060000
         begin                                                          47065000
         transclosure;                                                  47070000
         clear(segsadded,addedsegs);                                    47075000
         clear(segsdeleted,deletedsegs);                                47080000
         clear(segsmodified,modifiedsegs)                               47085000
         end                                                            47090000
      end;                                                     <<00230>>47095000
   if slrec0mod then <<records 0,1 modified?>>                 <<00230>>47100000
      begin                                                    <<00230>>47105000
      fwritemr'(splfnum,splrec0,p256,0);<<save recs 0,1>>      <<00230>>47110000
      slrec0mod := false;   <<clear flag>>                     <<00230>>47115000
      end;                                                     <<00230>>47120000
   cleanuplibbuf; <<save directory buffer>>                    <<00230>>47125000
   cleanuprtbuf;  <<save ref. tab. buffer>>                    <<00230>>47130000
   saveslmap;     <<save map buffer>>                          <<00230>>47135000
   end;                                                                 47140000
$page "SL FILE MAINTAINENCE PROCEDURES - BINDSEGS"             <<00207>>47145000
$ control segment = seg30                                               47150000
procedure bindsegs;                                                     47155000
   <<steps thru the segment external lists and binds the externals.     47160000
     if a bind operation is indicated (segsadded = true) then           47165000
     tries to satisfy those externals that are unsatisfied.  if         47170000
     a re-bind operation is indicated (segsdeleted = true) then         47175000
     tries to re-satisfy all externals of a segment that referenced     47180000
     one of the deleted segments>>                                      47185000
   begin                                                                47190000
   integer i;  <<seg. nr.>>                                             47195000
   logical allsatisfied;  <<all externals satisfied?>>                  47200000
   logical badseg := false;  <<binding error?>>                         47205000
   integer l;           <<counts external per seg>>                     47210000
   logical array badsegs(0:15);  <<segments in error>>                  47215000
   array parms(0:4)=q;                                         <<00595>>47220000
                                                                        47225000
   logical subroutine refchangedseg;                                    47230000
      <<checks to see if the current segment references (directly       47235000
        or indirectly) a segment that has been modified or deleted>>    47240000
      begin                                                             47245000
      tos := @slrrefedsegs;  <<segments referenced>>                    47250000
      tos := 0;  <<flag>>                                               47255000
      xreg := 15;  <<seg. map index>>                                   47260000
      do begin                                                          47265000
         if segsmodified then                                           47270000
            tos := tos lor (modifiedsegs(xreg) land lps1(xreg));        47275000
         if segsdeleted then                                            47280000
            tos := tos lor (deletedsegs(xreg) land lps1(xreg));         47285000
         xreg := xreg-1                                                 47290000
         end until <;                                                   47295000
      if tos <> 0 then  <<segments referenced?>>                        47300000
         begin                                                          47305000
         assemble(dup,zero); ps1 := tos;                                47310000
         assemble(dup,incb); tos := 15; assemble(move 3);               47315000
         setbit(ps0,i);                                                 47320000
         s2 := true  <<set result>>                                     47325000
         end;                                                           47330000
      del                                                               47335000
      end;                                                              47340000
                                                                        47345000
   tos _ @badsegs; ps0 _ 0;                                             47350000
   assemble(dup,incb); tos _ 15; assemble(move 3);                      47355000
   cleanuplibbuf;                                                       47360000
   for i _ 0 until splnrt-1 do                                          47365000
      begin                                                             47370000
      getreftabentry(i);                                                47375000
      if not deletedseg then  <<deleted segment?>>                      47380000
         if refchangedseg or segsadded and not satisfiedseg then        47385000
            begin                                                       47390000
            l := integer (allsatisfied := true);                        47395000
            loadslstt;  <<load stt, etc.>>                              47400000
            while getnextslextn do                                      47405000
               begin                                                    47410000
               if (l:=l+1)=0 then       <<first external>>              47415000
                allsatisfied := slrsatisbit;<<the way it was>>          47420000
               if segsadded and not slsatisextn or                      47425000
                  (segsmodified or segsdeleted) and slsatisextn then    47430000
                  if searchspl(slxname) then  <<satisfiable>>           47435000
                     begin                                              47440000
                     if not slsatisextn or slsegnr <> slxsegnr then     47445000
                        begin                                           47450000
                        parmcheck(slparms,slxparms,parms);     <<00595>>47455000
                        if parms <> 0 then <<error?>>          <<00595>>47460000
                           begin                               <<00595>>47465000
                           setbit(badsegs,if testbit(addedsegs,i)       47470000
                              then i else slsegnr);            <<00595>>47475000
                           badseg := true;                     <<00595>>47480000
                           case parms of                       <<00595>>47485000
                              begin                            <<00595>>47490000
                              ;                                <<00595>>47495000
                              errors(49,slxname);              <<00595>>47500000
                              errors(50,slxname);              <<00595>>47505000
                              begin                            <<00595>>47510000
                                 errors(45,slxname);           <<00595>>47515000
                                 printbitmap(parms(1));        <<00595>>47520000
                              end;                             <<00595>>47525000
                              end;                             <<00595>>47530000
                           end;                                <<00595>>47535000
                        tos _ slplabel;  <<entry point p-label>>        47540000
                        if < then  <<illegal p-label?>>                 47545000
                           begin                                        47550000
                           errors(43,slxname);                          47555000
                           setbit(badsegs,if testbit(addedsegs,i)       47560000
                              then i else slsegnr);            <<st.tc>>47565000
                           badseg _ true; <<set bad seg. flag>><<st.tc>>47570000
                           end;                                         47575000
                        tos.(0:1) := 1;  <<set "EXTERNAL" bit>>         47580000
                        sttp(-slxsttnr) := s0;  <<insert p-label>>      47585000
                        xreg := -xreg;  <<stt nr.>>                     47590000
                        slsttmap(xreg) := tos;  <<seg. nr.>>            47595000
                        slxsatisbit _ true;  <<set satisfied bit>>      47600000
                        allsatisfied := allsatisfied land 1             47605000
                                                     lor (l=0);         47610000
                        slxsegnr _ slsegnr;  <<seg. nr.>>               47615000
                        slsttmodified := true  <<set modified flag>>    47620000
                        end;                                            47625000
                     setbit(slrrefedsegs,slsegnr)  <<set seg. bit>>     47630000
                     end                                                47635000
                  else  <<unsatisfiable>>                               47640000
                     begin                                              47645000
                     if slsatisextn then  <<currently satisfied?>>      47650000
                        begin                                           47655000
                        slsttmap(slxsttnr) := -1;  <<clear seg. nr.>>   47660000
                        slxsegnr := i; <<make internal>>       <<00198>>47665000
                        slxsatisbit _ false;  <<clear satisfied bit>>   47670000
                        slsttmodified := true  <<set modified flag>>    47675000
                        end;                                            47680000
                     allsatisfied _ false  <<one or more unsatis.>>     47685000
                     end;                                               47690000
               end;                                                     47695000
            storeslstt;  <<save stt, etc.>>                             47700000
            slrsatisbit _ allsatisfied;  <<all extn's satisfied?>>      47705000
            rtmodified _ true  <<set modified flag>>                    47710000
            end                                                         47715000
      end;                                                              47720000
   if badseg then  <<binding error?>>                                   47725000
      begin                                                             47730000
      segsadded _ false;                                                47735000
      segsmodified _ false;                                             47740000
      segsdeleted _ true;                                               47745000
      move deletedsegs _ badsegs,(16);                                  47750000
      fixupsl(true);  <<delete and re-bind>>                            47755000
      splns _ splns-sumbits(badsegs)  <<adj. nr. seg's>>                47760000
      end                                                               47765000
   end;                                                                 47770000
$page "SL FILE MAINTENANCE PROCEDURE - COUNTSISPACE"                    47775000
procedure countsispace(len);                                   <<04782>>47780000
                                                               <<04782>>47785000
integer len;                                                   <<04782>>47790000
                                                               <<04782>>47795000
<< this procedure count the number of records occupied >>      <<04782>>47800000
<< by the si info of a sl segment. reference table     >>      <<04782>>47805000
<< pointer need to set to the segment prior to call    >>      <<04782>>47810000
<< this procedure. len = 0 returned if there is no si  >>      <<04782>>47815000
<< info included for this segment.                     >>      <<04782>>47820000
                                                               <<04782>>47825000
begin                                                          <<04782>>47830000
                                                               <<04782>>47835000
   len:=0;                                                     <<04782>>47840000
   if slrsirec <> 0 then                                       <<04782>>47845000
      begin                                                    <<04782>>47850000
         len:=slrsilen;                                        <<06537>>47855000
      end;                                                     <<04782>>47860000
end;                                                           <<04782>>47865000
$page "SL FILE MAINTENANCE PROCEDURE - COUNTPMAPSPACE"                  47870000
procedure countpmapspace(len);                                 <<04782>>47875000
                                                               <<04782>>47880000
integer len;                                                   <<04782>>47885000
                                                               <<04782>>47890000
<< this procedure count the number of records occupied >>      <<04782>>47895000
<< by the pamp info of a sl segment. reference table   >>      <<04782>>47900000
<< pointer need to set to the segment prior to call    >>      <<04782>>47905000
<< this procedure. len = 0 returned if there is no     >>      <<04782>>47910000
<< pmap info included for this segment.                >>      <<04782>>47915000
                                                               <<04782>>47920000
begin                                                          <<04782>>47925000
                                                               <<04782>>47930000
equate maxpmaptype=5;<<change this constant if add new type>>  <<04782>>47935000
integer array pmapinfo(0:127);                                 <<04782>>47940000
integer array typetable'(0:maxpmaptype);                       <<04782>>47945000
logical terminated;                                            <<04782>>47950000
logical nextrecord;    <<entry extend to next record>>         <<04782>>47955000
integer offset;   <<word offset>>                              <<04782>>47960000
integer entrysize;                                             <<04782>>47965000
                                                               <<04782>>47970000
len:=0;                                                        <<04782>>47975000
if slrpmaprec <> 0 then                                        <<04782>>47980000
   begin                                                       <<04782>>47985000
      terminated:=false;                                       <<04782>>47990000
      freaddir'(osplfnum,pmapinfo,slrpmaprec);                 <<04782>>47995000
      move typetable' := pmapinfo,(pmapinfo);                  <<04782>>48000000
      offset:=typetable';                                      <<04782>>48005000
      while not terminated do      << count pmap record number <<04782>>48010000
         begin                                                 <<04782>>48015000
            freaddir'(osplfnum,pmapinfo,slrpmaprec+len);       <<04782>>48020000
            nextrecord:=false;                                 <<04782>>48025000
            terminated:=(pmapinfo(offset) = 0);                <<04782>>48030000
            while not terminated and not nextrecord do         <<04782>>48035000
               begin                                           <<04782>>48040000
                  entrysize := pmapinfo(offset).(4:4)/2+1+     <<04782>>48045000
                        typetable'(pmapinfo(offset).(0:4)+1);  <<04782>>48050000
                  offset:=offset+entrysize;                    <<04782>>48055000
                  if offset > 127 then                         <<04782>>48060000
                     begin                                     <<04782>>48065000
                        nextrecord:=true;                      <<04782>>48070000
                        offset:=offset-128;                    <<04782>>48075000
                     end                                       <<04782>>48080000
                  else terminated:=(pmapinfo(offset) = 0);     <<04782>>48085000
               end;                                            <<04782>>48090000
            len:=len+1;                                        <<04782>>48095000
         end;                                                  <<04782>>48100000
   end;                                                        <<04782>>48105000
end;                                                           <<04782>>48110000
$page "SL FILE MAINTENANCE PROCEDURE - TRANSCLOSURE"                    48115000
$ control segment = seg30                                               48120000
procedure transclosure;                                                 48125000
   <<gets the transitive closure of the reference table and             48130000
     inserts it back in the file>>                                      48135000
   begin                                                                48140000
   integer n = q+1;  <<same as splnrt - avoids indexing>>               48145000
   integer range = q+2;  <<nr. words between first and last rows>>      48150000
   integer pointer m = q+3;  <<incidence matrix>>                       48155000
   logical pointer mj = q+4;  <<points to first word of row j>>         48160000
   logical pointer col = q+5;  <<points to first word of column j>>     48165000
   logical mask = q+6;  <<column bit for column j>>                     48170000
                                                                        48175000
   <<* * * allocate dl buffers * * *>>                                  48180000
                                                                        48185000
   tos := splnrt;  <<nr. entries>>                                      48190000
   if = then return;  <<no entries?>>                                   48195000
   makeroomindl(n&lsl(4));                                              48200000
   if < then quit(3);  <<no room?>>                                     48205000
                                                                        48210000
   <<* * * initialize local variables * * *>>                           48215000
                                                                        48220000
   tos := (s0-1)&lsl(4);                                                48225000
   tos := @dlavail;                                                     48230000
   assemble(ddup,add);                                                  48235000
   tos := @m+range&lsr(8);                                              48240000
   tos := 1&csr(n);                                                     48245000
                                                                        48250000
   <<* * * fill matrix from reference table * * *>>                     48255000
                                                                        48260000
   tos := n;                                                            48265000
   tos := @m+range;                                                     48270000
   do begin                                                             48275000
      getreftabentry(s1-1);                                             48280000
      move ps0 := slrrefedsegs,(16);                                    48285000
      tos := tos-16;                                                    48290000
      s1 := s1-1                                                        48295000
      end until =;                                                      48300000
                                                                        48305000
   <<* * * take transitive closure of matrix * * *>>                    48310000
                                                                        48315000
   do begin  <<process a column>>                                       48320000
      xreg := range;                                                    48325000
      do begin                                                          48330000
         tos := col(xreg) land mask;                                    48335000
         del;                                                           48340000
         if <> then  <<or row j with row i?>>                           48345000
            begin                                                       48350000
            tos := xreg;  <<save x register>>                           48355000
            tos := @m(xreg);                                            48360000
            xreg := 15;                                                 48365000
            do begin                                                    48370000
               lps0(xreg) := lps0(xreg) lor mj(xreg);                   48375000
               xreg := xreg-1                                           48380000
               end until <;                                             48385000
            del;                                                        48390000
            xreg := tos  <<restore x register>>                         48395000
            end;                                                        48400000
         xreg := xreg-16                                                48405000
         end until <;                                                   48410000
      @mj := @mj-16;  <<next row>>                                      48415000
      mask := mask&csl(1);  <<next column bit>>                         48420000
      if mask then @col := @col-1  <<next word column>>                 48425000
      end until @col < @m;                                              48430000
                                                                        48435000
   <<* * * empty matrix into reference table * * *>>                    48440000
                                                                        48445000
   tos := n;                                                            48450000
   tos := @m+range;                                                     48455000
   do begin                                                             48460000
      getreftabentry(s1-1);                                             48465000
      move slrrefedsegs := ps0,(16);                                    48470000
      rtmodified := true;  <<set modified flag>>                        48475000
      tos := tos-16;                                                    48480000
      s1 := s1-1                                                        48485000
      end until =                                                       48490000
   end;                                                                 48495000
$page "SL FILE MAINTENANCE PROCEDURE - RETURNSLPMAPSPACE"               48500000
$control segment = seg30                                                48505000
procedure returnslpmapspace;                                   <<04102>>48510000
                                                               <<04102>>48515000
<< this procedure returns the pmap spaces when     >>          <<04102>>48520000
<< purgesl segment,segname entered.                >>          <<04102>>48525000
                                                               <<04102>>48530000
begin                                                          <<04102>>48535000
                                                                        48540000
integer nrrecs;                                                <<04782>>48545000
                                                               <<04782>>48550000
countpmapspace(nrrecs);                                        <<04782>>48555000
if nrrecs <> 0 then                                            <<04782>>48560000
   begin                                                       <<04782>>48565000
      returnslspace(slrpmaprec,nrrecs);                        <<04782>>48570000
      slrpmaprec:=0;                                           <<04782>>48575000
   end;                                                        <<04782>>48580000
end;                                                           <<04102>>48585000
$page "SL FILE MAINTENNANCE PROCEDURE - RETURNSLSISPACE"                48590000
$control segment = seg30                                                48595000
procedure returnslsispace;                                     <<04525>>48600000
                                                                        48605000
<< this procedure returns the si space when  >>                         48610000
<< purgesl segment,segname entered.          >>                         48615000
                                                                        48620000
begin                                                                   48625000
integer nrrecs;                                                <<04782>>48630000
                                                               <<04782>>48635000
   countsispace(nrrecs);                                       <<04782>>48640000
   if nrrecs <> 0 then                                         <<04782>>48645000
      begin                                                    <<04782>>48650000
         returnslspace(slrsirec,nrrecs);                       <<04782>>48655000
         slrsirec := 0;                                        <<04782>>48660000
         slrsilen := 0;                                        <<06537>>48665000
      end;                                                     <<04782>>48670000
   end;                                                                 48675000
$page "SL FILE MAINTENANCE PROCEDURE - REMOVESL"                        48680000
$ control segment = seg30                                               48685000
procedure removesl;                                                     48690000
   <<removes the specified entry point(s) from the directory and,       48695000
     if necessary, removes the segment from the sl file>>               48700000
   begin                                                                48705000
   define exitproc = assemble(exit 0)#;                                 48710000
   integer segnr;                                                       48715000
   byte array segname (0:15);                                           48720000
   integer splfnumsave;                                        <<04782>>48725000
                                                                        48730000
   subroutine validdelete;                                              48735000
      <<checks to see if the specified file is a real sl file and if    48740000
        the segment is currently loaded>>                               48745000
      begin                                                             48750000
      if realsl then  <<real sl file?>>                                 48755000
         begin                                                          48760000
         getprivmode;  <<get into priv. mode>>                          48765000
         if loadedslseg(slkey,segnr) then  <<segment loaded?>>          48770000
            begin                                                       48775000
            error(110);                                                 48780000
            exitproc                                                    48785000
            end;                                                        48790000
         getusermode  <<return to user mode>>                           48795000
         end                                                            48800000
      end;                                                              48805000
                                                                        48810000
   if class = entryclass then  <<single entry point>>                   48815000
      begin                                                             48820000
      if not searchspl(name) then                                       48825000
         begin                                                          48830000
         l1: error(93);                                                 48835000
         return                                                         48840000
         end;                                                           48845000
      segnr _ slsegnr;  <<save seg. nr.>>                               48850000
      validdelete;  <<segment loaded?>>                                 48855000
      deletelibentry;  <<delete entry point>>                           48860000
      getreftabentry(segnr);                                            48865000
      rtmodified _ true;  <<set modified flag>>                         48870000
      tos _ slrnrentpts-1;  <<dec. nr. entry points>>                   48875000
      if = then go deleteseg;  <<last entry point?>>                    48880000
      slrnrentpts _ tos;                                                48885000
      segsmodified _ true;  <<set modified segment flag>>               48890000
      setbit(modifiedsegs,segnr)  <<set segment bit>>                   48895000
      end                                                               48900000
   else  <<entire segment>>                                             48905000
      begin                                                             48910000
      tos _ @segname; bps0 _ " ";                                       48915000
      assemble(dup,incb); move * _ *,(15);                              48920000
      move segname _ bname(1),(integer(bname));                         48925000
      segnr _ searchsegname(segname);                                   48930000
      if segnr = -1 then go l1;                                         48935000
      if ldseg then <<currently loaded segment>>               <<00.eb>>48940000
      << request from syspass program, freeze sys seg,>>       <<00.eb>>48945000
      << then delete it in sl>>                                <<00.eb>>48950000
      begin                                                    <<00.eb>>48955000
         getprivmode;                                          <<00.eb>>48960000
         tos := physicalcst(0,segnr);                          <<06093>>48965000
         if <> then quit(101);                                 <<00.eb>>48970000
         lockseg(*,0,absolute(cpcb)-absolute(pcbb));           <<00.eb>>48975000
         if < then                                             <<00.eb>>48980000
         begin                                                 <<00.eb>>48985000
            error(114); <<unable'to freeze segment>>           <<00.eb>>48990000
            getusermode;                                       <<00.eb>>48995000
            return;                                            <<00.eb>>49000000
         end;                                                  <<00.eb>>49005000
         getusermode;                                          <<00.eb>>49010000
      end                                                      <<00.eb>>49015000
      else validdelete; <<segment loaded?>>                    <<00.eb>>49020000
      deleteseg:                                                        49025000
      segsdeleted _ true;  <<set deleted segment flag>>                 49030000
      setbit(deletedsegs,segnr);  <<set segment bit>>                   49035000
      splfnumsave := osplfnum;                                 <<04782>>49040000
      osplfnum := splfnum;                                     <<04782>>49045000
      returnslpmapspace;                                       <<04102>>49050000
      returnslsispace;                                                  49055000
      osplfnum := splfnumsave;                                 <<04782>>49060000
      splns _ splns-1  <<dec. nr. segments>>                            49065000
      end;                                                              49070000
   slrec0mod _ true  <<set modified flag>>                              49075000
   end;                                                                 49080000
$page "SL FILE MAINTAINENCE PROCEDURES - LOADSLSTT"            <<00207>>49085000
$ control segment = seg30                                               49090000
procedure loadslstt;                                                    49095000
   <<loads the stt, stt map array and external list for the segment     49100000
     defined by the current reference table entry>>                     49105000
   begin                                                                49110000
   slsttnw := (slrnr-rtp.(2:7))&lsl(7)+p256;  <<nr. words stt, etc.>>   49115000
   slsttrecd := slrsa+rtp.(2:7)-2;  <<rec. nr. stt, etc.>>              49120000
   makeroomindl(slsttnw);                                               49125000
   if < then quit(3);  <<no room?>>                                     49130000
   freadmr'(splfnum,dlavail,slsttnw,slsttrecd);                         49135000
   @sttp := rtp.(9:7)+255+@dlavail;  <<pl entry>>                       49140000
   slsttmodified := false;  <<clear modified flag>>                     49145000
   @slsttmap := (@sttp+1)&lsl(1);  <<stt map>>                          49150000
   @slxp := @sttp+129;  <<first external entry>>                        49155000
   slxnw := 0  <<phoney nr. words>>                                     49160000
   end;                                                                 49165000
$page "SL FILE MAINTAINENCE PROCEDURES - STORESLSTT"           <<00207>>49170000
procedure storeslstt;                                                   49175000
   <<stores the stt, stt map array and external list for the segment    49180000
     defined by the current reference table entry>>                     49185000
   begin                                                                49190000
   if slsttmodified then  <<stt, etc. modified?>>                       49195000
      fwritemr'(splfnum,dlavail,slsttnw,slsttrecd)                      49200000
   end;                                                                 49205000
$page "SL FILE MAINTAINENCE PROCEDURES - GETNEXTSLEXTN"        <<00207>>49210000
$ control segment = seg30                                               49215000
logical procedure getnextslextn;                                        49220000
   <<gets the next external entry and sets the external entry           49225000
     parameters.  returns the value false when the external list has    49230000
     been exhausted, otherwise returns the value true>>                 49235000
   begin                                                                49240000
   integer result = getnextslextn;                                      49245000
   @slxp := @slxp+slxnw;  <<next entry>>                                49250000
   slxnc := slxp.(4:4);  <<nr. char's in name>>                         49255000
   if <> then  <<not end of list?>>                                     49260000
      begin                                                             49265000
      @slxp1 := @slxp+slxp.(4:3)+1;  <<secondary entry pointer>>        49270000
      slxnw := @slxp1-@slxp+1+parmlen(slxparms);  <<nr. words>>         49275000
      result := result+1  <<set result to true>>                        49280000
      end                                                               49285000
   end;                                                                 49290000
$page "SL FILE MAINTAINENCE PROCEDURES - GETREFTABENTRY"       <<00207>>49295000
$ control segment = seg30                                               49300000
procedure getreftabentry (entrynr);                                     49305000
   <<sets the reference table entry pointer (rtp) to the specified      49310000
     reference table entry.  if a new record has to be read into        49315000
     the buffer, the reference table modified flag is checked to        49320000
     see if the old record needs to be preserved>>                      49325000
   value entrynr;                                                       49330000
   integer entrynr;                                                     49335000
   begin                                                                49340000
   tos := entrynr; tos := 4;                                            49345000
   assemble(div,stbx);                                                  49350000
   @rtp := (tos&lsl(5))+@rtbuf;  <<init. entry pointer>>                49355000
   tos := splrec1(xreg);  <<rec. nr.>>                                  49360000
   if s0 <> rtrecd then  <<different record?>>                          49365000
      begin                                                             49370000
      cleanuprtbuf;  <<save modified buffer>>                           49375000
      if s0 < feof(splfnum) then freaddir'(splfnum,rtbuf,s0);           49380000
      rtrecd := tos  <<save rec. nr.>>                                  49385000
      end                                                               49390000
   end;                                                                 49395000
$page "SL FILE MAINTAINENCE PROCEDURES - CLEANUPRTBUF"         <<00207>>49400000
$ control segment = seg30                                               49405000
procedure cleanuprtbuf;                                                 49410000
   <<checks the reference table modified flag and if it is set,         49415000
     writes the reference table record containing the modified          49420000
     entry>>                                                            49425000
   begin                                                                49430000
   if rtmodified then  <<record modified?>>                             49435000
      begin                                                             49440000
      fwritedir'(splfnum,rtbuf,rtrecd);                                 49445000
      rtmodified _ false  <<clear modified flag>>                       49450000
      end                                                               49455000
   end;                                                                 49460000
$page "SL FILE MAINTAINENCE PROCEDURES - SLCLEAN"              <<00465>>49465000
$control segment=seg30                                         <<04782>>49470000
procedure slclean(factor);                                     <<04782>>49475000
   value factor; double factor;                                <<04782>>49480000
                                                               <<04782>>49485000
   comment: this procedure, with factor=0, implements the      <<04782>>49490000
            cleansl command.  factor=0 implies that the new    <<04782>>49495000
            sl filesize equals the old sl filesize (though eof <<04782>>49500000
            may be less).  if factor>0, then the new filesize  <<04782>>49505000
            is factor % greater than old eof.  this feature is <<04782>>49510000
            used by copysl.  slclean expects to find the new sl<<04782>>49515000
            file name in bfname1.  it returns cce if cleaning  <<04782>>49520000
            was successful, ccl otherwise;                     <<04782>>49525000
                                                               <<04782>>49530000
begin                                                          <<04782>>49535000
   equate                                                      <<04782>>49540000
      tempbufsize = 2048,                                      <<04782>>49545000
      nrtempsects = tempbufsize/128,                           <<04782>>49550000
      slclndlbufs1 = tempbufsize+256;                          <<04782>>49555000
   define                                                      <<04782>>49560000
      ospllid = osplrec0 #,      <<id code>>                   <<04782>>49565000
      osplfl = osplrec0(1) #,    <<file length>>               <<04782>>49570000
      osplel = osplrec0(2) #,    <<extent length>>             <<04782>>49575000
      osplns = osplrec0(4) #,    <<# of segments>>             <<04782>>49580000
      osplfrtl = osplrec0(7) #,  <<free ref. entry #>>         <<04782>>49585000
      osplnrt = osplrec0(9) #,   <<# ref table entries>>       <<04782>>49590000
      oslns = osplrec0(11) #;    <<# of sections>>             <<04782>>49595000
                                                               <<04782>>49600000
   integer pointer                                             <<04782>>49605000
      osplrec0,                                                <<04782>>49610000
      osplrec1,                                                <<04782>>49615000
      tempbuf;                                                 <<04782>>49620000
   integer                                                     <<04782>>49625000
      orecd,                                                   <<04782>>49630000
      ortrecd := 0,                                            <<04782>>49635000
      prev,                                                    <<04782>>49640000
      nslrsa,                                                  <<04782>>49645000
      nslsisa,                                                 <<04782>>49650000
      nslpmapsa,                                               <<04782>>49655000
      length,                                                  <<04782>>49660000
      fromrec,                                                 <<04782>>49665000
      torec,                                                   <<04782>>49670000
      i;                                                       <<04782>>49675000
   logical                                                     <<04782>>49680000
      replaceoldsl := false,                                   <<04782>>49685000
      switched'sl := false,                                    <<04782>>49690000
      xfer,                                                    <<04782>>49695000
      nwtocopy;                                                <<04782>>49700000
   byte array oldslname(0:31);                                 <<04782>>49705000
                                                               <<04782>>49710000
                                                               <<04782>>49715000
   subroutine cantclose(fn);                                   <<04782>>49720000
      value fn; integer fn;                                    <<04782>>49725000
      begin                                                    <<04782>>49730000
      fcheck( fn, i);                                          <<04782>>49735000
      errorn( 10, double(i));                                  <<04782>>49740000
      end;                                                     <<04782>>49745000
                                                               <<04782>>49750000
subroutine transferrecs;                                       <<04782>>49755000
                                                               <<04782>>49760000
<< this subroutine transfers "NWTOCOPY" words from record >>   <<04782>>49765000
<< "FROMREC" in old sl file to record "TOREC" in new sl   >>   <<04782>>49770000
<< file.                                                  >>   <<04782>>49775000
                                                               <<04782>>49780000
begin                                                          <<04782>>49785000
   while nwtocopy > 0 do                                       <<04782>>49790000
      begin                                                    <<04782>>49795000
         xfer := if nwtocopy > tempbufsize then tempbufsize    <<04782>>49800000
                                           else nwtocopy;      <<04782>>49805000
         freadmr'(osplfnum,tempbuf,xfer,fromrec);              <<04782>>49810000
         fwritemr'(splfnum,tempbuf,xfer,torec);                <<04782>>49815000
         fromrec:=fromrec+nrtempsects;                         <<04782>>49820000
         torec:=torec+nrtempsects;                             <<04782>>49825000
         nwtocopy:=nwtocopy-xfer;                              <<04782>>49830000
      end;                                                     <<04782>>49835000
end;                                                           <<04782>>49840000
                                                               <<04782>>49845000
subroutine copysiinfo;                                         <<04782>>49850000
                                                               <<04782>>49855000
begin                                                          <<04782>>49860000
   countsispace(length);                                       <<04782>>49865000
   if length <> 0 then                                         <<04782>>49870000
      begin                                                    <<04782>>49875000
         tos:=findslspace(length);                             <<04782>>49880000
         if <> then go noroom;                                 <<04782>>49885000
         nslsisa := tos;                                       <<04782>>49890000
         nwtocopy := length&lsl(7);                            <<04782>>49895000
         fromrec:=slrsirec;                                    <<04782>>49900000
         torec:=nslsisa;                                       <<04782>>49905000
         transferrecs;                                         <<04782>>49910000
         slrsirec:=nslsisa;                                    <<04782>>49915000
      end;                                                     <<04782>>49920000
end;                                                           <<04782>>49925000
                                                               <<04782>>49930000
subroutine copypmapinfo;                                       <<04782>>49935000
                                                               <<04782>>49940000
begin                                                          <<04782>>49945000
   countpmapspace(length);                                     <<04782>>49950000
   if length <> 0 then                                         <<04782>>49955000
      begin                                                    <<04782>>49960000
         tos:=findslspace(length);                             <<04782>>49965000
         if <> then go noroom;                                 <<04782>>49970000
         nslpmapsa := tos;                                     <<04782>>49975000
         nwtocopy := length&lsl(7);                            <<04782>>49980000
         fromrec:=slrpmaprec;                                  <<04782>>49985000
         torec:=nslpmapsa;                                     <<04782>>49990000
         transferrecs;                                         <<04782>>49995000
         slrpmaprec:=nslpmapsa;                                <<04782>>50000000
      end;                                                     <<04782>>50005000
end;                                                           <<04782>>50010000
                                                               <<04782>>50015000
   if splfnum=0 then                                           <<04782>>50020000
      begin                                                    <<04782>>50025000
      error(16);                                               <<04782>>50030000
      go nfg;                                                  <<04782>>50035000
      end;                                                     <<04782>>50040000
   fixupsl(false);                                             <<04782>>50045000
   fgetinfo(splfnum,oldslname,,,,,,,,,,,,,,,nrextents);        <<04782>>50050000
   if <> then go nfg;                                          <<04782>>50055000
                                                               <<04782>>50060000
   << * * * allocate storage * * * >>                          <<04782>>50065000
                                                               <<04782>>50070000
   makeroomindl( slclndlbufs1);                                <<04782>>50075000
   if < then go nfg;                                           <<04782>>50080000
   @tempbuf := @dlarea1-tempbufsize;                           <<04782>>50085000
   @osplrec1 := @tempbuf-128;                                  <<04782>>50090000
   @osplrec0 := @osplrec1-128;                                 <<04782>>50095000
   move osplrec0 := splrec0,(256); <<save old recs 0,1>>       <<04782>>50100000
                                                               <<04782>>50105000
   << * * * open new sl file * * * >>                          <<04782>>50110000
                                                               <<04782>>50115000
   if bfname1 = " " then                                       <<04782>>50120000
      begin                                                    <<04782>>50125000
      move bfname1 := oldslname,(32);                          <<04782>>50130000
      replaceoldsl := true;                                    <<04782>>50135000
      end                                                      <<04782>>50140000
   else                                                        <<04782>>50145000
      begin                                                    <<04782>>50150000
      oldfile( bfname1, 202);                                  <<04782>>50155000
      if < then go nfg;                                        <<04782>>50160000
      end;                                                     <<04782>>50165000
   filesize := osplfl;                                         <<04782>>50170000
   if factor <> 0d then                                        <<04782>>50175000
      begin                                                    <<04782>>50180000
      filesize := integer(delta(double(osplfl-sltotalfreespace),        50185000
           factor));                                           <<04782>>50190000
      if filesize < osplfl then nrextents := filesize/osplel;  <<04782>>50195000
      if nrextents <= 0 then nrextents := 1;                   <<04782>>50200000
      end;                                                     <<04782>>50205000
   <<from this point it will be neccessary to reopen >>        <<04782>>50210000
   <<old sl file on error                            >>        <<04782>>50215000
   switched'sl := true;                                        <<04782>>50220000
   osplfnum := splfnum;                                        <<04782>>50225000
   splfnum := 0;                                               <<04782>>50230000
   opensl(true);                                               <<04782>>50235000
   if splfnum = 0 then go openfail;                            <<04782>>50240000
                                                               <<04782>>50245000
   << * * * allocate space for reference table entries * * * >><<04782>>50250000
                                                               <<04782>>50255000
   splnrt := osplnrt;                                          <<04782>>50260000
   i := -1;                                                    <<04782>>50265000
   tos := (osplnrt+3)&lsr(2);                                  <<04782>>50270000
   while <> do                                                 <<04782>>50275000
      begin                                                    <<04782>>50280000
      tos := findslspace(1);                                   <<04782>>50285000
      if < then go noroom;                                     <<04782>>50290000
      splrec1(i:=i+1) := tos;                                  <<04782>>50295000
      tos:=tos-1;                                              <<04782>>50300000
      end;                                                     <<04782>>50305000
   del;                                                        <<04782>>50310000
                                                               <<04782>>50315000
   << * * * copy directory * * * >>                            <<04782>>50320000
                                                               <<04782>>50325000
   for *i := splfhi until 127 do                               <<04782>>50330000
      begin                                                    <<04782>>50335000
      if osplrec0(i) <> 0 then                                 <<04782>>50340000
         begin                                                 <<04782>>50345000
         orecd := osplrec0(xreg);                              <<04782>>50350000
         tos := findslspace(1);                                <<04782>>50355000
         if <> then go noroom;                                 <<04782>>50360000
         splrec0(xreg) := prev := tos;                         <<04782>>50365000
l1:                                                            <<04782>>50370000
         freaddir'( osplfnum, spldir, orecd);                  <<04782>>50375000
         if spldir <> 0 then                                   <<04782>>50380000
            begin                                              <<04782>>50385000
            orecd := spldir;                                   <<04782>>50390000
            spldir := findslspace(1);                          <<04782>>50395000
            if <> then go noroom;                              <<04782>>50400000
            fwritedir'( splfnum, spldir, prev);                <<04782>>50405000
            prev := spldir;                                    <<04782>>50410000
            go l1;                                             <<04782>>50415000
            end;                                               <<04782>>50420000
         fwritedir'( splfnum, spldir, prev);                   <<04782>>50425000
         end;                                                  <<04782>>50430000
      end;                                                     <<04782>>50435000
                                                               <<04782>>50440000
   << * * * copy segments and reference table * * * >>         <<04782>>50445000
                                                               <<04782>>50450000
   splfrtl := -1;                                              <<04782>>50455000
   for i := 0 until osplnrt-1 do                               <<04782>>50460000
      begin                                                    <<04782>>50465000
      tos := i; tos := 4;                                      <<04782>>50470000
      assemble( div, stbx);                                    <<04782>>50475000
      @rtp := (tos&lsl(5))+@rtbuf;                             <<04782>>50480000
      tos := osplrec1(xreg);                                   <<04782>>50485000
      if s0 <> ortrecd then                                    <<04782>>50490000
         begin                                                 <<04782>>50495000
         cleanuprtbuf;                                         <<04782>>50500000
         rtrecd := splrec1(xreg);                              <<04782>>50505000
         freaddir'( osplfnum, rtbuf, s0);                      <<04782>>50510000
         ortrecd := s0;                                        <<04782>>50515000
         rtmodified := true;                                   <<04782>>50520000
         end;                                                  <<04782>>50525000
      ddel;                                                    <<04782>>50530000
      if not deletedseg then                                   <<04782>>50535000
         begin                                                 <<04782>>50540000
         splns := splns+1;                                     <<04782>>50545000
         tos := findslspace(slrnr);                            <<04782>>50550000
         if <> then go noroom;                                 <<04782>>50555000
         nslrsa := tos;                                        <<04782>>50560000
         nwtocopy := slrnr&lsl(7);                             <<04782>>50565000
         fromrec := slrsa;                                     <<04782>>50570000
         torec := nslrsa;                                      <<04782>>50575000
         transferrecs;                                         <<04782>>50580000
         slrsa := nslrsa;                                      <<04782>>50585000
         copysiinfo;                                           <<04782>>50590000
         copypmapinfo;                                         <<04782>>50595000
         end                                                   <<04782>>50600000
      else                                                     <<04782>>50605000
         begin                                                 <<04782>>50610000
         rtp := splfrtl;                                       <<04782>>50615000
         splfrtl := i;                                         <<04782>>50620000
         end;                                                  <<04782>>50625000
      end;                                                     <<04782>>50630000
                                                               <<04782>>50635000
   if replaceoldsl then                                        <<04782>>50640000
      begin                                                    <<04782>>50645000
      fclose( osplfnum, 4, 0);                                 <<04782>>50650000
      if <> then                                               <<04782>>50655000
         begin                                                 <<04782>>50660000
         cantclose(osplfnum);                                  <<04782>>50665000
         go nfg;                                               <<04782>>50670000
         end;                                                  <<04782>>50675000
      opensl( false); <<save present sl file>>                 <<04782>>50680000
      end                                                      <<04782>>50685000
   else                                                        <<04782>>50690000
      fclose( osplfnum, 1, 0);                                 <<04782>>50695000
   condcode := cce;                                            <<04782>>50700000
   return;                                                     <<04782>>50705000
                                                               <<04782>>50710000
noroom:                                                        <<04782>>50715000
nfg:                                                           <<04782>>50720000
   condcode := ccl;                                            <<04782>>50725000
   if not switched'sl then return;                             <<04782>>50730000
   fclose( splfnum, 4, 0);                                     <<04782>>50735000
   if <> then cantclose(splfnum);                              <<04782>>50740000
   fclose( osplfnum, 1, 0);                                    <<04782>>50745000
   if <> then cantclose(osplfnum);                             <<04782>>50750000
openfail:                                                      <<04782>>50755000
   splfnum := 0;                                               <<04782>>50760000
   move bfname1 := oldslname,(32);                             <<04782>>50765000
   opensl(false);                                              <<04782>>50770000
end;                                                           <<04782>>50775000
$page "SL FILE MAINTAINENCE PROCEDURES - LISTSL'"              <<00465>>50780000
$ control segment = seg30                                               50785000
procedure listsl';                                                      50790000
   <<lists the contents of the current spl file>>                       50795000
   begin                                                                50800000
   byte array b0(0:10)=pb _ "PRIVILEGED ";                              50805000
   byte array b1(0:9)=pb _ "ALLOCATED ";                                50810000
   byte array b2(0:8)=pb _ "RESIDENT ";                                 50815000
   byte array b3(0:7)=pb _ "SL FILE ";                                  50820000
   byte array b4(0:6)=pb _ "SEGMENT";                                   50825000
   byte array b5(0:5)=pb _ "LENGTH";                                    50830000
   byte array b6 (0:33)=pb := "ENTRY POINTS    CHECK CAL STT  ADR";     50835000
   byte array b7 (0:28)=pb := "EXTERNALS       CHECK STT SEG";          50840000
   byte array b8(0:6)=pb _ "SYSTEM ";                                   50845000
   byte array b9 (0:3)=pb _ "USED";                                     50850000
   byte array b10 (0:8)=pb _ "AVAILABLE";                               50855000
   integer i;  <<segment nr.>>                                          50860000
   double wordused;                                            <<00207>>50865000
   integer wordused2=wordused+1;                               <<00207>>50870000
   double wordfree;                                            <<00207>>50875000
   integer wordfree2=wordfree+1;                               <<00207>>50880000
                                                                        50885000
   <<* * * complete segment binding * * *>>                             50890000
                                                                        50895000
   fixupsl(false);                                                      50900000
                                                                        50905000
   <<* * * print file name * * *>>                                      50910000
                                                                        50915000
   fcontrol(infnum,enable'ctly,i);                             <<00.dm>>50920000
   ctly := false;                                              <<00.dm>>50925000
   blankline;                                                           50930000
   tos _ splfnum;                                                       50935000
   move bline _ b3,(8),2;  <<"SL FILE">>                                50940000
   fgetinfo(*,*);  <<insert sl file name>>                              50945000
   printline;                                                           50950000
   for i _ 0 until splnrt-1 do                                          50955000
      begin                                                             50960000
      getreftabentry(i);  <<load ref. tab. entry>>                      50965000
      move line:=slrsegname,(8);                               <<00207>>50970000
      if not deletedseg and((bfname1=" ") or                   <<00207>>50975000
         (bfname1=bline,(16)) )  then                          <<00207>>50980000
         begin                                                          50985000
         loadslstt;  <<load stt, etc.>>                                 50990000
                                                                        50995000
         <<* * * print segment name * * *>>                             51000000
                                                                        51005000
         blankline;                                                     51010000
         move bline _ b4,(7); ntoa(i,8,bline(10));  <<seg. nr.>>        51015000
         move line(6) := slrsegname,(8);  <<seg. name>>                 51020000
         move bline(28) := b5,(6);                                      51025000
         ntoa(slrsl,8,bline(39));  <<seg. length>>                      51030000
         printline;                                                     51035000
         tos _ @bline;                                                  51040000
         if slprivileged then move * _ b0,(11),2;                       51045000
         if slallocated then move * _ b1,(10),2;                        51050000
         if slresident then move * _ b2,(9),2;                          51055000
         if slsystem then move * _ b8,(7),2;                            51060000
         if tos <> @bline then printline;                               51065000
                                                                        51070000
         <<* * * print entry point names * * *>>                        51075000
                                                                        51080000
         blankline;                                                     51085000
         move bline(3) := b6,(34);                                      51090000
         printline;                                                     51095000
         setuplibbuf;                                                   51100000
         while getnextlibentry do  <<step thru directory>>              51105000
            if slsegnr = i then                                         51110000
               begin                                                    51115000
               if ctly then return;    <<check for control y>> <<00.dm>>51120000
               tos _ @bline(3); tos _ @slname&lsl(1)+1;                 51125000
               move * _ *,(splnc);                                      51130000
               ntoa(slpcheck,8,bline(21));  <<parm. check level>>       51135000
               bline(26) := if sluncallable then "U" else "C";          51140000
               ntoa(slsttnr,8,bline(31));  <<stt nr.>>                  51145000
               ntoa(sttp(-slsttnr).(2:14),8,bline(37));  <<pb adr.>>    51150000
               printline                                                51155000
               end;                                                     51160000
                                                                        51165000
         <<* * * print external names * * *>>                           51170000
                                                                        51175000
         blankline;                                                     51180000
         move bline(3) := b7,(29);                                      51185000
         printline;                                                     51190000
         while getnextslextn do                                         51195000
            begin                                                       51200000
            if ctly then return;       <<check for control y>> <<00.dm>>51205000
            tos _ @bline(3); tos _ @slxname&lsl(1)+1;                   51210000
            move * := *,(slxnc);                                        51215000
            ntoa(slxpcheck,8,bline(21));  <<parm. check level>>         51220000
            ntoa(slxsttnr,8,bline(27));  <<stt nr.>>                    51225000
            if slsatisextn  <<satisfied?>>                              51230000
               then ntoa(slxsegnr,8,bline(31))  <<seg. nr.>>            51235000
               else bline(31) := "?";                                   51240000
            printline                                                   51245000
            end;                                                        51250000
                                                                        51255000
         <<* * * print referenced segment list * * *>>                  51260000
                                                                        51265000
         blankline;                                                     51270000
         tos _ @bline;  <<column pointer>>                              51275000
         tos _ @slrrefedsegs;  <<segment bit map>>                      51280000
         tos _ 0;  <<segment nr.>>                                      51285000
         xreg _ splnrt;  <<loop counter>>                               51290000
         do begin                                                       51295000
            assemble(ddup,zero; cab,cab);                               51300000
            bps5 := integer(testbit(*,*).(15:1))+%60;                   51305000
            @bps2 _ @bps2+1;  <<next column>>                           51310000
            if s0.(13:3) = %7 then @bps2 _ @bps2+1;  <<space pointer>>  51315000
            if s0.(10:6) = %77 then  <<line full?>>                     51320000
               begin                                                    51325000
               printline;                                               51330000
               @bps2 _ @bline  <<re-set column pointer>>                51335000
               end;                                                     51340000
            assemble(inca,decx)                                         51345000
            end until =;                                                51350000
         ddel;                                                          51355000
         if tos <> @bline then printline; <<print last line?>> <<00207>>51360000
         if bfname1 <> " " then go getout;                     <<04122>>51365000
         end                                                            51370000
      end;                                                              51375000
   if bfname1 <> " " then begin error(93); go getout; end;     <<04122>>51380000
                                                                        51385000
   <<* * * print file parameters * * *>>                                51390000
                                                                        51395000
   blankline;                                                           51400000
   wordfree := double(sltotalfreespace)&dlsl(7);               <<00465>>51405000
   move bline _ b9,(4);                                        <<00207>>51410000
   wordused:=double(logical(splfl))&dlsl(7)-wordfree;          <<00465>>51415000
   dntoa(wordused,8,bline(19));                                <<00207>>51420000
   bline(20):="(";                                             <<00207>>51425000
   dntoa((wordused&dasr(7)),8,bline(25));                      <<00207>>51430000
   bline(26):=".";                                             <<00207>>51435000
   ntoa(wordused2.(9:7),8,bline(29));                          <<00207>>51440000
   bline(30):=")";                                             <<00207>>51445000
   move bline(35) _ b10,(9);                                   <<00207>>51450000
   dntoa(wordfree,8,bline(54));                                <<00207>>51455000
   bline(55):="(";                                             <<00207>>51460000
   dntoa((wordfree&dasr(7)),8,bline(60));                      <<00207>>51465000
   bline(61):=".";                                             <<00207>>51470000
   ntoa(wordfree2.(9:7),8,bline(64));                          <<00207>>51475000
   bline(65):=")";                                             <<00207>>51480000
   printline;                                                           51485000
   ejectpage;                                                  <<00.dm>>51490000
getout: fcontrol(infnum, disable'ctly,i);                      <<04122>>51495000
   end;                                                                 51500000
$page "RL FILE MAINTAINENCE PROCEDURES - OPENRL"               <<00207>>51505000
<<----------------------------------------------------------------------51510000
*                                                                      *51515000
*  rl file maintainence procedures                                     *51520000
*                                                                      *51525000
---------------------------------------------------------------------->>51530000
                                                                        51535000
$ control segment = seg40                                               51540000
procedure openrl (newfile);                                             51545000
  <<preserves any information in core that may be destroyed by          51550000
     loading the rl, then loads the rl and initializes the necessary    51555000
     global parameters.  if newfile is set, record 0 is initialized     51560000
     according to the parameters in the command buffer; otherwise       51565000
     record 0 is loaded>>                                               51570000
   value newfile; logical newfile;                                      51575000
   begin                                                                51580000
   integer savedlarea1;                                        <<00563>>51585000
   integer flag := 0;   <<dl buffers just allocated?>>         <<00563>>51590000
   integer aoptions := 0;                                      <<00563>>51595000
                                                                        51600000
   <<* * * initialize local variables * * *>>                           51605000
                                                                        51610000
   savedlarea1 := @dlarea1;                                    <<00563>>51615000
                                                                        51620000
   <<* * * allocate dl buffers * * *>>                                  51625000
                                                                        51630000
   if not rlbufalloc then  <<allocate buffers?>>                        51635000
      begin                                                             51640000
      makeroomindl(rldlbufs1);                                          51645000
      if < then go nfg;  <<no room?>>                                   51650000
      @rlmap _ @dlarea1-128;                                            51655000
      @rlrec0 _ @rlmap-128;                                             51660000
      @rldir _ @rlrec0-128;                                             51665000
      @rlproctab := @rldir-rlproctablen;                                51670000
      @dlarea1 := @rlproctab;  <<new dl area 1 limit>>                  51675000
      rlbufalloc := true;  <<set flag>>                                 51680000
      flag := flag+1  <<set flag>>                                      51685000
      end;                                                              51690000
                                                                        51695000
   <<* * * preserve overlayable information * * *>>                     51700000
                                                                        51705000
   closerl;                                                             51710000
   if < then go nfg;  <<error?>>                                        51715000
                                                                        51720000
   <<* * * load new rl file information * * *>>                         51725000
                                                                        51730000
   if newfile then  <<init. record 0?>>                                 51735000
      begin                                                             51740000
      if not (minrl <= filesize <= maxrl) then                          51745000
         begin                                                          51750000
         error(20);                                                     51755000
         go nfg                                                         51760000
         end;                                                           51765000
      rlfnum _ fopen(bfilename,%(2)10000000000,%(2)111010100,,,,,,,     51770000
         double(logical(filesize)),nrextents,,rlfilecode);              51775000
      if < then  <<error?>>                                             51780000
         begin                                                          51785000
         fopenerror:                                                    51790000
         tos _ 30;                                                      51795000
         tos _ 0d; fcheck(0,s0);  <<file sys. error nr.>>               51800000
         errorn(*,*);                                                   51805000
         go nfg                                                         51810000
         end;                                                           51815000
                                                                        51820000
      <<* * * initialize record 0 * * *>>                               51825000
                                                                        51830000
      tos _ @rlrec0; ps0 _ 0;                                           51835000
      assemble(dup,incb); tos _ 127; assemble(move 3);                  51840000
      rllid := rlfileid;  <<version nr.>>                               51845000
      rlfl _ filesize;  <<file length (in records)>>                    51850000
      rlns _ (logical(filesize)+511)&lsr(9);  <<nr. sections>>          51855000
      rlsaxl _ bigd;  <<s.a. of external lists>>                        51860000
                                                                        51865000
      <<* * * initialize free storage maps * * *>>                      51870000
                                                                        51875000
      tos _ rlns;  <<section counter>>                                  51880000
      do begin                                                          51885000
         tos _ @rlmap; ps0 _ -1;                                        51890000
         assemble(dup,incb); tos _ 127; assemble(move 3);               51895000
         if s0 = 1 then  <<first section?>>                             51900000
            begin                                                       51905000
            xreg _ (rlns+1)&lsl(2);                                     51910000
            do begin                                                    51915000
               clearbit(rlmap,xreg-1);                                  51920000
               xreg _ xreg-1                                            51925000
               end until =                                              51930000
            end;                                                        51935000
         if s0 = rlns then  <<last section?>>                           51940000
            begin                                                       51945000
            tos _ rlfl.(7:9)&lsl(2);                                    51950000
            while <> do                                                 51955000
               begin                                                    51960000
               clearbit(rlmap,s0);                                      51965000
               tos _ (tos+1).(5:11)                                     51970000
               end;                                                     51975000
            del                                                         51980000
            end;                                                        51985000
         fwritedir'(rlfnum,rlmap,s0);                                   51990000
         tos _ tos-1                                                    51995000
         end until =;                                                   52000000
      rlstate.(1:2) := %(2)11  <<init. state word>>                     52005000
      end                                                               52010000
   else  <<read record 0 and first map>>                                52015000
      begin                                                             52020000
      rlfnum _ fopen(bfilename,%(2)10000000011,%(2)111110100);          52025000
      if < then go fopenerror;  <<error?>>                              52030000
      tos _ 0;                                                          52035000
      fgetinfo(rlfnum,,,aoptions,,,,,s0);  <<get file code>>   <<00563>>52040000
      if aoptions.(7:9) <> %764 then                           <<00563>>52045000
         begin                                                 <<00563>>52050000
         error(96);                                            <<00563>>52055000
         closerl;                                              <<00563>>52060000
         go nfg;                                               <<00563>>52065000
         end;                                                  <<00563>>52070000
      flock(rlfnum,true);  <<get file exclusively>>            <<00563>>52075000
      freadmr'(rlfnum,rlrec0,p256,0);  <<record 0 and map>>             52080000
      if tos <> rlfilecode or rllid <> 3 then  <<type rl?>>             52085000
         begin                                                          52090000
         error(22);                                                     52095000
         go nfg                                                         52100000
         end;                                                           52105000
      rlstate.(1:2) := %(2)00  <<init. state word>>                     52110000
      end;                                                              52115000
                                                                        52120000
   <<* * * init. global parameters * * *>>                              52125000
                                                                        52130000
   assemble(dzro,dzro; zero);                                           52135000
   rlmaprecd _ 1; rlmapmodified _ tos;                                  52140000
   rlentrymodified _ tos;                                               52145000
   nrprocsadded _ tos; nrprocsdeleted _ tos; cleanuprldir _ tos;        52150000
   go getout;                                                           52155000
                                                                        52160000
   nfg:                                                                 52165000
   if logical(flag) then  <<deallocate buffers?>>                       52170000
      begin                                                             52175000
      @dlarea1 := savedlarea1;  <<restore dl area 1 limit>>             52180000
      rlbufalloc := false  <<clear flag>>                               52185000
      end;                                                              52190000
                                                                        52195000
   getout:                                                              52200000
   end;                                                                 52205000
$page "RL FILE MAINTAINENCE PROCEDURES - CLOSERL"              <<00207>>52210000
$ control segment = seg40                                               52215000
procedure closerl;                                                      52220000
   <<if a rl file is opened, saves the information in core that         52225000
     has been modified: saves record 0.  note that this procedure uses  52230000
     the condition code to indicate an error>>                          52235000
   begin                                                                52240000
   tos := rlfnum;  <<rl file nr.>>                                      52245000
   if <> then  <<rl opened?>>                                           52250000
      begin                                                             52255000
      fixuprl;  <<complete any binding>>                                52260000
      fclose(rlfnum,rlnew,0);                                           52265000
      if < then  <<error?>>                                             52270000
         begin                                                          52275000
         tos _ 23;                                                      52280000
         tos _ 0d; fcheck(rlfnum,s0);                                   52285000
         errorn(*,*);                                                   52290000
         tos _ ccl;  <<error condition code>>                           52295000
         go getout                                                      52300000
         end;                                                           52305000
      rlstate.(1:2) := %(2)00;  <<re-set state word>>                   52310000
      rlfnum := 0  <<clear rl file nr.>>                                52315000
      end;                                                              52320000
   tos _ cce;  <<ok condition code>>                                    52325000
                                                                        52330000
   getout:                                                              52335000
   condcode _ tos  <<store condition code>>                             52340000
   end;                                                                 52345000
$page "RL FILE MAINTAINENCE PROCEDURES - FINDRLSPACE"          <<00207>>52350000
$ control segment = seg40                                               52355000
double procedure findrlspace (nrwords,recflag);                         52360000
   <<finds space in the rl file for nrwords and returns the file        52365000
     address as the result.  the number of words requested is rounded   52370000
     up to an integral number of 32 word blocks.  if the recflag is set,52375000
     the space will begin on a record boundary.  note that this         52380000
     procedure uses the condition code to indicate an error>>           52385000
   value nrwords,recflag;                                               52390000
   integer nrwords;                                                     52395000
   logical recflag;                                                     52400000
   begin                                                                52405000
   integer sectionnr = q+1;                                             52410000
   integer blocknr = q+2;                                               52415000
   integer nrblocks = q+3;                                              52420000
   integer blocks = q+4;                                                52425000
                                                                        52430000
   <<* * * initialize local variables * * *>>                           52435000
                                                                        52440000
   tos _ 0;  <<section nr.>>                                            52445000
   tos _ 0;  <<block nr.>>                                              52450000
   tos _ nrwords;  <<nr. words requested>>                              52455000
   if < or double(logical(nrwords)) >                                   52460000
      double(logical(rlfl-rlns-1))&dlsl(7) then                         52465000
      begin                                                             52470000
      error(11);  <<request too big>>                                   52475000
      go nfg                                                            52480000
      end;                                                              52485000
   tos _ (logical(tos)+31)&lsr(5);  <<nr. blocks requested>>            52490000
   tos _ s0;  <<nr. blocks needed>>                                     52495000
                                                                        52500000
   <<* * * search free maps * * *>>                                     52505000
                                                                        52510000
   tos _ rlns;  <<section counter>>                                     52515000
   do begin                                                             52520000
      getrlmap(sectionnr);  <<load section map>>                        52525000
      blocknr _ 0;                                                      52530000
      tos _ 2048;  <<block counter>>                                    52535000
      do begin                                                          52540000
         if testbit(rlmap,blocknr) and (not recflag or                  52545000
            blocks <> nrblocks or blocknr.(14:2) = 0) then              52550000
            begin                                                       52555000
            blocks _ blocks-1;  <<adj. blocks needed>>                  52560000
            if = then go foundspace                                     52565000
            end                                                         52570000
         else                                                           52575000
            begin                                                       52580000
            blocks _ nrblocks;  <<reset blocks needed>>                 52585000
            tos := double(logical(sectionnr))&dlsl(11);                 52590000
            tos := double(logical(blocknr));                            52595000
            assemble(inca,dadd);                                        52600000
            findrlspace := tos&dlsl(5)  <<new s.a. of space>>           52605000
            end;                                                        52610000
         blocknr _ blocknr+1;                                           52615000
         tos _ tos-1                                                    52620000
         end until =;                                                   52625000
      sectionnr _ sectionnr+1;                                          52630000
      assemble(del,deca)                                                52635000
      end until =;                                                      52640000
   error(11);  <<no room>>                                              52645000
   go nfg;                                                              52650000
                                                                        52655000
   <<* * * allocate space * * *>>                                       52660000
                                                                        52665000
   foundspace:                                                          52670000
   do begin                                                             52675000
      clearbit(rlmap,blocknr);  <<mark block "USED">>                   52680000
      rlmapmodified _ true;  <<set modified flag>>                      52685000
      blocknr _ blocknr-1;                                              52690000
      if < then                                                         52695000
         begin                                                          52700000
         blocknr _ 2047;                                                52705000
         sectionnr _ sectionnr-1;                                       52710000
         getrlmap(sectionnr)  <<load next map>>                         52715000
         end;                                                           52720000
      nrblocks _ nrblocks-1                                             52725000
      end until =;                                                      52730000
   tos _ cce;  <<ok condition code>>                                    52735000
   go getout;                                                           52740000
                                                                        52745000
   nfg:                                                                 52750000
   tos _ ccl;  <<error condition code>>                                 52755000
                                                                        52760000
   getout:                                                              52765000
   condcode _ tos                                                       52770000
   end;                                                                 52775000
$page "RL FILE MAINTAINENCE PROCEDURES - RETURNRLSPACE"        <<00207>>52780000
$ control segment = seg40                                               52785000
procedure returnrlspace (adr,nrwords);                                  52790000
   <<returns nrwords of space in the rl file beginning at file address  52795000
     adr.  the number of words returned is rounded up to an integral    52800000
     number of blocks>>                                                 52805000
   value adr,nrwords;                                                   52810000
   double adr;                                                          52815000
   integer nrwords;                                                     52820000
   begin                                                                52825000
   tos _ (logical(nrwords)+31)&lsr(5);  <<nr. blocks returned>>         52830000
   tos _ adr;  <<starting section nr.>>                                 52835000
   tos _ tos&lsr(5);  <<starting block nr.>>                            52840000
   getrlmap(s1);  <<load section map>>                                  52845000
   do begin                                                             52850000
      setbit(rlmap,s0);  <<mark block "FREE">>                          52855000
      rlmapmodified _ true;  <<set modified flag>>                      52860000
      tos _ (tos+1).(5:11);                                             52865000
      if = then  <<new section?>>                                       52870000
         begin                                                          52875000
         s1 _ s1+1;  <<next section>>                                   52880000
         getrlmap(s1)  <<get next section map>>                         52885000
         end;                                                           52890000
      s2 _ s2-1                                                         52895000
      end until =                                                       52900000
   end;                                                                 52905000
$page "RL FILE MAINTAINENCE PROCEDURES - GETRLMAP"             <<00207>>52910000
$ control segment = seg40                                               52915000
procedure getrlmap (sectionnr);                                         52920000
   <<loads the bit map for the specified section number>>               52925000
   value sectionnr;                                                     52930000
   integer sectionnr;                                                   52935000
   begin                                                                52940000
   sectionnr _ sectionnr+1;  <<convert to rec. nr.>>                    52945000
   if rlmaprecd <> sectionnr then  <<different map?>>                   52950000
      begin                                                             52955000
      saverlmap;  <<save current map>>                                  52960000
      rlmaprecd _ sectionnr;                                            52965000
      freaddir'(rlfnum,rlmap,rlmaprecd)  <<read map>>                   52970000
      end                                                               52975000
   end;                                                                 52980000
$page "RL FILE MAINTAINENCE PROCEDURES - SAVERLMAP"            <<00207>>52985000
$ control segment = seg40                                               52990000
procedure saverlmap;                                                    52995000
   <<saves the current section bit map if it has been modified>>        53000000
   begin                                                                53005000
   if rlmapmodified then  <<map modified?>>                             53010000
      begin                                                             53015000
      fwritedir'(rlfnum,rlmap,rlmaprecd);                               53020000
      rlmapmodified _ false  <<clear modified flag>>                    53025000
      end                                                               53030000
   end;                                                                 53035000
$page "RL FILE MAINTAINENCE PROCEDURES - SEARCHRL"             <<00207>>53040000
$ control segment = seg40                                               53045000
logical procedure searchrl (name);                                      53050000
   <<searches the rl file directory for the entry point having the      53055000
     specified name.  if found, the result true is returned and the     53060000
     entry parameters are set; otherwise the result false is returned>> 53065000
   integer array name;                                                  53070000
   begin                                                                53075000
   cleanuprlbuf;  <<save modified entry>>                               53080000
   rlbucket _ rlfhi+hash(name);  <<index of hash list>>                 53085000
   rlrecd _ 0;                                                          53090000
   rlnextrecd _ rlrec0(rlbucket);  <<first rec. in list>>               53095000
   while getnextrlrecd do                                               53100000
      begin                                                             53105000
      @rlp _ @rldir(2);  <<init. entry pointer>>                        53110000
      while @rlp < @rldir(rldirused) do                                 53115000
         begin                                                          53120000
         rlentryparms;  <<get entry parm's>>                            53125000
         if name.(4:4) = rlnc then                                      53130000
            begin                                                       53135000
            tos _ @name&lsl(1)+1; tos _ @rlname&lsl(1)+1;               53140000
            if * = *,(rlnc) then  <<names match?>>                      53145000
               begin                                                    53150000
               tos _ deletedproc(rlinfo);                               53155000
               if s0 = 0 or ps0(2) = 0 then                             53160000
                  begin                                                 53165000
                  searchrl _ true;                                      53170000
                  return                                                53175000
                  end;                                                  53180000
               del                                                      53185000
               end                                                      53190000
            end;                                                        53195000
         @rlp _ @rlp+rlnw  <<next entry>>                               53200000
         end                                                            53205000
      end                                                               53210000
   end;                                                                 53215000
$page "RL FILE MAINTAINENCE PROCEDURES - GETNEXTRLRECD"        <<00207>>53220000
$ control segment = seg40                                               53225000
logical procedure getnextrlrecd;                                        53230000
   <<loads the next record in the current hash list.  if there are no   53235000
     more records, the value false is returned>>                        53240000
   begin                                                                53245000
   cleanuprlbuf;  <<save modified entry>>                               53250000
   rlprevrecd _ rlrecd;  <<save previous rec. nr.>>                     53255000
   rlrecd _ rlnextrecd;  <<next rec. nr.>>                              53260000
   if = then return;  <<no more records?>>                              53265000
   freaddir'(rlfnum,rldir,rlrecd);                                      53270000
   rlnextrecd _ rldirlink;  <<save next rec. nr.>>                      53275000
   getnextrlrecd _ true                                                 53280000
   end;                                                                 53285000
$page "RL FILE MAINTAINENCE PROCEDURES - RLENTRYPARMS"         <<00207>>53290000
$ control segment = seg40                                               53295000
procedure rlentryparms;                                                 53300000
   <<calculates the parameters of the current entry>>                   53305000
   begin                                                                53310000
   rlnc _ rlp.(4:4);  <<nr. char's in name>>                            53315000
   rlnamenw _ rlnc&lsr(1)+1;  <<nr. words for entry name>>              53320000
   @rlp1 _ @rlp+rlnamenw;  <<init. secondary pointer>>                  53325000
   rlnw _ rlnamenw+4+parmlen(rlparms)  <<nr. words for entry>>          53330000
   end;                                                                 53335000
$page "RL FILE MAINTAINENCE PROCEDURES - SETUPRLBUF"           <<00207>>53340000
$ control segment = seg40                                               53345000
procedure setuprlbuf;                                                   53350000
   <<initializes the directory buffers and parameters for stepping thru 53355000
     the entire directory>>                                             53360000
   begin                                                                53365000
   cleanuprlbuf;  <<save modified entry>>                               53370000
   rlbucket _ rlfhi-1;  <<init. hash list index>>                       53375000
   rlrecd _ 0;                                                          53380000
   rlnextrecd _ 0;                                                      53385000
   rldirused _ 2;                                                       53390000
   rlnw _ 2;                                                            53395000
   @rlp _ @rldir  <<init. entry pointer>>                               53400000
   end;                                                                 53405000
$page "RL FILE MAINTAINENCE PROCEDURES - GETNEXTRLENTRY"       <<00207>>53410000
$ control segment = seg40                                               53415000
logical procedure getnextrlentry;                                       53420000
   <<gets the next directory entry>>                                    53425000
   begin                                                                53430000
   @rlp _ @rlp+rlnw;  <<next entry>>                                    53435000
   if @rlp = @rldir(rldirused) then  <<read next record?>>              53440000
      begin                                                             53445000
      if not getnextrlrecd then  <<next hash list?>>                    53450000
         begin                                                          53455000
         do rlbucket _ rlbucket+1 until rlrec0(rlbucket) <> 0;          53460000
         if rlbucket > 127 then return;  <<all done?>>                  53465000
         rlrecd _ 0;                                                    53470000
         rlnextrecd _ rlrec0(xreg);                                     53475000
         getnextrlrecd                                                  53480000
         end;                                                           53485000
      @rlp _ @rldir(2)  <<reset entry pointer>>                         53490000
      end;                                                              53495000
   rlentryparms;  <<get entry parm's>>                                  53500000
   getnextrlentry _ true                                                53505000
   end;                                                                 53510000
$page "RL FILE MAINTAINENCE PROCEDURES - FINDRLDIRSPACE"       <<00207>>53515000
$ control segment = seg40                                               53520000
procedure findrldirspace (hashcode,nrwords);                            53525000
   <<steps thru the directory record list for the specified hash code   53530000
     looking for room for an entry of nrwords.  if no record can be     53535000
     found, a new record is allocated and linked into the hash list.    53540000
     if space is found, the primary entry pointer is set to the space   53545000
     allocated for the new entry.  note that this procedure uses the    53550000
     condition code to indicate an error>>                              53555000
   value hashcode,nrwords;                                              53560000
   integer hashcode,nrwords;                                            53565000
   begin                                                                53570000
   cleanuprlbuf;  <<save modified entry>>                               53575000
   rlbucket _ rlfhi+hashcode;  <<index of hash list>>                   53580000
   rlrecd _ 0;                                                          53585000
   rlnextrecd _ rlrec0(rlbucket);                                       53590000
   if <> then  <<empty hash list?>>                                     53595000
      do assemble(nop)  <<compilet kludge>>                             53600000
         until not getnextrlrecd or 128-rldirused >= nrwords;           53605000
   if rlrecd = 0 then  <<get new record for hash list?>>                53610000
      begin                                                             53615000
      tos _ findrlspace(128,true);  <<find a record>>                   53620000
      if < then go nfg;  <<no room?>>                                   53625000
      tos _ tos&dlsr(7);  <<rec. nr.>>                                  53630000
      rlrecd _ tos;  <<save rec. nr.>>                                  53635000
      tos _ rlrec0(rlbucket);  <<old s.a. of hash list>>                53640000
      rlnextrecd _ s0;                                                  53645000
      rlrec0(xreg) _ rlrecd;  <<new s.a. of hash list>>                 53650000
      tos _ 2;  <<used space count>>                                    53655000
      rlddir _ tos;  <<update dir. buffer>>                             53660000
      rlprevrecd _ 0  <<prev. rec. nr.>>                                53665000
      end;                                                              53670000
   @rlp _ @rldir(rldirused);  <<init. entry pointer>>                   53675000
   rldirused _ rldirused+nrwords;  <<adj. used space count>>            53680000
   rlentrymodified _ true;  <<set modified flag>>                       53685000
   tos _ cce;  <<ok condition code>>                                    53690000
   go getout;                                                           53695000
                                                                        53700000
   nfg:                                                                 53705000
   tos _ ccl;  <<error condition code>>                                 53710000
                                                                        53715000
   getout:                                                              53720000
   condcode _ tos  <<store condition code>>                             53725000
   end;                                                                 53730000
$page "RL FILE MAINTAINENCE PROCEDURES - DELETERLENTRY"        <<00207>>53735000
$ control segment = seg40                                               53740000
procedure deleterlentry;                                                53745000
   <<deletes the current entry from the current directory record.  if   53750000
     the record is void of entries, the space is returned>>             53755000
   begin                                                                53760000
   move rlp _ rlp(rlnw),(rldirused-@rlp+@rldir-rlnw);                   53765000
   rldirused _ rldirused-rlnw;  <<adj. used space count>>               53770000
   if rldirused = 2 then  <<empty record?>>                             53775000
      begin                                                             53780000
      if rlrec0(rlbucket) = rlrecd                                      53785000
         then rlrec0(xreg) _ rldir  <<new. s.a. of hash list>>          53790000
         else repairrecord'(rlfnum,rlprevrecd,0,rldir);                 53795000
      returnrlspace(double(logical(rlrecd))&dlsl(7),128)                53800000
      end;                                                              53805000
   rlnw _ 0;  <<zero entry length>>                                     53810000
   rlentrymodified _ true  <<set modified flag>>                        53815000
   end;                                                                 53820000
$page "RL FILE MAINTAINENCE PROCEDURES - CLEANUPRLBUF"         <<00207>>53825000
$ control segment = seg40                                               53830000
procedure cleanuprlbuf;                                                 53835000
   <<saves the current directory record if it has been modified>>       53840000
   begin                                                                53845000
   if rlentrymodified then                                              53850000
      begin                                                             53855000
      fwritedir'(rlfnum,rldir,rlrecd);  <<save modified record>>        53860000
      rlentrymodified _ false  <<clear modified flag>>                  53865000
      end                                                               53870000
   end;                                                                 53875000
$page "RL FILE MAINTAINENCE PROCEDURES - INSERTRL"             <<00207>>53880000
$ control segment = seg40                                               53885000
procedure insertrl;                                                     53890000
   <<inserts the current usl procedure into the current rl file>>       53895000
   begin                                                                53900000
   integer nwinfo = q+1;  <<nr. words in info block>>                   53905000
   double sainfo = q+2;  <<file adr. of info block>>                    53910000
   integer nrentpts = q+4;  <<nr. entry points>>                        53915000
   logical bitmap0 = q+5;  <<illegal header nr's>>                      53920000
   integer nwparms = q+6;  <<parm. info length>>                        53925000
                                                                        53930000
   <<* * * initialize local variables * * *>>                           53935000
                                                                        53940000
   tos _ 10+entnwcode;                                                  53945000
   tos _ 0d;                                                            53950000
   tos _ 0;                                                             53955000
   tos:=%(2)0000000101100000;                                  <<04126>>53960000
   tos := entparmlen;                                                   53965000
                                                                        53970000
   if not primaryproc then  <<primary entry point?>>                    53975000
      begin                                                             53980000
      error(87);                                                        53985000
      return                                                            53990000
      end;                                                              53995000
   if fatalerror then  <<fatal error?>>                                 54000000
      begin                                                             54005000
      error(46);                                                        54010000
      return                                                            54015000
      end;                                                              54020000
   if warning then warn(47);  <<non-fatal error?>>                      54025000
                                                                        54030000
   <<* * * determine info block size * * *>>                            54035000
                                                                        54040000
   while getnextdescrip do                                              54045000
      begin                                                             54050000
      if bitmap0&csr(eheadtype) then  <<illegal header?>>               54055000
         begin                                                          54060000
            error(1);                                                   54065000
         return                                                         54070000
         end;                                                           54075000
      tos _ eheadnw;  <<nr. words in header>>                           54080000
      if eheadtype = 1 then tos _ tos+4;                                54085000
      nwinfo _ tos+nwinfo                                               54090000
      end;                                                              54095000
   uslentryparms;  <<restore entry parm's>>                             54100000
                                                                        54105000
   <<* * * allocate info block space * * *>>                            54110000
                                                                        54115000
   sainfo _ findrlspace(nwinfo,false);                                  54120000
   if < then return;  <<no room?>>                                      54125000
                                                                        54130000
   <<* * * insert entry points in directory * * *>>                     54135000
                                                                        54140000
   dbuf _ sainfo;  <<s.a. of info block>>                               54145000
   buf(3) _ ecode;  <<code module descriptor>>                          54150000
   move buf(4) := eparms,(nwparms);  <<parm. info>>                     54155000
   tos _ entfileadr;  <<save adr. of entry>>                            54160000
   do if active then                                                    54165000
      begin                                                             54170000
      if searchrl(ename) then  <<duplicately defined?>>                 54175000
         begin                                                          54180000
         errors(12,ename);                                              54185000
         go abort1                                                      54190000
         end;                                                           54195000
      findrldirspace(enthash,entnamenw+4+                      <<00.dm>>54200000
                (if secparmproc then entparmlen else nwparms));<<00.dm>>54205000
      if < then go abort1;  <<no room?>>                                54210000
      move rlname _ ename,(entnamenw),2;  <<entry point name>>          54215000
      rlname.(0:1) := not primaryproc;  <<pri./sec. entry bit>>         54220000
      buf(2) := entp1(if primaryproc then 2 else 1);  <<s.a. entry>>    54225000
      if secparmproc then                                      <<00.dm>>54230000
         begin                                                 <<00.dm>>54235000
         move * := buf,(4),2;                                  <<00.dm>>54240000
         move * := eparms,(entparmlen);                        <<00.dm>>54245000
         end                                                   <<00.dm>>54250000
       else                                                    <<00.dm>>54255000
         move * := buf,(4+nwparms);                            <<00.dm>>54260000
      rlentrymodified _ true;  <<set modified flag>>                    54265000
      nrentpts _ nrentpts+1  <<bump nr. entry points>>                  54270000
      end until not getfamily(s0);                                      54275000
                                                                        54280000
   <<* * * insert info block preamble * * *>>                           54285000
                                                                        54290000
   tfnum1 _ rlfnum;                                                     54295000
   tos _ sainfo&dlsl(9);                                                54300000
   tdisp1 _ tos&lsr(9);                                                 54305000
   trecd1 _ tos;                                                        54310000
   if trecd1 < feof(rlfnum) then  <<prime buffer?>>                     54315000
      freaddir'(rlfnum,tbuf1,trecd1);                                   54320000
   tos _ nwinfo;                                                        54325000
   tos _ entnwcode;                                                     54330000
   tos _ nrentpts;                                                      54335000
   if = then  <<no entry points?>>                                      54340000
      begin                                                             54345000
      error(28);                                                        54350000
      go abort2                                                         54355000
      end;                                                              54360000
   corebuf1(s2,3);                                                      54365000
                                                                        54370000
   <<* * * insert code module * * *>>                                   54375000
                                                                        54380000
   masterbuf(rlfnum,uslfnum,tbuf1,trecd1,tdisp1,true,uslsai+entcodeadr, 54385000
      buf,entnwcode);                                                   54390000
                                                                        54395000
   <<* * * insert headers * * *>>                                       54400000
                                                                        54405000
   move buf(2) _ etpdb,(4);  <<global requirements>>                    54410000
   corebuf1(buf,6);  <<insert dummy extn link and db info>>             54415000
   while getnextheader(false,-1) do                                     54420000
      begin                                                             54425000
      if headtype = 1 then  <<pcal?>>                                   54430000
         begin                                                          54435000
         buf _ headp+%(2)10000000;  <<adj. header length>>              54440000
         corebuf1(buf,5);                                               54445000
         headp(2).(0:1) _ 0;  <<clear satisfied bit>>                   54450000
         corebuf1(headp(1),headnw-1)                                    54455000
         end                                                            54460000
      else corebuf1(headp,headnw);                                      54465000
      end;                                                              54470000
   tbuf1(tdisp1) _ -1;  <<list terminator>>                             54475000
   fwritedir'(rlfnum,tbuf1,trecd1);  <<empty buffer>>                   54480000
                                                                        54485000
   <<* * * update procedure table * * *>>                               54490000
                                                                        54495000
   if rlproctablen-nrprocsadded&lsl(2)-nrprocsdeleted&lsl(2) < 4 then   54500000
      fixuprl;  <<bind procedures>>                                     54505000
   nrprocsadded _ nrprocsadded+1;                                       54510000
   tos _ @rlproctab+rlproctablen-nrprocsadded&lsl(2);                   54515000
   dps0 _ sainfo;                                                       54520000
   tos _ tos+2;                                                         54525000
   tos _ nwinfo;                                                        54530000
   tos _ entnwcode;                                                     54535000
   dps2 _ tos;                                                          54540000
   go getout;                                                           54545000
                                                                        54550000
   abort1:                                                              54555000
   setuprlbuf;                                                          54560000
   while getnextrlentry do if rlinfo = sainfo then deleterlentry;       54565000
                                                                        54570000
   abort2:                                                              54575000
   returnrlspace(sainfo,nwinfo);                                        54580000
                                                                        54585000
   getout:                                                              54590000
   rlrec0mod _ true  <<set modified flag>>                              54595000
   end;                                                                 54600000
$page "RL FILE MAINTAINENCE PROCEDURES - REMOVERL"             <<00207>>54605000
$ control segment = seg40                                               54610000
procedure removerl;                                                     54615000
   <<deletes the current entry point or procedure from the current rl>> 54620000
   begin                                                                54625000
   integer recd;                                                        54630000
   integer disp;                                                        54635000
   double kludge = recd;                                                54640000
   tos _ deletedproc(rlinfo);                                           54645000
   assemble(test);                                                      54650000
   if = then  <<create new entry?>>                                     54655000
      begin                                                             54660000
      if rlproctablen-nrprocsadded&lsl(2)-nrprocsdeleted&lsl(2) < 4 then54665000
         begin                                                 <<00.dm>>54670000
         fixuprl;  <<bind procedures>>                                  54675000
         <<point to correct entry again after fixup!>>         <<00.dm>>54680000
         if not searchrl(name) then return;                    <<00.dm>>54685000
         end;                                                  <<00.dm>>54690000
      tos _ @rlproctab+nrprocsdeleted&lsl(2);  <<entry pointer>>        54695000
      nrprocsdeleted _ nrprocsdeleted+1;                                54700000
      dps0 _ rlinfo  <<insert s.a. info block>>                         54705000
      end;                                                              54710000
   tos _ tos+2;  <<bump table pointer>>                                 54715000
   tos _ rlinfo&dlsl(9);                                                54720000
   tos _ tos&lsr(9);                                                    54725000
   kludge _ tos;                                                        54730000
   freadmr''(rlfnum,buf,p256,recd);                                     54735000
   tos _ @buf(disp);  <<pointer to info block preamble>>                54740000
   dps1 _ dps0;  <<nr. words info and nr. words code>>                  54745000
   tos _ tos+2;  <<bump info pointer>>                                  54750000
   ps0 _ ps0-1;  <<dec. nr. entry points>>                              54755000
   if <> then  <<last entry point?>>                                    54760000
      if class = entryclass then                                        54765000
         begin                                                          54770000
         ps1 _ 0;  <<clear nr. words info>>                             54775000
         fwritemr''(rlfnum,buf,p256,recd)  <<save new info preamble>>   54780000
         end                                                            54785000
      else cleanuprldir _ true;  <<set directory flag>>                 54790000
   deleterlentry;  <<delete entry point>>                               54795000
   rlrec0mod _ true  <<set modified flag>>                              54800000
   end;                                                                 54805000
$page "RL FILE MAINTAINENCE PROCEDURES - FIXUPRL"              <<00207>>54810000
$ control segment = seg40                                               54815000
procedure fixuprl;                                                      54820000
   <<completes any remaining linkage or procedure binding in the        54825000
     current rl file>>                                                  54830000
   begin                                                                54835000
   array parms(0:4)=q;                                         <<00595>>54840000
   integer pointer badprocs;        <<bad procedure table>>    <<00595>>54845000
   double  pointer dbadprocs = badprocs;                       <<00595>>54850000
   integer nrbadprocs := 0;   <<nr. bad procedures>>           <<00595>>54855000
   double prevextnadr := 0d;  <<prev. extn. set adr.>>         <<00595>>54860000
   double extnadr := 0d;  <<current extn. set adr.>>           <<00595>>54865000
   double nextextnadr := 0d;  <<next extn. set adr.>>          <<00595>>54870000
   double saveadr := 0d;                                       <<00595>>54875000
                                                                        54880000
   logical subroutine badlogged;                               <<00.dm>>54885000
      << checks to see if bad procedure has been >>            <<00.dm>>54890000
      << logged already                          >>            <<00.dm>>54895000
      begin                                                    <<00.dm>>54900000
      xreg := nrbadprocs&lsl(1);                               <<00.dm>>54905000
      while xreg > 0 do                                        <<00.dm>>54910000
         begin                                                 <<00.dm>>54915000
         xreg := xreg-2;                                       <<00.dm>>54920000
         if dbadprocs(xreg) = rlinfo then                      <<00.dm>>54925000
            begin                                              <<00.dm>>54930000
            badlogged := true;                                 <<00.dm>>54935000
            return;                                            <<00.dm>>54940000
            end;                                               <<00.dm>>54945000
         end;                                                  <<00.dm>>54950000
      end;                                                     <<00.dm>>54955000
                                                                        54960000
   double subroutine newinfo;                                           54965000
      <<searches the added procedure table to determine if a new        54970000
        external set should be the successor of the current one.  if so 54975000
        returns the address of the external set; otherwise returns 0d>> 54980000
      begin                                                             54985000
      newinfo _ bigd;  <<init. result>>                                 54990000
      tos _ nrprocsadded;  <<entry counter>>                            54995000
      if = then go del1;  <<no proc's added?>>                          55000000
      tos _ @rlproctab+rlproctablen-nrprocsadded&lsl(2);                55005000
      do begin                                                          55010000
         tos _ dps0+double(logical(ps0(3)+3));  <<s.a. extn. set>>      55015000
         if extnadr < ds1 and ds1 < nextextnadr and ds1 < ds6 then      55020000
           ds6 _ ds1;                                                   55025000
         ddel;                                                          55030000
         tos _ tos+4;  <<bump entry pointer>>                           55035000
         assemble(decb)                                                 55040000
         end until =;                                                   55045000
      del2: del;                                                        55050000
      del1: del;                                                        55055000
      if ds2 = bigd then newinfo _ 0d  <<check result>>                 55060000
      end;                                                              55065000
                                                                        55070000
   subroutine successor;                                                55075000
      <<initializes the successor link in the current external set if   55080000
        it is a new external set and determines the true successor of   55085000
        the current external set>>                                      55090000
      begin                                                             55095000
      tos _ saveadr;                                                    55100000
      if <> then  <<init. successor link>>                              55105000
         begin                                                          55110000
         rlxlink _ ds1;  <<insert link>>                                55115000
         rlextnmod _ true;  <<set modified flag>>                       55120000
         nextextnadr _ tos;  <<correct next adr.>>                      55125000
         tos _ 0d                                                       55130000
         end;                                                           55135000
      saveadr _ tos;  <<clear flag adr.>>                               55140000
      tos _ newinfo;                                                    55145000
      assemble(ddup,dtst);                                              55150000
      if <> then  <<new successor?>>                                    55155000
         begin                                                          55160000
         saveadr _ nextextnadr;  <<save successor adr.>>                55165000
         if extnadr = 0d then                                           55170000
            rlsaxl _ tos  <<update s.a. of external list>>              55175000
         else                                                           55180000
            begin                                                       55185000
            rlxlink _ tos;  <<update successor link>>                   55190000
            rlextnmod _ true  <<set modified flag>>                     55195000
            end;                                                        55200000
         nextextnadr _ tos  <<correct next adr.>>                       55205000
         end                                                            55210000
      else assemble(ddel,ddel)                                          55215000
      end;                                                              55220000
                                                                        55225000
   logical subroutine oldinfo;                                          55230000
      <<searches the deleted procedure table to determine if the current55235000
        external set should be deleted.  if so, returns the value true; 55240000
        otherwise returns the value false>>                             55245000
      begin                                                             55250000
      tos _ nrprocsdeleted;  <<entry counter>>                          55255000
      if = then  <<no proc's deleted?>>                                 55260000
         begin                                                          55265000
         del;                                                           55270000
         return                                                         55275000
         end;                                                           55280000
      tos _ @rlproctab;  <<entry pointer>>                              55285000
      do begin                                                          55290000
         if extnadr = dps0+double(logical(ps0(3)+3)) and                55295000
            ps0(2) <> 0 then                                            55300000
            begin                                                       55305000
            assemble(ddel,incb);                                        55310000
            return                                                      55315000
            end;                                                        55320000
         tos _ tos+4;  <<bump entry pointer>>                           55325000
         assemble(decb)                                                 55330000
         end until =;                                                   55335000
      ddel                                                              55340000
      end;                                                              55345000
                                                                        55350000
   subroutine unlink;                                                   55355000
      <<unlinks the current external set from the external set list>>   55360000
      begin                                                             55365000
      if prevextnadr = 0d then                                          55370000
         rlsaxl _ nextextnadr  <<new s.a. of external list>>            55375000
      else                                                              55380000
         begin                                                          55385000
         tos _ prevextnadr&dlsl(9);  <<rec. nr.>>                       55390000
         tos _ tos&lsr(9);  <<rec. disp.>>                              55395000
         if s1 >= rlextnrecd then  <<in buffer?>>                       55400000
            begin                                                       55405000
            tos _ @rlextnbuf+(s1-rlextnrecd)&lsl(7)+s0;                 55410000
            dps0 _ nextextnadr;  <<insert new link>>                    55415000
            rlextnmod _ true  <<set modified flag>>                     55420000
            end                                                         55425000
         else  <<on disc>>                                              55430000
            begin                                                       55435000
            freadmr''(rlfnum,buf,p256,s1);                              55440000
            tos _ @buf+s0;                                              55445000
            dps0 _ nextextnadr;  <<insert new link>>                    55450000
            fwritemr''(rlfnum,buf,p256,s2)                              55455000
            end;                                                        55460000
         assemble(del,ddel)                                             55465000
         end;                                                           55470000
      extnadr _ prevextnadr  <<prevent change of prev. adr.>>           55475000
      end;                                                              55480000
                                                                        55485000
   subroutine bindprocs;                                                55490000
      <<binds (if necessary) the externals in the current external set>>55495000
      begin                                                             55500000
      while getnextrlextn do                                            55505000
         begin                                                          55510000
                                                                        55515000
         <<* * * unbind external * * *>>                                55520000
                                                                        55525000
         if nrprocsdeleted <> 0 and rlxsatisfied and                    55530000
            deletedproc(rlxinfo) <> 0 then                              55535000
            begin                                                       55540000
            rlxsatisfiedbit _ 0;  <<set to "UNSATISFIED">>              55545000
            rlextnmod _ true  <<set modified flag>>                     55550000
            end;                                                        55555000
         if nrprocsadded <> 0 and not rlxsatisfied and                  55560000
            searchrl(rlxname) then                                      55565000
            begin                                              <<00595>>55570000
            parmcheck(rlparms,rlxparms,parms);                 <<00595>>55575000
            if parms = 0 then  <<error?>>                      <<00595>>55580000
               begin                                                    55585000
               rlxname.(0:3) _ 4 cat rlname (14:1:2);                   55590000
               rlxcode _ rlcode;                                        55595000
               rlxinfo _ rlinfo;                                        55600000
               rlxsa _ rlsa;                                            55605000
               rlextnmod _ true  <<set modified flag>>                  55610000
               end                                                      55615000
            else                                                        55620000
               begin                                                    55625000
               tos := @badprocs+nrbadprocs&lsl(2);             <<00.dm>>55630000
               tos := addedproc(rlinfo);                       <<00.dm>>55635000
               tos := 4;                                       <<00.dm>>55640000
               if s1 <> 0 then                                 <<00.dm>>55645000
                  begin    << bad actual parameters >>         <<00.dm>>55650000
                  if not badlogged then                        <<00.dm>>55655000
                     begin                                     <<00.dm>>55660000
                     assemble( move 0 );                       <<00.dm>>55665000
                     nrbadprocs := nrbadprocs+1;               <<00.dm>>55670000
                     end;                                      <<00.dm>>55675000
                  case parms of                                <<00595>>55680000
                     begin                                     <<00595>>55685000
                     ;                                         <<00595>>55690000
                     errors2( 49, rlxname, rlname);            <<00595>>55695000
                     errors2( 50, rlxname, rlname);            <<00595>>55700000
                     begin                                     <<00595>>55705000
                        errors2( 45, rlxname, rlname);         <<00595>>55710000
                        printbitmap( parms(1));                <<00595>>55715000
                     end;                                      <<00595>>55720000
                     end;                                      <<00595>>55725000
                  end                                          <<00.dm>>55730000
               else                                            <<00.dm>>55735000
                  begin     << bad formal parameters >>        <<00.dm>>55740000
                  setuprlbuf;                                  <<00.dm>>55745000
                  while getnextrlentry do                      <<00.dm>>55750000
                     if extnadr = rlinfo+double(rlnwc)+3d then <<04755>>55755000
                        begin                                  <<00.dm>>55760000
                        if not badlogged then                  <<00.dm>>55765000
                           begin                               <<00.dm>>55770000
                           s1 := addedproc(rlinfo);            <<00.dm>>55775000
                           if s1 <> 0 then                     <<00.dm>>55780000
                              begin                            <<00.dm>>55785000
                              assemble( move 0 );              <<00.dm>>55790000
                              nrbadprocs := nrbadprocs+1;      <<00.dm>>55795000
                              end;                             <<00.dm>>55800000
                           end;                                <<00.dm>>55805000
                        case parms of                          <<00595>>55810000
                           begin                               <<00595>>55815000
                           ;                                   <<00595>>55820000
                           errors2(49,rlxname,rlname);         <<00595>>55825000
                           errors2(50,rlxname,rlname);         <<00595>>55830000
                           begin                               <<00595>>55835000
                              errors2(45,rlxname,rlname);      <<00595>>55840000
                              printbitmap(parms(1));           <<00595>>55845000
                           end;                                <<00595>>55850000
                           end;                                <<00595>>55855000
                        end;                                   <<00.dm>>55860000
                  end;                                         <<00.dm>>55865000
                  ddel; del;  << del move parms >>             <<00.dm>>55870000
               end                                                      55875000
            end                                                         55880000
         end                                                            55885000
      end;                                                              55890000
                                                                        55895000
   tos _ nrprocsadded; tos _ nrprocsdeleted;                            55900000
   assemble(or,del);                                                    55905000
   if = then go getout;  <<nothing changed?>>                  <<00289>>55910000
   cleanuprlbuf;  <<save modified entries now!>>                        55915000
                                                                        55920000
   <<* * * initialize local variables * * *>>                           55925000
                                                                        55930000
   <<* * * allocate dl buffers * * *>>                                  55935000
                                                                        55940000
   makeroomindl(nrprocsadded&lsl(2)+rldlbufs2);                <<00.dm>>55945000
   if < then terminate;  <<no room?>>                                   55950000
   @badprocs _ @dlavail;                                                55955000
   @rlextnbuf _ @badprocs+nrprocsadded&lsl(2);                 <<00.dm>>55960000
   nrrlextnrecds _ (@dlarea1-@rlextnbuf)&lsr(7);                        55965000
   rlextnrecd _ -255; rlextnmod _ false;                                55970000
                                                                        55975000
   <<* * * return deleted storage * * *>>                               55980000
                                                                        55985000
   if nrprocsdeleted <> 0 then  <<proc's deleted?>>                     55990000
      begin                                                             55995000
                                                                        56000000
      <<* * * delete remaining entry points * * *>>                     56005000
                                                                        56010000
      if cleanuprldir then                                              56015000
         begin                                                          56020000
         cleanuprldir := false;                                <<00.dm>>56025000
         setuprlbuf;                                                    56030000
         while getnextrlentry do                                        56035000
            begin                                              <<00.dm>>56040000
            tos := deletedproc(rlinfo);                        <<00.dm>>56045000
            if s0 <> 0 then                                    <<00.dm>>56050000
               if ps0(2) <> 0 then deleterlentry;              <<00.dm>>56055000
            del;                                               <<00.dm>>56060000
            end;                                               <<00.dm>>56065000
         end;                                                           56070000
                                                                        56075000
      <<* * * delete info blocks * * *>>                                56080000
                                                                        56085000
      tos _ nrprocsdeleted;  <<entry counter>>                          56090000
      tos _ @rlproctab;  <<table pointer>>                              56095000
      do begin                                                          56100000
         tos _ dps0;  <<s.a. info block>>                               56105000
         tos _ ps2(2);  <<nr. words in info block>>                     56110000
         if <> then returnrlspace(*,*) else assemble(del,ddel);         56115000
         tos _ tos+4;  <<bump entry pointer>>                           56120000
         assemble(decb)                                                 56125000
         end until =;                                                   56130000
      ddel                                                              56135000
      end;                                                              56140000
                                                                        56145000
   <<* * * step thru external list sets * * *>>                         56150000
                                                                        56155000
   nextextnadr _ rlsaxl;  <<init. next adr.>>                           56160000
   successor;  <<determine successor>>                                  56165000
   while nextextnadr <> bigd do                                         56170000
      begin                                                             56175000
      setuprlextnbuf(nextextnadr);                                      56180000
      prevextnadr _ extnadr;                                            56185000
      extnadr _ nextextnadr;                                            56190000
      nextextnadr _ rlxlink;                                            56195000
      successor;  <<determine successor>>                               56200000
      if oldinfo then unlink else bindprocs                             56205000
      end;                                                              56210000
                                                                        56215000
   assemble(zero,zero);                                                 56220000
   nrprocsadded _ tos;                                                  56225000
   nrprocsdeleted _ tos;                                                56230000
   cleanuprlextnbuf;                                                    56235000
   tos _ nrbadprocs;                                                    56240000
   if <> then  <<binding error?>>                                       56245000
      begin                                                             56250000
      cleanuprldir := true;                                    <<00.dm>>56255000
      nrprocsdeleted _ tos;                                             56260000
      move rlproctab _ badprocs,(nrbadprocs&lsl(2));                    56265000
      fixuprl  <<delete and re-bind>>                                   56270000
      end;                                                     <<00231>>56275000
getout:                                                        <<00289>>56280000
   if rlrec0mod then <<record 0 modified?>>                    <<00231>>56285000
      begin                                                    <<00231>>56290000
      fwritedir'(rlfnum,rlrec0,0); <<save record 0>>           <<00231>>56295000
      rlrec0mod := false; <<clear flag>>                       <<00231>>56300000
      end;                                                     <<00231>>56305000
   cleanuprlbuf; <<save directory record>>                     <<00231>>56310000
   saverlmap;    <<save storage map buffer>>                   <<00231>>56315000
   end;                                                                 56320000
$page "RL FILE MAINTAINENCE PROCEDURES - ADDPROC"              <<00207>>56325000
                                                                        56330000
$ control segment = seg40                                               56335000
integer procedure addedproc (infoadr);                                  56340000
   <<searches the modified procedure table to see if the procedure      56345000
     specified by the given info block address has been modified.  if   56350000
     so, a pointer to the entry is returned; otherwise a zero is        56355000
     returned>>                                                         56360000
   value infoadr;                                                       56365000
   double infoadr;                                                      56370000
   begin                                                                56375000
   entry deletedproc;                                                   56380000
   tos _ nrprocsadded;  <<entry counter>>                               56385000
   if = then return;  <<no proc's added?>>                              56390000
   tos _ @rlproctab+rlproctablen-nrprocsadded&lsl(2);  <<entry pointer>>56395000
   go loop;                                                             56400000
                                                                        56405000
   deletedproc:                                                         56410000
   tos _ nrprocsdeleted;  <<entry counter>>                             56415000
   if = then return;  <<no proc's deleted?>>                            56420000
   tos _ @rlproctab;  <<entry pointer>>                                 56425000
                                                                        56430000
   loop:                                                                56435000
   do begin                                                             56440000
      if dps0 = infoadr then                                            56445000
         begin                                                          56450000
         addedproc _ tos;  <<return entry pointer>>                     56455000
         return                                                         56460000
         end;                                                           56465000
      tos _ tos+4;  <<bump entry pointer>>                              56470000
      assemble(decb)                                                    56475000
      end until =                                                       56480000
   end;                                                                 56485000
$page "RL FILE MAINTAINENCE PROCEDURES - SETUPRLEXTNBUF"       <<00207>>56490000
$ control segment = seg40                                               56495000
procedure setuprlextnbuf (extnadr);                                     56500000
   <<sets up the buffer and parameters for stepping thru the external   56505000
     entries in the header set beginning at the specified file address>>56510000
   value extnadr;                                                       56515000
   double extnadr;                                                      56520000
   begin                                                                56525000
   integer recd = q+1;                                                  56530000
   integer disp = q+2;                                                  56535000
   tos _ extnadr&dlsl(9);                                               56540000
   tos _ tos&lsr(9);                                                    56545000
   if recd < rlextnrecd+nrrlextnrecds-1 then  <<set in buffer?>>        56550000
      tos _ (recd-rlextnrecd)&lsl(7)                                    56555000
   else  <<set on disc>>                                                56560000
      begin                                                             56565000
      cleanuprlextnbuf;                                                 56570000
      rlextnrecd _ recd;                                                56575000
      freadmr''(rlfnum,rlextnbuf,nrrlextnrecds&lsl(7),rlextnrecd);      56580000
      tos _ 0                                                           56585000
      end;                                                              56590000
   @rlxp _ tos+@rlextnbuf+disp;  <<set pointer to external link>>       56595000
   rlheadadr _ extnadr;  <<header set address>>                         56600000
   rlheadnw _ 6  <<phoney header length>>                               56605000
   end;                                                                 56610000
$page "RL FILE MAINTAINENCE PROCEDURES - GETNEXTRLEXTN"        <<00207>>56615000
$ control segment = seg40                                               56620000
logical procedure getnextrlextn;                                        56625000
   <<gets the next external entry in the current header set list>>      56630000
   begin                                                                56635000
   do begin                                                             56640000
      setuprlextnbuf(rlheadadr+double(logical(rlheadnw)));              56645000
      if rlxp = -1 then return;  <<last header?>>                       56650000
      rlheadnw _ rlxp.(1:10);  <<nr. words in header>>                  56655000
      end until rlxp.(11:5) = 1;                                        56660000
   @rlxp _ @rlxp+6;  <<set pointer to name>>                            56665000
   @rlxp1 _ @rlxp+rlxp.(4:3)+1;  <<word following name>>                56670000
   getnextrlextn _ true                                                 56675000
   end;                                                                 56680000
$page "RL FILE MAINTAINENCE PROCEDURES - CLEANUPRLEXTNBUF"     <<00207>>56685000
$ control segment = seg40                                               56690000
procedure cleanuprlextnbuf;                                             56695000
   <<saves the external buffer if the contents have been modified>>     56700000
   begin                                                                56705000
   if rlextnmod then  <<buffer modified?>>                              56710000
      begin                                                             56715000
      fwritemr''(rlfnum,rlextnbuf,nrrlextnrecds&lsl(7),rlextnrecd);     56720000
      rlextnmod _ false  <<clear modified flag>>                        56725000
      end                                                               56730000
   end;                                                                 56735000
$page "RL FILE MAINTAINENCE PROCEDURES - LISTRL'"              <<00207>>56740000
$ control segment = seg40                                               56745000
procedure listrl';                                                      56750000
   <<lists the contents of the current rl file>>                        56755000
   begin                                                                56760000
   byte array b0 (0:7)=pb _ "RL FILE ";                                 56765000
   byte array b1 (0:49)=pb _                                   <<00.dm>>56770000
      "ENTRY POINTS  CHECK ADR      LOC   NUM  CODE  INFO";    <<00.dm>>56775000
   byte array b2 (0:31)=pb _                                   <<00.dm>>56780000
      "EXTERNALS     CHECK ADR      LOC";                      <<00.dm>>56785000
   byte array b3 (0:3)=pb _ "USED";                                     56790000
   byte array b4 (0:8)=pb _ "AVAILABLE";                                56795000
   fixuprl;  <<complete any binding>>                                   56800000
                                                                        56805000
   <<* * * allocate dl buffers * * *>>                                  56810000
                                                                        56815000
   makeroomindl(rldlbufs2);                                             56820000
   if < then return;  <<no room?>>                                      56825000
   @rlextnbuf _ @dlavail;                                               56830000
   nrrlextnrecds _ (@dlarea1-@dlavail)&lsr(7);                          56835000
   rlextnrecd _ -255; rlextnmod _ false;                                56840000
   fcontrol(infnum,enable'ctly,i);                             <<00.dm>>56845000
   ctly := false;                                              <<00.dm>>56850000
                                                                        56855000
   blankline;                                                           56860000
   tos _ rlfnum;                                                        56865000
   move bline _ b0,(8),2;  <<"RL FILE">>                                56870000
   fgetinfo(*,*);  <<insert rl file name>>                              56875000
   printline;                                                           56880000
                                                                        56885000
   <<* * * list entry points * * *>>                                    56890000
                                                                        56895000
   blankline;                                                           56900000
   move bline _ b1,(50);  <<"ENTRY POINTS">>                   <<00.dm>>56905000
   printline;                                                           56910000
   blankline;                                                           56915000
   setuprlbuf;                                                          56920000
   while getnextrlentry do                                              56925000
      begin                                                             56930000
      if ctly then return;     <<check for control y>>         <<00.dm>>56935000
      tos _ @bline; tos _ @rlname&lsl(1)+1;                             56940000
      move * _ *,(rlnc);  <<entry name>>                                56945000
      ntoa(rlparms.(0:2),8,bline(16));  <<parm. checking level>>        56950000
      ntoa(rlsa,8,bline(22));  <<s.a. of entry point>>                  56955000
      dntoa(rlinfo,8,bline(31));  <<s.a. of info block>>                56960000
      if rlprimary then  <<primary entry point?>>                       56965000
         begin                                                          56970000
         tos _ rlinfo&dlsl(9);  <<rec. nr.>>                            56975000
         tos _ tos&lsr(9)+@buf;  <<info disp>>                          56980000
         freadmr''(rlfnum,buf,p256,s1);  <<load info preamble>>         56985000
         ntoa(ps0(2),8,bline(37));  <<nr. entry points>>                56990000
         ntoa(ps0(1),8,bline(43));  <<code module length>>              56995000
         ntoa(ps0,8,bline(49));  <<info block length>>                  57000000
         ddel                                                           57005000
         end;                                                           57010000
      printline                                                         57015000
      end;                                                              57020000
                                                                        57025000
   <<* * * list externals * * *>>                                       57030000
                                                                        57035000
   blankline;                                                           57040000
   move bline _ b2,(32); <<"EXTERNALS     CHECK ADR      LOC">><<00.dm>>57045000
   printline;                                                           57050000
   blankline;                                                           57055000
   tos _ rlsaxl;  <<s.a. of external list set>>                         57060000
   while ds1 <> bigd do                                                 57065000
      begin                                                             57070000
      setuprlextnbuf(*);                                                57075000
      tos _ rlxlink;  <<next external link>>                            57080000
      while getnextrlextn do                                            57085000
         begin                                                          57090000
         if ctly then return;    <<check for control y>>       <<00.dm>>57095000
         tos _ @bline; tos _ @rlxname&lsl(1)+1;                         57100000
         move * _ *,(rlxnc);  <<external name>>                         57105000
         ntoa(rlxparms.(0:2),8,bline(16));  <<parm. checking level>>    57110000
         if rlxsatisfied then  <<external satisfied?>>                  57115000
            begin                                                       57120000
            ntoa(rlxsa,8,bline(22));  <<s.a. of entry point>>           57125000
            dntoa(rlxinfo,8,bline(31))  <<s.a. of info block>>          57130000
            end;                                                        57135000
         printline                                                      57140000
         end                                                            57145000
      end;                                                              57150000
                                                                        57155000
   <<* * * list file parameters * * *>>                                 57160000
                                                                        57165000
   blankline;                                                           57170000
   tos _ 0d;  <<blocks free>>                                           57175000
   tos _ rlns-1;  <<section counter>>                                   57180000
   do begin                                                             57185000
      getrlmap(s0);  <<load section map>>                               57190000
      tos _ 2047;  <<block counter>>                                    57195000
      do begin                                                          57200000
         if testbit(rlmap,s0) then ds3 _ ds3+1d;                        57205000
         tos _ tos-1                                                    57210000
         end until <;                                                   57215000
      assemble(del,deca)                                                57220000
      end until <;                                                      57225000
   del;                                                                 57230000
   tos _ tos&dlsl(5);  <<words free>>                                   57235000
   move bline _ b3,(4);                                                 57240000
   dntoa(double(logical(rlfl))&dlsl(7)-ds1,8,bline(24));                57245000
   move bline(35) _ b4,(9); dntoa(*,8,bline(59));                       57250000
   printline;                                                           57255000
   ejectpage;                                                  <<00.dm>>57260000
   fcontrol(infnum,disable'ctly,i);                            <<00.dm>>57265000
   end;                                                                 57270000
$page "MISC.PROCEDURE - GETSYSFPMAP"                                    57275000
$control segment=seg1                                                   57280000
procedure getsysfpmap(sysfpmap);                               <<04584>>57285000
integer sysfpmap;                                              <<04584>>57290000
                                                               <<04584>>57295000
begin                                                          <<04584>>57300000
   equate sysdb        = %1000,                                <<04584>>57305000
          sysfpmapoffset  = %102,                              <<04584>>57310000
          sysglobextptoffset = %377;                           <<04584>>57315000
   define sysglobextpt=absolute(sysdb+sysglobextptoffset)#;    <<04584>>57320000
   entry updatesysfpmap;                                       <<04584>>57325000
                                                               <<04584>>57330000
   getprivmode;                                                <<04584>>57335000
   sysfpmap := absolute(sysdb+sysglobextpt+sysfpmapoffset);    <<04584>>57340000
   sysfpmap :=sysfpmap.(14:2);                                 <<04584>>57345000
   getusermode;                                                <<04584>>57350000
   return;                                                     <<04584>>57355000
updatesysfpmap:                                                <<04584>>57360000
   getprivmode;                                                <<04584>>57365000
   absolute(sysdb+sysglobextpt+sysfpmapoffset) := sysfpmap;    <<04584>>57370000
   getusermode;                                                <<04584>>57375000
end;                                                           <<04584>>57380000
$page "MISC. PROCEDURE - GETJSFPMAP"                                    57385000
procedure getjsfpmap(jsfpmap);                                 <<04584>>57390000
integer jsfpmap;                                               <<04584>>57395000
                                                               <<04584>>57400000
begin                                                          <<04584>>57405000
                                                               <<04584>>57410000
   equate jsfpmapoffset = 6;                                   <<04584>>57415000
   integer jitdst;                                             <<04584>>57420000
   integer pointer pxglob;                                     <<04584>>57425000
   logical updateflag;                                         <<04584>>57430000
   entry updatejsfpmap;                                        <<04584>>57435000
                                                               <<04584>>57440000
   updateflag:=false;                                          <<04584>>57445000
   go to start;                                                <<04584>>57450000
updatejsfpmap:                                                 <<04584>>57455000
   updateflag:=true;                                           <<04584>>57460000
start:                                                         <<04584>>57465000
   getprivmode;                                                <<04584>>57470000
   push (dl);                                                  <<04584>>57475000
   @pxglob := tos - ps0(-1);                                   <<04584>>57480000
   jitdst := pxglob(11);                                       <<06538>>57485000
                                                               <<04584>>57490000
   if updateflag then go to update;                            <<04584>>57495000
                                                               <<04584>>57500000
   tos:=@jsfpmap;                                              <<04584>>57505000
   tos:=jitdst;                                                <<04584>>57510000
   tos:=jsfpmapoffset;                                         <<04584>>57515000
   tos:=1;                                                     <<04584>>57520000
   assemble(mfds 0);                                           <<04584>>57525000
                                                               <<04584>>57530000
   if jsfpmap.(14:1) = 0 then <<jsfpmap isn't init'ed>>        <<04584>>57535000
      begin                                                    <<04584>>57540000
         getusermode;                                          <<04584>>57545000
         getsysfpmap(sysfpmap); getprivmode;                   <<04584>>57550000
         jsfpmap.(15:1) := sysfpmap.(15:1);                    <<04584>>57555000
         jsfpmap.(14:1) := 1;                                  <<04584>>57560000
update:                                                        <<04584>>57565000
         tos:=jitdst;                                          <<04584>>57570000
         tos:=jsfpmapoffset;                                   <<04584>>57575000
         tos:=@jsfpmap;                                        <<04584>>57580000
         tos:=1;                                               <<04584>>57585000
         assemble(mtds 0);                                     <<04584>>57590000
      end;                                                     <<04584>>57595000
   getusermode;                                                <<04584>>57600000
end;                                                           <<04584>>57605000
$page "MISC. PROCEDURE - SHOWALL"                                       57610000
procedure showall;                                             <<04584>>57615000
                                                               <<04584>>57620000
begin                                                          <<04584>>57625000
                                                               <<04584>>57630000
subroutine printname(fnum);                                    <<04584>>57635000
value fnum;                                                    <<04584>>57640000
integer fnum;                                                  <<04584>>57645000
                                                               <<04584>>57650000
begin                                                          <<04584>>57655000
                                                               <<04584>>57660000
   if fnum <> 0 then                                           <<04584>>57665000
      begin                                                    <<04584>>57670000
         tos := fnum;                                          <<04584>>57675000
         tos := @bline(18);                                    <<04584>>57680000
         fgetinfo(*,*);                                        <<04584>>57685000
      end                                                      <<04584>>57690000
   else                                                        <<04584>>57695000
      move bline(18) := "NONE";                                <<04584>>57700000
   printline;                                                  <<04584>>57705000
end;                                                           <<04584>>57710000
                                                               <<04584>>57715000
   blankline;                                                  <<04584>>57720000
   move bline := "USL FILE       :";                           <<04584>>57725000
   printname (uslfnum);                                        <<04584>>57730000
   move bline := "AUX USL FILE   :";                           <<04584>>57735000
   printname (xuslfnum);                                       <<04584>>57740000
   move bline := "SL FILE        :";                           <<04584>>57745000
   printname (splfnum);                                        <<04584>>57750000
   move bline := "RL FILE        :";                           <<04584>>57755000
   printname (rlfnum);                                         <<04584>>57760000
                                                               <<04584>>57765000
   << get fpmap flages >>                                      <<04584>>57770000
                                                               <<04584>>57775000
   getsysfpmap(sysfpmap);                                      <<04584>>57780000
                                                               <<04584>>57785000
   getjsfpmap(jsfpmap);                                        <<04584>>57790000
                                                               <<04584>>57795000
   move bline:="SYSTEM FPMAP   :";                             <<04584>>57800000
   if sysfpmap = 0 then                                        <<04584>>57805000
      move bline(18) := "OFF"                                  <<04584>>57810000
   else                                                        <<04584>>57815000
      if sysfpmap = 1 then                                     <<04584>>57820000
         move bline(18) := "ON  (CONDITION)"                   <<04584>>57825000
      else                                                     <<04584>>57830000
         move bline(18) := "ON  (UNCONDITION)";                <<04584>>57835000
   printline;                                                  <<04584>>57840000
   move bline:="SESSION FPMAP  :";                             <<04584>>57845000
   if jsfpmap.(15:1)=1 then                                    <<04584>>57850000
      move bline(18) := "ON"                                   <<04584>>57855000
   else move bline(18) := "OFF";                               <<04584>>57860000
   printline;                                                  <<04584>>57865000
   blankline;                                                  <<04584>>57870000
end;                                                           <<04584>>57875000
$page "MISC. PROCEDURE - SETFPMAPFLAG"                                  57880000
procedure setfpmapflag;                                        <<04584>>57885000
                                                               <<04584>>57890000
begin                                                          <<04584>>57895000
   if setsystem then                                           <<04584>>57900000
      begin                                                    <<04584>>57905000
      if not usercap1.(0:1) then << no sm cap >>               <<04584>>57910000
         error(msg'reqsmcap)                                   <<04584>>57915000
      else                                                     <<04584>>57920000
         if setoff then                                        <<04584>>57925000
            sysfpmap:=0                                        <<04584>>57930000
         else                                                  <<04584>>57935000
            if setuncond then                                  <<04584>>57940000
               sysfpmap:=2                                     <<04584>>57945000
            else                                               <<04584>>57950000
               sysfpmap:=1;                                    <<04584>>57955000
      updatesysfpmap(sysfpmap);                                <<04584>>57960000
      end                                                      <<04584>>57965000
   else                                                        <<04584>>57970000
      begin                                                    <<04584>>57975000
      if setoff then                                           <<04584>>57980000
         jsfpmap:=%(2)10  <<bit 14:1 indicates >>              <<04584>>57985000
      else                      <<jsfpmap is init'ed >>        <<04584>>57990000
         jsfpmap:=%(2)11;                                      <<04584>>57995000
      updatejsfpmap(jsfpmap);                                  <<04584>>58000000
      end;                                                     <<04584>>58005000
end;                                                           <<04584>>58010000
$page "MISC PROCEDURE - GENPMAPLIST"                                    58015000
procedure genpmaplist;                                         <<04584>>58020000
                                                               <<04584>>58025000
<< this procedure lists the program pmap as user's request >>  <<04584>>58030000
<< 1. list a procedure if procedure name specified         >>  <<04584>>58035000
<< 2. list a segment if seg name specified                 >>  <<04584>>58040000
<< 3. list all segment if none of above is specified       >>  <<04584>>58045000
                                                               <<04584>>58050000
begin                                                          <<04584>>58055000
   integer array inmapbuf(0:14);                               <<04584>>58060000
   integer array pmapcb (0:640);                               <<04584>>58065000
   integer pointer inmapp=inmapbuf;                            <<04584>>58070000
   byte array inmapbp(*)=inmapbuf;                             <<04584>>58075000
   integer pointer inmapp1;                                    <<04584>>58080000
   double pointer inmapdp1=inmapp1;                            <<04584>>58085000
   byte array heading(*)=pb:=                                  <<04584>>58090000
   "  NAME            TYPE     CODE    ENTRY   LENGTH";        <<04584>>58095000
   logical headprinted;                                        <<04584>>58100000
   integer scancode;                                           <<04584>>58105000
   integer status;                                             <<04584>>58110000
   equate scanall=0,                                           <<04584>>58115000
          scancurseg=1;                                        <<04584>>58120000
   byte array nameblock(0:15);                                 <<04584>>58125000
   define                                                      <<04584>>58130000
   inmapfnum      = pmapcb(1)#,   << # of prog/sl file >>      <<04584>>58135000
   inmapfilecode  = pmapcb(2)#;   << prog file code >>         <<04584>>58140000
<<-------------------------------------------------------------<<04584>>58145000
<<                                                             <<04584>>58150000
<< internal pmap records.                                      <<04584>>58155000
<<                                                             <<04584>>58160000
<<-------------------------------------------------------------<<04584>>58165000
<<                                                             <<04584>>58170000
<< pointers referenced:                                        <<04584>>58175000
<<                                                             <<04584>>58180000
<<    inmapp   - integer pointer to 1st word of an internal    <<04584>>58185000
<<               record.                                       <<04584>>58190000
<<    inmapbp  - byte pointer to 1st byte of an internal pmap  <<04584>>58195000
<<               record.                                       <<04584>>58200000
<<    inmapp1  - integer pointer to 1st word after name in an  <<04584>>58205000
<<               internal pmap record.                         <<04584>>58210000
<<    inmapdp1 - double pointer to 1st word after name in an   <<04584>>58215000
<<               internal pmap record.                         <<04584>>58220000
<<                                                             <<04584>>58225000
<<-------------------------------------------------------------<<04584>>58230000
                                                               <<04584>>58235000
<< field definitions common to all record types: >>            <<04584>>58240000
                                                               <<04584>>58245000
define                                                         <<04584>>58250000
   inmap'type      = inmapp.(0:4)#;                            <<04584>>58255000
define                                                         <<04584>>58260000
   inmap'namenumch = inmapp.(4:4)#, << # chars in ent name >>  <<04584>>58265000
   inmap'name      = inmapbp#,                                 <<04584>>58270000
                                                               <<04584>>58275000
<< segment record field definitions: >>                        <<04584>>58280000
                                                               <<04584>>58285000
   inmap'sttlen    = inmapp1.(0:8)#,                           <<04584>>58290000
   inmap'segnum    = inmapp1.(8:8)#,                           <<04584>>58295000
   inmap'seglen    = inmapp1(1)#, << segment length, including <<04584>>58300000
                                  <<   the stt.                <<04584>>58305000
                                                               <<04584>>58310000
<< procedure record field definitions: >>                      <<04584>>58315000
                                                               <<04584>>58320000
   inmap'flags     = inmapp1#,                                 <<04584>>58325000
      inmap'hidden = inmapp1.(0:1)#,                           <<04584>>58330000
                                                               <<04584>>58335000
   inmap'procstart = inmapp1(1)#,                              <<04584>>58340000
   inmap'proclen   = inmapp1(2)#,                              <<04584>>58345000
   inmap'procentry = inmapp1(3)#,                              <<04584>>58350000
   inmap'tboxlink  = inmapdp1(2)#,                             <<04584>>58355000
   inmap'tboxid    = inmapp1(6)#,                              <<04584>>58360000
                                                               <<04584>>58365000
<< secondary entry point record definitions: >>                <<04584>>58370000
                                                               <<04584>>58375000
   inmap'secentry  = inmapp1(1)#,                              <<04584>>58380000
   inmap'secentnum = inmapp1(2)#;                              <<04584>>58385000
                                                               <<04584>>58390000
subroutine printprogram;                                       <<04584>>58395000
                                                               <<04584>>58400000
begin                                                          <<04584>>58405000
                                                               <<04584>>58410000
   << print program name >>                                    <<04584>>58415000
                                                               <<04584>>58420000
   blankline;                                                  <<04584>>58425000
   tos := inmapfnum;                                           <<04584>>58430000
   move bline := "PROGRAM FILE ",2;                            <<04584>>58435000
   fgetinfo(*,*);                                              <<04584>>58440000
   printline;                                                  <<04584>>58445000
   blankline;                                                  <<04584>>58450000
   headprinted := false;                                       <<04584>>58455000
end;                                                           <<04584>>58460000
                                                               <<04584>>58465000
subroutine printsegment;                                       <<04584>>58470000
                                                               <<04584>>58475000
begin                                                          <<04584>>58480000
                                                               <<04584>>58485000
   << print segment name >>                                    <<04584>>58490000
                                                               <<04584>>58495000
   blankline;                                                  <<04584>>58500000
   move bline := inmap'name(1),(inmap'namenumch);              <<04584>>58505000
   ntoa(inmap'segnum,8,bline(18));                             <<04584>>58510000
   ntoa(inmap'seglen,8,bline(26));                             <<04584>>58515000
   printline;                                                  <<04584>>58520000
   headprinted := false;                                       <<04584>>58525000
end;                                                           <<04584>>58530000
                                                               <<04584>>58535000
subroutine printheading;                                       <<04584>>58540000
                                                               <<04584>>58545000
begin                                                          <<04584>>58550000
                                                               <<04584>>58555000
   << print column heading >>                                  <<04584>>58560000
                                                               <<04584>>58565000
   blankline;                                                  <<04584>>58570000
   move bline := heading,(49);                                 <<04584>>58575000
   printline;                                                  <<04584>>58580000
   headprinted := true;                                        <<04584>>58585000
end;                                                           <<04584>>58590000
                                                               <<04584>>58595000
subroutine printentry;                                         <<04584>>58600000
                                                               <<04584>>58605000
begin                                                          <<04584>>58610000
                                                               <<04584>>58615000
   << print entries >>                                         <<04584>>58620000
                                                               <<04584>>58625000
   if not headprinted then printheading;                       <<04584>>58630000
   move bline(2) := inmap'name(1),(inmap'namenumch);           <<04584>>58635000
   if inmap'type = pmapproctype then                           <<04584>>58640000
      begin                                                    <<04584>>58645000
         move bline(20) := "P";                                <<04584>>58650000
         ntoa(inmap'procstart,8,bline(30));                    <<04584>>58655000
         ntoa(inmap'procentry,8,bline(39));                    <<04584>>58660000
         ntoa(inmap'proclen,8,bline(48));                      <<04584>>58665000
      end                                                      <<04584>>58670000
   else                                                        <<04584>>58675000
      begin                                                    <<04584>>58680000
         move bline(19) := "SP";                               <<04584>>58685000
         ntoa(inmap'secentry,8,bline(39));                     <<04584>>58690000
      end;                                                     <<04584>>58695000
   printline;                                                  <<04584>>58700000
end;                                                           <<04584>>58705000
                                                               <<04584>>58710000
<< beginning of genpmaplist >>                                 <<04584>>58715000
                                                               <<04584>>58720000
   inmapfnum:=fopen(progname,%(2)11,%(2)100010000);            <<04584>>58725000
   if < then                                                   <<04584>>58730000
      begin                                                    <<04584>>58735000
         tos:=37;                                              <<04584>>58740000
         tos:=0d;                                              <<04584>>58745000
         fcheck(0,s0);                                         <<04584>>58750000
         errorn(*,*);                                          <<04584>>58755000
         return;                                               <<04584>>58760000
      end;                                                     <<04584>>58765000
                                                               <<04584>>58770000
   pmapcbinit(inmapfnum,pmapcb,status);                        <<04584>>58775000
   if status <> 0 then                                         <<04584>>58780000
      go nfg;                                                  <<04584>>58785000
   if inmapfilecode <> progfilecode then                       <<04584>>58790000
      begin                                                    <<04584>>58795000
         status:=11;                                           <<04584>>58800000
         go nfg;                                               <<04584>>58805000
      end;                                                     <<04584>>58810000
                                                               <<04584>>58815000
   printprogram;                                               <<04584>>58820000
   pmapfindsegnum(0,pmapcb,status);                            <<04584>>58825000
   if status <> 0 then go nfg;                                 <<04584>>58830000
   scancode:=scanall;                                          <<04584>>58835000
   if seg'procname <> " " then                                 <<04584>>58840000
      begin                                                    <<04584>>58845000
         buildnameblock(nameblock,16,seg'procname,,status);    <<04584>>58850000
         while getipmaprec(inmapbuf,inmapp1,scancode,          <<04584>>58855000
                           pmapcb,status) do                   <<04584>>58860000
            begin                                              <<04584>>58865000
               if namesmatch(inmap'name,nameblock) then        <<04584>>58870000
                  begin                                        <<04584>>58875000
                     if inmap'type > 0 then                    <<04584>>58880000
                        begin                                  <<04584>>58885000
                           printentry;                         <<04584>>58890000
                           go exit';                           <<04584>>58895000
                        end                                    <<04584>>58900000
                     else                                      <<04584>>58905000
                        begin                                  <<04584>>58910000
                           printsegment;                       <<04584>>58915000
                           scancode :=scancurseg;              <<04584>>58920000
                           while getipmaprec(inmapbuf,inmapp1, <<04584>>58925000
                              scancode,pmapcb,status) do       <<04584>>58930000
                              printentry;                      <<04584>>58935000
                           go exit';                           <<04584>>58940000
                        end;                                   <<04584>>58945000
                  end;                                         <<04584>>58950000
            end;                                               <<04584>>58955000
         status:=1;                                            <<04584>>58960000
         go nfg;                                               <<04584>>58965000
      end                                                      <<04584>>58970000
$page "COMMAND INTERPRETER SUPPORT PROCEDURES - CORRECTCLASS"  <<00207>>58975000
   else                                                        <<04584>>58980000
      begin                                                    <<04584>>58985000
         while getipmaprec(inmapbuf,inmapp1,scancode,          <<04584>>58990000
                           pmapcb,status) do                   <<04584>>58995000
            if inmap'type = pmapsegtype then                   <<04584>>59000000
               printsegment                                    <<04584>>59005000
            else                                               <<04584>>59010000
               printentry;                                     <<04584>>59015000
      end;                                                     <<04584>>59020000
   go to exit';                                                <<04584>>59025000
   nfg:                                                        <<04584>>59030000
   case * status of                                            <<04584>>59035000
      begin                                                    <<04584>>59040000
         tos:=-1;                                              <<04584>>59045000
         tos:=msg'cantlocateitem;                              <<04584>>59050000
         ;;;;;;;;                                              <<04584>>59055000
         tos:=msg'nopmap;                                      <<04584>>59060000
         tos:=msg'badprogfile;                                 <<04584>>59065000
         begin                                                 <<04584>>59070000
            tos:=msg'unexpectedioerr;                          <<04584>>59075000
            tos:=0d;                                           <<04584>>59080000
            fcheck(inmapfnum,s0);                              <<04584>>59085000
            errorn(*,*);                                       <<04584>>59090000
            go exit';                                          <<04584>>59095000
         end;                                                  <<04584>>59100000
      end;                                                     <<04584>>59105000
   if s0 <> -1 then error(*);                                  <<04584>>59110000
exit':                                                         <<04584>>59115000
   if inmapfnum <> 0 then fclose(inmapfnum,0,0);               <<04584>>59120000
end;                                                           <<04584>>59125000
$page "COMMAND INTERPRETER SUPPORT PROCEDURE - CORRECTCLASS"   <<04584>>59130000
<<----------------------------------------------------------------------59135000
*                                                                      *59140000
*  command interpreter support procedures                              *59145000
*                                                                      *59150000
---------------------------------------------------------------------->>59155000
                                                                        59160000
$ control segment = seg1                                                59165000
logical procedure correctclass;                                         59170000
   <<checks the current entry to see if it is of the specified          59175000
     class>>                                                            59180000
   begin                                                                59185000
   integer result = correctclass;                                       59190000
   xreg _ enttype;                                                      59195000
   assemble(ldxa,adax);                                                 59200000
   if class = (%(2)0101100110010011&csr(xreg)).(14:2) or                59205000
      class = (%(2)1010101010100011&csr(xreg)).(14:2) or       <<04123>>59210000
      enttype = 8 and class = 2  then                          <<04123>>59215000
      result _ result+1                                                 59220000
   end;                                                                 59225000
$page  "COMMAND INTERPRETER SUPPORT PROCEDURES - DETERMINE'FPMAP"       59230000
$control segment=seg1                                                   59235000
procedure determine'fpmap;                                     <<04102>>59240000
                                                               <<04102>>59245000
<< this procedure looks into sysfpmap and jsfpmap     >>       <<04102>>59250000
<< and parameters specified to determine fpmap option >>       <<04102>>59255000
<<                                                    >>       <<04102>>59260000
<<   sysfpmap  : the %102 word of sysglob extension   >>       <<04102>>59265000
<<   jsfpmap   : the 6th word of jit                 >>        <<04584>>59270000
<<                                                    >>       <<04102>>59275000
<<   parameters                                       >>       <<04102>>59280000
<<      fpmap   : num3.(8:1)                          >>       <<04102>>59285000
<<      nofpmap : num3.(7:1)                          >>       <<04102>>59290000
                                                               <<04102>>59295000
begin                                                          <<04102>>59300000
   getsysfpmap(sysfpmap);                                      <<04584>>59305000
   getjsfpmap(jsfpmap);                                        <<04584>>59310000
   if sysfpmap = 2 then    <<sysfpmap=2:forced fpmap systemwide<<04102>>59315000
      fpmap:=1             <<ignor jsfpmap and parameters      <<04102>>59320000
   else                    <<sysfpmap=1 or 0:system fpmap can  <<04102>>59325000
      if jsfpmap.(15:1)=1 then <<be override by jsfpmap        <<04584>>59330000
        if not nofpmap then<<jsfpmap can be override by fpmap  <<04102>>59335000
            fpmap:=1;      <<or nofpmap parameter              <<04102>>59340000
end;                                                           <<04102>>59345000
$page "COMMAND INTERPRETER SUPPORT PROCEDURES - DETERMINE'CKSUM"        59350000
$control segment=seg1                                                   59355000
procedure determine'cksum;                                     <<04257>>59360000
                                                               <<04257>>59365000
<< this procedure ckeck the existence of patch area >>         <<04257>>59370000
<< if checksum specified. if patch is not specified >>         <<04257>>59375000
<< then set patch to zero. note that checksum is    >>         <<04257>>59380000
<< store in a field of patch area.                  >>         <<04257>>59385000
                                                               <<04257>>59390000
begin                                                          <<04257>>59395000
   if checksumspecified then                                   <<04257>>59400000
      if initpatch = -1 then                                   <<04257>>59405000
         initpatch := 0;                                       <<04257>>59410000
end;                                                           <<04257>>59415000
$page "COMMAND INTERPRETER "                                   <<00207>>59420000
$ control segment = seg1                                                59425000
<<----------------------------------------------------------------------59430000
*                                                                      *59435000
*  command interpreter                                                 *59440000
*                                                                      *59445000
---------------------------------------------------------------------->>59450000
                                                                        59455000
<<* * * initialize global parameters * * *>>                            59460000
                                                                        59465000
turnofftraps;                                                           59470000
push(dl);                                                               59475000
@dlarea2 _ s0;  <<init. dl area 2 limit>>                               59480000
@dlavail _ tos;  <<init. dl available area limit>>                      59485000
who(usermode,usercap);  <<get user's parm's>>                           59490000
<<* * * open $stdinx file * * *>>                              <<00.dm>>59495000
                                                               <<00.dm>>59500000
if usermode.(12:2) = 1 then  << it's a session >>              <<00.dm>>59505000
   begin                                                       <<00.dm>>59510000
   infnum := fopen( ,%2054, 0, -80);                           <<00.dm>>59515000
   if <> then quit(0);                                         <<00.dm>>59520000
   end                                                         <<00.dm>>59525000
else                                                           <<00.dm>>59530000
   infnum := 0;                                                <<00.dm>>59535000
                                                               <<00.dm>>59540000
<<* * * set up control y trap * * *>>                          <<00.dm>>59545000
                                                               <<00.dm>>59550000
xcontrap(@ctly'trap,i);                                        <<00.dm>>59555000
fcontrol(infnum,disable'ctly,i);                               <<00.dm>>59560000
                                                               <<00.dm>>59565000
getprivmode;  <<get into priv. mode>>                                   59570000
if thiscpu <> 0 then                                           <<00.dm>>59575000
   begin      <<series ii>>                                    <<00.dm>>59580000
   tos := setsysdb;                                            <<00.dm>>59585000
   tos := sdbdefaultstk2;                                      <<00.dm>>59590000
   tos := sdbmaxcode2;                                         <<00.dm>>59595000
   if pcbsize = pcbsizempe4 then                               <<06538>>59600000
      tos:=absolute(absolute(cpcb)+5)&lsr(8) * pcbsize         <<06538>>59605000
   else                                                        <<06538>>59610000
      tos := pcb(absolute(cpcb)+5);                            <<06538>>59615000
   end                                                         <<00.dm>>59620000
 else                                                          <<00.dm>>59625000
   begin      <<series i>>                                     <<00.dm>>59630000
   tos := setsysdb;                                            <<00.dm>>59635000
   tos := sdbdefaultstk1;                                      <<00.dm>>59640000
   tos := sdbmaxcode1;                                         <<00.dm>>59645000
   tos := absolute(absolute(cpcb)+5)&lsr(8) * pcbsize1;        <<06538>>59650000
   end;                                                        <<00.dm>>59655000
resetdb(s3);                                                   <<00.dm>>59660000
config := tos;      <<pcb size>>                               <<00.dm>>59665000
config(1) := tos;   <<max. code segment size>>                 <<00.dm>>59670000
config(2) := tos;   <<min. stack size>>                        <<00.dm>>59675000
del;                                                           <<00.dm>>59680000
                                                                        59685000
ob:                                                                     59690000
awake(fatherpinx,2,1);                                         <<06538>>59695000
                                                                        59700000
<<* * * receive command from father * * *>>                             59705000
                                                                        59710000
receivemail(0,combuf,false);  <<get command thru mail>>                 59715000
if <> then quit(4);  <<error?>>                                         59720000
getusermode;  <<back into user mode>>                                   59725000
move auxcombuf _ combuf,(auxmaillength);                                59730000
                                                                        59735000
<<* * * open list file * * *>>                                          59740000
                                                                        59745000
if list and listfnum = 0 then  <<open list file?>>                      59750000
   begin                                                                59755000
   tos _ 0;  <<for result of fopen>>                                    59760000
   tos _ @listdesig;  <<list designator>>                               59765000
   tos := %(2)00100001100;                                              59770000
   tos.(5:1) _ inhibitfileeq;  <<inhibit file equation?>>               59775000
   listfnum := fopen(*,*,%(2)011000001);                                59780000
   if < then  <<error?>>                                                59785000
      begin                                                             59790000
      tos _ 83;                                                         59795000
      tos _ 0d; fcheck(0,s0);                                           59800000
      errorn(*,*);                                                      59805000
      go ob1                                                            59810000
      end;                                                              59815000
   fgetinfo(listfnum,,,,listwidth)  <<get line width>>                  59820000
   end;                                                                 59825000
                                                                        59830000
<<* * * process command * * *>>                                         59835000
                                                                        59840000
tos _ command;  <<load command nr.>>                                    59845000
errornr _ noerror;  <<init. error flag>>                                59850000
go comswitch(tos);                                                      59855000
                                                                        59860000
<<addrl>>                                                               59865000
                                                                        59870000
addrl:                                                                  59875000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      59880000
if rlfnum = 0 then go err7;  <<rl file opened?>>                        59885000
if not searchusl(name,index,uslnonseg) then go err2;                    59890000
insertrl;                                                               59895000
go ob1;                                                                 59900000
                                                                        59905000
<<addsl>>                                                               59910000
                                                                        59915000
addsl:                                                                  59920000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      59925000
if splfnum = 0 then go err6;  <<sl file opened?>>                       59930000
if not searchusl(segname,0,uslseg) then go err2;                        59935000
symdbug := not nosym;                                          <<04102>>59940000
determine'fpmap;                                               <<04102>>59945000
determine'cksum;                                               <<04257>>59950000
insertsl;                                                               59955000
go ob1;                                                                 59960000
                                                                        59965000
<<auxusl>>                                                              59970000
                                                                        59975000
auxusl:                                                                 59980000
changestate;  <<back to aux. usl>>                                      59985000
openusl(false);  <<open aux. usl>>                                      59990000
changestate;  <<back to orig. usl>>                                     59995000
go ob1;                                                                 60000000
                                                                        60005000
<<buildrl>>                                                             60010000
                                                                        60015000
buildrl:                                                                60020000
openrl(true);                                                           60025000
go ob1;                                                                 60030000
                                                                        60035000
<<buildsl>>                                                             60040000
                                                                        60045000
buildsl:                                                                60050000
opensl(true);                                                           60055000
go ob1;                                                                 60060000
                                                                        60065000
<<buildusl>>                                                            60070000
                                                                        60075000
buildusl:                                                               60080000
openusl(true);                                                          60085000
go ob1;                                                                 60090000
                                                                        60095000
<<cease>>                                                               60100000
                                                                        60105000
cease:                                                                  60110000
flag _ true;  <<set flag for deactivation>>                             60115000
if uslfnum = 0 then go err4;                                   <<03026>>60120000
if not searchusl (name,index,class) then go err2;              <<03026>>60125000
go use1;                                                                60130000
                                                               <<00207>>60135000
<<cleansl>>                                                    <<00207>>60140000
cleansl:                                                       <<00207>>60145000
slclean(0d);                                                   <<00207>>60150000
                                                               <<00207>>60155000
go to ob1;                                                     <<00207>>60160000
                                                               <<00207>>60165000
<<cleanusl>>                                                   <<00207>>60170000
cleanusl':                                                     <<00207>>60175000
uslclean;                                                      <<00207>>60180000
go to ob1;                                                     <<00207>>60185000
                                                                        60190000
<<copy>>                                                                60195000
                                                                        60200000
copy:                                                                   60205000
if class = entryclass then go err89;                                    60210000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      60215000
if xuslfnum = 0 then go err3;  <<aux. usl file opened?>>                60220000
changestate;                                                            60225000
if not searchusl(name,index,class) then                                 60230000
   begin                                                                60235000
   changestate;  <<get origional usl>>                                  60240000
   go err2                                                              60245000
   end;                                                                 60250000
if not correctclass then                                                60255000
   begin                                                                60260000
   changestate;  <<get origional usl>>                                  60265000
   go err86;                                                            60270000
   end;                                                                 60275000
copyfamily;                                                             60280000
go ob1;                                                                 60285000
                                                               <<00207>>60290000
<<copysl>>                                                     <<00207>>60295000
                                                               <<00207>>60300000
copysl:                                                        <<00207>>60305000
tos := double(num1)+100d;                                      <<00465>>60310000
if ds1 < 100d or ds1 > 10000d then                             <<00465>>60315000
   begin                                                       <<00465>>60320000
   ddel;                                                       <<00465>>60325000
   error(95);                                                  <<00465>>60330000
   go ob1;                                                     <<00465>>60335000
   end;                                                        <<00465>>60340000
slclean(*);                                                    <<00465>>60345000
go ob1;                                                        <<00465>>60350000
                                                               <<00207>>60355000
<<copyusl>>                                                    <<00207>>60360000
                                                               <<00207>>60365000
copyusl:                                                       <<00207>>60370000
   uslcopy;                                                    <<00207>>60375000
   go to ob1;                                                  <<00207>>60380000
                                                                        60385000
<<exit>>                                                                60390000
                                                                        60395000
exit':                                                                  60400000
closeusl;  <<close usl file>>                                           60405000
changestate;  <<back to aux. usl file>>                                 60410000
closeusl;  <<close aux. usl file>>                                      60415000
changestate;  <<back to orig. usl>>                                     60420000
closesl;  <<close sl file>>                                             60425000
closerl;  <<close rl file>>                                             60430000
terminate;                                                              60435000
                                                                        60440000
<<hide>>                                                                60445000
                                                                        60450000
hide:                                                                   60455000
flag _ true;  <<set flag for hide>>                                     60460000
hide1:                                                                  60465000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      60470000
if not searchusl(name,index,uslnonseg) then go err2;                    60475000
if not bitmap10&csr(enttype) then go err88;                             60480000
entp(2).(3:1) _ flag;  <<adj. hidden bit>>                              60485000
usldirmod _ true;  <<set modified flag>>                                60490000
go ob1;                                                                 60495000
                                                                        60500000
<<listaux>>                                                    <<03027>>60505000
                                                               <<03027>>60510000
listaux:                                                       <<03027>>60515000
if xuslfnum = 0 then go err3;                                  <<03027>>60520000
changestate;                                                   <<03027>>60525000
listusl';                                                      <<03027>>60530000
changestate;                                                   <<03027>>60535000
go ob1;                                                        <<03027>>60540000
                                                               <<03027>>60545000
<<listpmap>>                                                   <<04584>>60550000
                                                               <<04584>>60555000
listpmap:                                                      <<04584>>60560000
genpmaplist;                                                   <<04584>>60565000
go ob1;                                                        <<04584>>60570000
                                                               <<04584>>60575000
<<listrl>>                                                              60580000
                                                                        60585000
listrl:                                                                 60590000
if rlfnum = 0 then go err7;  <<rl file opened?>>                        60595000
listrl';                                                                60600000
go ob1;                                                                 60605000
                                                                        60610000
<<listsl>>                                                              60615000
                                                                        60620000
listsl:                                                                 60625000
if splfnum = 0 then go err6;  <<sl file opened?>>                       60630000
listsl';                                                                60635000
go ob1;                                                                 60640000
                                                                        60645000
<<listusl>>                                                             60650000
                                                                        60655000
listusl:                                                                60660000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      60665000
listusl';                                                               60670000
go ob1;                                                                 60675000
                                                                        60680000
<<newseg>>                                                              60685000
                                                                        60690000
newseg:                                                                 60695000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      60700000
if not searchusl(name,index,uslnonseg) then go err2;                    60705000
if map12(enttype) <> 1 then go err88;                                   60710000
i _ entfileadr;  <<save entry address>>                                 60715000
unlinkfamily(i);  <<unlink family of entries>>                          60720000
if not searchusl(segname,0,uslseg) then  <<create segment entry?>>      60725000
   begin                                                                60730000
   createsegentry(segname);  <<create segment entry>>                   60735000
   if < then go ob1  <<error?>>                                         60740000
   end;                                                                 60745000
tos _ esl;  <<save son link>>                                           60750000
esl _ i;  <<insert new son link>>                                       60755000
usldirmod _ true;                                                       60760000
getentry(i);                                                            60765000
ebl _ tos;  <<insert saved son link>>                                   60770000
usldirmod _ true;                                                       60775000
go ob1;                                                                 60780000
                                                                        60785000
<<prepare>>                                                             60790000
                                                                        60795000
prepare:                                                                60800000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      60805000
symdbug := not nosym;                                          <<04102>>60810000
determine'fpmap;                                               <<04102>>60815000
determine'cksum;                                               <<04257>>60820000
prepareprogram;  <<prepare program file>>                               60825000
go ob1;                                                                 60830000
                                                                        60835000
<<purgerbm>>                                                            60840000
                                                                        60845000
purgerbm:                                                               60850000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      60855000
if class = entryclass then go err88;                                    60860000
if not searchusl(name,index,class) then go err2;                        60865000
if not correctclass then go err86;                                      60870000
removefamily(entfileadr);  <<remove family of entries>>                 60875000
go ob1;                                                                 60880000
                                                                        60885000
<<purgerl>>                                                             60890000
                                                                        60895000
purgerl:                                                                60900000
if rlfnum = 0 then go err7;  <<rl file opened?>>                        60905000
if class = segclass then go err89;                                      60910000
if not searchrl(name) then go err2;                                     60915000
removerl;                                                               60920000
go ob1;                                                                 60925000
                                                                        60930000
<<purgesl>>                                                             60935000
                                                                        60940000
purgesl:                                                                60945000
if splfnum = 0 then go err6;  <<sl file opened?>>                       60950000
if class = unitclass then go err89;                                     60955000
removesl;                                                               60960000
go ob1;                                                                 60965000
                                                                        60970000
<<reveal>>                                                              60975000
                                                                        60980000
reveal:                                                                 60985000
flag _ false;  <<set flag for reveal>>                                  60990000
go hide1;                                                               60995000
                                                                        61000000
<<rl>>                                                                  61005000
                                                                        61010000
rl:                                                                     61015000
openrl(false);                                                          61020000
go ob1;                                                                 61025000
                                                               <<04584>>61030000
<<setfpmap>>                                                   <<04584>>61035000
                                                               <<04584>>61040000
setfpmap:                                                      <<04584>>61045000
setfpmapflag;                                                  <<04584>>61050000
go ob1;                                                        <<04584>>61055000
                                                                        61060000
<<show>>                                                       <<04584>>61065000
                                                               <<04584>>61070000
show:                                                          <<04584>>61075000
showall;                                                       <<04584>>61080000
go ob1;                                                        <<04584>>61085000
                                                               <<04584>>61090000
<<sl>>                                                                  61095000
                                                                        61100000
sl:                                                                     61105000
opensl(false);                                                          61110000
go ob1;                                                                 61115000
                                                                        61120000
<<use>>                                                                 61125000
                                                                        61130000
use:                                                                    61135000
flag _ false;  <<set flag for activation>>                              61140000
if uslfnum = 0 then go err4;  <<usl file opened?>>                      61145000
if not searchusl(name,index,class,1) then go err2;             <<03026>>61150000
use1:                                                          <<03026>>61155000
if not correctclass then go err86;                                      61160000
setactivity(flag);  <<adjust activity bits>>                            61165000
go ob1;                                                                 61170000
                                                                        61175000
<<usl>>                                                                 61180000
                                                                        61185000
usl:                                                                    61190000
openusl(false);                                                         61195000
go ob1;                                                                 61200000
                                                                        61205000
<<debug>>                                                               61210000
                                                                        61215000
debug':                                                                 61220000
if not usercap2.(9:1) then go err44;                           <<01107>>61225000
debug;                                                                  61230000
                                                                        61235000
<<* * * send result to father * * *>>                                   61240000
                                                                        61245000
ob1:                                                                    61250000
getprivmode;  <<get into priv. mode>>                                   61255000
sendmail(0,1,auxcombuf,false);  <<return answer>>                       61260000
if <> then quit(5);  <<error?>>                                         61265000
go ob;                                                                  61270000
                                                                        61275000
<<error messages>>                                                      61280000
                                                                        61285000
err86: error(86); go ob1;<<item diff class>>                            61290000
err87: error(87); go ob1;<<item not prim entry>>                        61295000
err88: error(88); go ob1;<<incomp. item type>>                          61300000
err89: error(89); go ob1;<<invalid class spec>>                         61305000
err2: error(93); go ob1;  <<unable to locate item>>                     61310000
err3: error(120); go ob1;  <<aux. usl file not designated>>             61315000
err4: error(5); go ob1;  <<usl file not designated>>                    61320000
err6: error(16); go ob1;  <<sl file not designated>>                    61325000
err7: error(21); go ob1;  <<rl file not designated>>                    61330000
err44: error(44); go ob1; <<no capability>>                    <<01107>>61335000
end. << segproc >>                                             <<02817>>61340000
