$control uslinit, code, map                                             00010000
                                                                        00015000
<<------------------------------------------------------------->>       00020000
<<                                                             >>       00025000
<<                  mpe segmenter intrinsics                   >>       00030000
<<                    segutil  (module 71)                     >>       00035000
<<                                                             >>       00040000
<<                      version  a.01.07                       >>       00045000
<<                     january 30, 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 UTILITIES - JANUARY 30, 1982"              00115000
$control main = segutil'3000                                            00120000
$control segment = segutil                                              00125000
                                                                        00130000
begin                                                                   00135000
$page                                                                   00140000
<<------------------------------------------------------------->>       00145000
<<                                                             >>       00150000
<< access to last stack marker.                                >>       00155000
<<                                                             >>       00160000
<<------------------------------------------------------------->>       00165000
                                                                        00170000
logical parmflags = q - 4;        << option variable bit map >>         00175000
integer statusreg = q - 1;        << status register returned >>        00180000
                                                                        00185000
define                                                                  00190000
   condcode = statusreg.(6:2)#,   << condition code returned >>         00195000
      cce   = 2#,                                                       00200000
      ccg   = 0#,                                                       00205000
      ccl   = 1#;                                                       00210000
                                                                        00215000
integer xreg = x;                                                       00220000
integer s0 = s-0;                                                       00225000
integer s1 = s-1;                                                       00230000
integer s2 = s-2;                                                       00235000
integer s5 = s-5;                                                       00240000
integer s6 = s-6;                                                       00245000
integer s7 = s-7;                                                       00250000
integer s11 = s-11;                                                     00255000
integer s12 = s-12;                                                     00260000
integer s13 = s-13;                                                     00265000
logical ls0 = s-0;                                                      00270000
double ds1 = s-1;                                                       00275000
double ds2 = s-2;                                                       00280000
double ds4 = s-4;                                                       00285000
   byte pointer bps0 = s-0;                                             00290000
byte pointer bps13 = s-13;                                              00295000
integer pointer ps0 = s-0;                                              00300000
                                                                        00305000
<<system constants>>                                                    00310000
                                                                        00315000
equate cpcb = 4,                                                        00320000
       pcbsize = 16;                                                    00325000
                                                                        00330000
$PAGE "USL INTRINSIC ERROR NUMBER"                             <<00207>>00335000
                                                                        00340000
equate err0 = 0,  <<unexpected eof>>                                    00345000
       err1 = 1,  <<unexpected i/o error>>                              00350000
       err2 = 2,  <<invalid file code>>                                 00355000
       err3 = 3,  <<illegal file length>>                               00360000
       err4 = 4,  <<attempt to exceed max. directory size (32k)>>       00365000
       err5 = 5,  <<insufficient directory space>>                      00370000
       err6 = 6,  <<insufficient info space>>                           00375000
       err7 = 7,  <<unable to open new usl file>>                       00380000
       err8 = 8,  <<unable to close (purge) old usl file>>              00385000
       err9 = 9,  <<unable to close (purge) new usl file>>              00390000
       err10 = 10,  <<unable to close $newpass>>                        00395000
       err11 = 11,  <<unable to open $oldpass>>                <<00207>>00400000
       illegalusl=12; <<illegal usl format>>                   <<00207>>00405000
                                                                        00410000
$page "USL RECORD 0 PARAMETERS"                                <<00207>>00415000
                                                                        00420000
equate uslfilecode = 1024;  <<usl file code>>                           00425000
define usllid = rec0#,  <<loader id>>                                   00430000
       uslne = rec0(1)#,  <<nr. directory entries>>                     00435000
       usldl = rec0(2)#,  <<directory length>>                          00440000
       usltdg = rec0(3)#,  <<total directory garbage>>                  00445000
       uslndg = rec0(4)#,  <<nr. directory garbage entries>>            00450000
       uslbdl = rec0(5)#,  <<s.a. block data list>>                     00455000
       uslipl = rec0(6)#,  <<s.a. interupt procedure list>>             00460000
       uslsl = rec0(7)#,  <<s.a. segment list>>                         00465000
       uslfl = drec0(4)#,  <<file length>>                              00470000
       uslsaad = rec0(10)#,  <<s.a. directory available block>>         00475000
       usladl = rec0(11)#,  <<directory available block length>>        00480000
       uslsai = drec0(6)#,  <<s.a. info block>>                         00485000
       uslil = drec0(7)#,  <<info block length>>                        00490000
       uslil2 = rec0(15)#,  <<second half>>                             00495000
       uslsaai = drec0(8)#,  <<s.a. info available block>>              00500000
       uslail = drec0(9)#,  <<info available block length>>             00505000
       usltig = drec0(10)#,  <<total info garbage>>                     00510000
       uslnig = rec0(22)#;  <<nr. info garbage entries>>                00515000
$page "PROGRAM FILE PMAP INTRINSICS - ",&                               00520000
$     "PARAMETERS AND DEFINITIONS"                                      00525000
<<------------------------------------------------------------->>       00530000
<<                                                             >>       00535000
<< system-tunable parameters.                                  >>       00540000
<<                                                             >>       00545000
<<------------------------------------------------------------->>       00550000
                                                                        00555000
equate                                                                  00560000
   ipmapbufnumdrecs     = 2,      << internal pmap buffer      >>       00565000
                                  <<   length in disc records. >>       00570000
                                  <<   must be at least 2.     >>       00575000
   nameblocknumwds      = 8;                                            00580000
                                                                        00585000
<<------------------------------------------------------------->>       00590000
<<                                                             >>       00595000
<< system constants.                                           >>       00600000
<<                                                             >>       00605000
<<------------------------------------------------------------->>       00610000
                                                                        00615000
equate                                                                  00620000
   drecnumwds           = 128,    << disc rec length in words >>        00625000
   drecnumdbls          = drecnumwds / 2, << and doublewords >>         00630000
                                                                        00635000
   ipmapbufnumwds       = ipmapbufnumdrecs * drecnumwds;                00640000
                                                                        00645000
<<------------------------------------------------------------->>       00650000
<<                                                             >>       00655000
<< miscellaneous constants.                                    >>       00660000
<<                                                             >>       00665000
<<------------------------------------------------------------->>       00670000
                                                                        00675000
equate                                                                  00680000
   maxint               = 32767,  << maximum integer >>                 00685000
   symnamemax           =    15;  << max # chars in a name >>           00690000
$page                                                                   00695000
<<------------------------------------------------------------->>       00700000
<<                                                             >>       00705000
<< error status codes returned by the pmap intrinsics.         >>       00710000
<<                                                             >>       00715000
<<------------------------------------------------------------->>       00720000
                                                                        00725000
equate                                                                  00730000
   stat'ok                 =   0, << no errors were detected. >>        00735000
   stat'entnamenotfound    =   1, << the entry point name      >>       00740000
                                  <<   couldn't be located.    >>       00745000
   stat'badaddress         =   2, << the address to be located >>       00750000
                                  <<   was outside the bounds  >>       00755000
                                  <<   of the specified seg.   >>       00760000
   stat'badsegid           =   3, << the program/sl file did   >>       00765000
                                  <<   not contain the speci-  >>       00770000
                                  <<   fied segment.           >>       00775000
   stat'segdeleted         =   3, << the requested sl segment  >>       00780000
                                  <<   was marked as deleted.  >>       00785000
   stat'xpmapfilefull      =   4, << the external pmap file    >>       00790000
                                  <<   wasn't large enough.    >>       00795000
   stat'tboxidnotfound     =   5, << the toolbox id couldn't   >>       00800000
                                  <<   be located.             >>       00805000
   stat'missingparms       =   9, << the option variable pa-   >>       00810000
                                  <<   rameter list was ille-  >>       00815000
                                  <<   gal.                    >>       00820000
   stat'nopmap             =  10, << the program/sl file did   >>       00825000
                                  <<   not contain a pmap.     >>       00830000
   stat'badfilecode        =  11, << the program/sl file code  >>       00835000
                                  <<   was not that of a pro-  >>       00840000
                                  <<   gram/sl file.           >>       00845000
   stat'badloaderid        =  11, << the sl loader id was not  >>       00850000
                                  <<   compatible with this    >>       00855000
                                  <<   version of the pmap     >>       00860000
                                  <<   intrinsics.             >>       00865000
   stat'ipmapioerr         =  12, << file system error on the  >>       00870000
                                  <<   program/sl file.        >>       00875000
   stat'xpmapioerr         =  13, << file system error on the  >>       00880000
                                  <<   external pmap file.     >>       00885000
   stat'ipmapbadfopen      =  14, << internal pmap file im- >> <<06555>>00890000
                                  <<   properly fopened.       >>       00895000
   stat'badipmap           =  15; << bad internal pmap      >> <<06555>>00900000
$page                                                                   00905000
<<------------------------------------------------------------->>       00910000
<<                                                             >>       00915000
<< status codes returned by internal pmap support procedures.  >>       00920000
<<                                                             >>       00925000
<<------------------------------------------------------------->>       00930000
                                                                        00935000
equate                                                                  00940000
   stat'endofpmap          = 100; << end of pmap sensed. >>             00945000
                                                                        00950000
<<------------------------------------------------------------->>       00955000
<<                                                             >>       00960000
<< scan codes used by getnextipmaprec.                         >>       00965000
<<                                                             >>       00970000
<<------------------------------------------------------------->>       00975000
                                                                        00980000
equate                                                                  00985000
   scanallsegs     = 0,           << scan all pmap segments >>          00990000
   scancurseg      = 1;           << scan current pmap segment >>       00995000
$page "GENERAL-PURPOSE CODE FILE FIELD DEFINITIONS"                     01000000
<<------------------------------------------------------------->>       01005000
<<                                                             >>       01010000
<< name block field definitions.                               >>       01015000
<<                                                             >>       01020000
<<------------------------------------------------------------->>       01025000
<<                                                             >>       01030000
<< a name block is a variable-length structure used to store   >>       01035000
<< the symbolic name of an entity in a code file, and is usu-  >>       01040000
<< ally found embedded within a larger structure representing  >>       01045000
<< the entity being named.                                     >>       01050000
<<                                                             >>       01055000
<< always interpreted as a byte array on the lowest level,     >>       01060000
<< name blocks are sometimes declared as integer arrays when   >>       01065000
<< they are aligned on word boundaries.  since name blocks     >>       01070000
<< should only be manipulated by special name block utility    >>       01075000
<< routines, this inconsistency should not prove to be incon-  >>       01080000
<< venient.                                                    >>       01085000
<<                                                             >>       01090000
<< the length of a name in a name block is indicated by a      >>       01095000
<< length field stored in the block's first byte.  if the val- >>       01100000
<< ue is non-zero, it represents the length of the name in     >>       01105000
<< bytes.  otherwise, the name must be scanned for the first   >>       01110000
<< blank or null character, which terminates the name.         >>       01115000
<<                                                             >>       01120000
<<------------------------------------------------------------->>       01125000
                                                                        01130000
define                                                                  01135000
   nb'flags     = 0).(8:4#,       << misc. control flags >>             01140000
   nb'numch = 0).(12:4#,          << name length >>                     01145000
   nb'name0     = 1#;             << 1st char of symbolic name >>       01150000
$page                                                                   01155000
<<------------------------------------------------------------->>       01160000
<<                                                             >>       01165000
<< data descriptor field definitions.                          >>       01170000
<<                                                             >>       01175000
<<------------------------------------------------------------->>       01180000
<<                                                             >>       01185000
<< data descriptors are single-word structures which describe  >>       01190000
<< data passed to procedures and data returned as procedure    >>       01195000
<< values.                                                     >>       01200000
<<                                                             >>       01205000
<< The leftmost bit of a data descriptor is called the "user-  >>       01210000
<< defined type bit" (or U bit for short) and determines the   >>       01215000
<< interpretation of the remaining bits.  if the u bit is 1,   >>       01220000
<< the remaining bits represent a user-defined data type de-   >>       01225000
<< clared in a pascal program.  if the u bit is 0, the data    >>       01230000
<< type is not user-defined, and the remaining bits are inter- >>       01235000
<< preted as follows:                                          >>       01240000
<<                                                             >>       01245000
<< mode (bits 1 through 3):                                    >>       01250000
<<   0 - undefined mode.                                       >>       01255000
<<   1 - call by value.                                        >>       01260000
<<   2 - call by reference.                                    >>       01265000
<<   3 - call by name.                                         >>       01270000
<<                                                             >>       01275000
<< structure (bits 4 through 9):                               >>       01280000
<<   0 - simple variable.                                      >>       01285000
<<   1 - pointer variable.                                     >>       01290000
<<   2 - array.                                                >>       01295000
<<   3 - procedure.                                            >>       01300000
<<                                                             >>       01305000
<< type (bits 10 through 15):                                  >>       01310000
<<   0 - undefined type.   6 - long.                           >>       01315000
<<   1 - logical.          7 - complex.                        >>       01320000
<<   2 - integer.          8 - spl label.                      >>       01325000
<<   3 - byte.             9 - fortran character array.        >>       01330000
<<   4 - real.            10 - fortran label.                  >>       01335000
<<   5 - double.          11 - wild card (matches any type).   >>       01340000
<<                                                             >>       01345000
<< a data descriptor of all zeroes is treated as a wild card   >>       01350000
<< and is compatible with (i.e., will match) any other data    >>       01355000
<< descriptor.                                                 >>       01360000
<<                                                             >>       01365000
<<------------------------------------------------------------->>       01370000
                                                                        01375000
define                                                                  01380000
   dd'usertype     = (0:1)#,                                            01385000
   dd'usertypecode = (1:15)#,                                           01390000
                                                                        01395000
   dd'mode         = (1:3)#,                                            01400000
   dd'structure    = (4:6)#,                                            01405000
   dd'type         = (10:6)#;                                           01410000
$page                                                                   01415000
<<------------------------------------------------------------->>       01420000
<<                                                             >>       01425000
<< parameter descriptor array field definitions.               >>       01430000
<<                                                             >>       01435000
<<------------------------------------------------------------->>       01440000
<<                                                             >>       01445000
<< parameter descriptor arrays (pdas) describe formal and      >>       01450000
<< actual calling sequences to procedures.  they are used by   >>       01455000
<< the segmenter and loader to check actual vs. formal calling >>       01460000
<< sequences when rbms are bound to one another at prep and    >>       01465000
<< run time.                                                   >>       01470000
<<                                                             >>       01475000
<< the structure of a complete pda is as follows:              >>       01480000
<<                                                             >>       01485000
<<   0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15            >>       01490000
<< +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+           >>       01495000
<< |level| number of parms |   fortran char count  | 0 1 2 3   >>       01500000
<< +-----------------------------------------------+           >>       01505000
<< |        procedure value data descriptor        |   1 2 3   >>       01510000
<< +-----------------------------------------------+           >>       01515000
<< |      data descriptor for first parameter      |       3   >>       01520000
<< +-----------------------------------------------+           >>       01525000
<< ~                                               ~           >>       01530000
<< +-----------------------------------------------+           >>       01535000
<< |      data descriptor for last parameter       |       3   >>       01540000
<< +-----------------------------------------------+           >>       01545000
<<                                                             >>       01550000
<< pdas are variable in length, depending on the level (of     >>       01555000
<< checking) field in the first word.  the numbers to the      >>       01560000
<< right of each word in the diagram indicate the level of     >>       01565000
<< checking required for the word to be present.               >>       01570000
<<                                                             >>       01575000
<< in the first word, if level = 0 (no checking) then none of  >>       01580000
<< the remaining fields contain meaningful data.  if level > 0 >>       01585000
<< and the procedure value is a fortran character array (as    >>       01590000
<< determined by the second word of the pda), then the number  >>       01595000
<< of characters in the array are stored as shown in the first >>       01600000
<< word.  if level > 1 then the number-of-parameters field in  >>       01605000
<< the first word is valid.                                    >>       01610000
<<                                                             >>       01615000
<<------------------------------------------------------------->>       01620000
                                                                        01625000
define                                                                  01630000
   pda'checklevel = 0).(0:2#,     << level of checking >>               01635000
   pda'numparms   = 0).(2:6#,     << level =    2 or 3 >>               01640000
   pda'numchars   = 0).(8:8#,     << level = 1, 2 or 3 >>               01645000
   pda'procdesc   = 1#,           << level = 1, 2 or 3 >>               01650000
   pda'parmdesc0  = 2#;           << level =         3 >>               01655000
$page "PROGRAM FILE FIELD DEFINITIONS"                                  01660000
<<------------------------------------------------------------->>       01665000
<<                                                             >>       01670000
<< miscellaneous program file constants.                       >>       01675000
<<                                                             >>       01680000
<<------------------------------------------------------------->>       01685000
                                                                        01690000
equate                                                                  01695000
   progfilecode    = 1029,        << file system file code >>           01700000
   pf'maxnumsegs   = 255;         << max # of segments >>               01705000
                                                                        01710000
<<------------------------------------------------------------->>       01715000
<<                                                             >>       01720000
<< program file header (record 0).                             >>       01725000
<<                                                             >>       01730000
<<------------------------------------------------------------->>       01735000
<<                                                             >>       01740000
<< the program file header is found in the first few records   >>       01745000
<< of the program file and contains information which locates  >>       01750000
<< major areas in the remainder of the file, as well as con-   >>       01755000
<< taining miscellaneous data required for loading of the pro- >>       01760000
<< gram.                                                       >>       01765000
<<                                                             >>       01770000
<< in most cases, the program file header will be placed en-   >>       01775000
<< tirely within record 0.  however, the larger number of code >>       01780000
<< segments made possible by the cst expansion project may     >>       01785000
<< cause the header to overflow into records 1 and 2, due to   >>       01790000
<< the cst remapping array and the segment descriptor array,   >>       01795000
<< both of whose lengths are determined by the number of seg-  >>       01800000
<< ments present.  more than 66 segments will cause overflow   >>       01805000
<< into record 1, and more than 151 segments will cause over-  >>       01810000
<< flow into record 2.                                         >>       01815000
<<                                                             >>       01820000
<< each time a program is loaded, the loader places the logon  >>       01825000
<< group and account names from the job or session requesting  >>       01830000
<< the load in the last 16 words of the last record used by    >>       01835000
<< the program file header.                                    >>       01840000
<<                                                             >>       01845000
<<------------------------------------------------------------->>       01850000
<<                                                             >>       01855000
<< pointers referenced:                                        >>       01860000
<<                                                             >>       01865000
<<    pf0p  - integer pointer to 1st word of program file      >>       01870000
<<    pf0lp - logical pointer to 1st word of program file      >>       01875000
<<            header.                                          >>       01880000
<<            header.                                          >>       01885000
<<    pf0bp - byte pointer to 1st byte of program file header. >>       01890000
<<                                                             >>       01895000
<<------------------------------------------------------------->>       01900000
                                                                        01905000
$page                                                                   01910000
equate                                                                  01915000
   pf0'infonumwds     = 28;         << length of info block >>          01920000
define                                                                  01925000
   pf0'flags           = pf0lp#,    << misc flags >>                    01930000
      pf0'fatalerr     = pf0lp.(0:1)#,                                  01935000
                                    << true if fatal error was >>       01940000
                                    <<  detected by the com-   >>       01945000
                                    <<  piler for at least one >>       01950000
                                    <<  procedure in the file. >>       01955000
      pf0'warning      = pf0lp.(1:1)#,                                  01960000
                                    << true if warning was     >>       01965000
                                    <<  was generated by com-  >>       01970000
                                    <<  piler for at least one >>       01975000
                                    <<  procedure in the file. >>       01980000
      pf0'zerodb       = pf0lp.(2:1)#,                                  01985000
                                    << true if initial dl area >>       01990000
                                    <<  should be initialized  >>       01995000
                                    <<  with zeroes by loader  >>       02000000
                                    <<  (zerodb).              >>       02005000
      pf0'privsegs     = pf0lp.(3:1)#,                                  02010000
                                    << true if one or more     >>       02015000
                                    <<  segments in the file   >>       02020000
                                    <<  are privileged.        >>       02025000
      pf0'zeroed       = pf0lp.(4:1)#,                                  02030000
                                    << true means *'d fields   >>       02035000
                                    <<  below are valid; false >>       02040000
                                    <<  means they're not.     >>       02045000
      pf0'caps         = pf0lp.(7:9)#,                                  02050000
                                    << capabilities required   >>       02055000
                                    <<  to execute the program >>       02060000
                                    <<  (cap = caplist).       >>       02065000
   pf0'numsegs         = pf0p(1)#,  << # segments in file >>            02070000
   pf0'dbtoqinumwds    = pf0p(2)#,  << size of global stack >>          02075000
   pf0'dbtoqidrecnum   = pf0p(3)#,  << initial global image >>          02080000
   pf0'firstsegdrecnum = pf0p(4)#,  << first code segment >>            02085000
   pf0'qitozinumwds    = pf0p(5)#,  << initial stack size >>            02090000
                                    <<   (stack   = stacksize) >>       02095000
   pf0'dltodbnumwds    = pf0p(6)#,  << initial dl area size    >>       02100000
                                    <<   (dl   = dlsize).      >>       02105000
   pf0'dltozmaxnumwds  = pf0p(7)#,  << maximum stack size      >>       02110000
                                    <<   (maxdata  = segsize). >>       02115000
   pf0'entlistdrecnum  = pf0p(8)#,  << entry point list >>              02120000
   pf0'startsegnum     = pf0p(9)#,  << starting segment # >>            02125000
   pf0'mainentaddr     = pf0p(10)#, << main entry point addr >>         02130000
   pf0'stltaddr        = pf0p(11)#, << db-rel addr of stlt >>           02135000
   pf0'flutaddr        = pf0p(12)#, << db-rel addr of flut >>           02140000
   pf0'extlistdrecnum  = pf0p(13)#, << external list >>                 02145000
   pf0'mainentsttnum   = pf0p(14)#, << stt # of main entry >>           02150000
   pf0'trapcomaddr     = pf0p(15)#, << ? >>                             02155000
   pf0'pmapdrecnum     = pf0p(16)#, << *pmap area >>                    02160000
   pf0'symdbugdrecnum  = pf0p(17)#, << *toolbox sym debug info >>       02165000
   pf0'cstremap0       = pf0bp(56)#,                                    02170000
                                    << cst remapping array;    >>       02175000
                                    <<   gives last cst # as-  >>       02180000
                                    <<   signed to each logi-  >>       02185000
                                    <<   cal segment.          >>       02190000
   pf0'segdescrip0     = pf0p(28 + (pf0'numsegs + 1) / 2)#,             02195000
                                    << segment descriptor array>>       02200000
      pf0'privseg      = (0:1)#,    << true if privileged seg >>        02205000
      pf0'newstt       = (1:1)#,    << true if segment's stt   >>       02210000
                                    <<   is in new format for  >>       02215000
                                    <<   cst expansion project.>>       02220000
      pf0'segnumwds    = (2:14)#;   << segment length, includ- >>       02225000
                                    <<   ing the stt.          >>       02230000
$page                                                                   02235000
<<------------------------------------------------------------->>       02240000
<<                                                             >>       02245000
<< program file external list entries.                         >>       02250000
<<                                                             >>       02255000
<<------------------------------------------------------------->>       02260000
<<                                                             >>       02265000
<< pointers referenced:                                        >>       02270000
<<                                                             >>       02275000
<<    pfebp - byte pointer to 1st byte of entry.               >>       02280000
<<    pfep1 - integer pointer to 1st word after name in entry. >>       02285000
<<                                                             >>       02290000
<<------------------------------------------------------------->>       02295000
                                                                        02300000
define                                                                  02305000
   pfext'ptrdecs =                                                      02310000
      byte    pointer pfebp;                                            02315000
      integer pointer pfep1#,                                           02320000
   pfext'ptrs = pfebp, pfep1#;                                          02325000
                                                                        02330000
define                                                                  02335000
   pfext'nameblock     = pfebp#,    << name block length byte >>        02340000
   pfext'namenumch     = pfebp.(12:4)#,                                 02345000
   pfext'namech0       = pfebp(1)#,                                     02350000
   pfext'numrefs       = pfep1#,    << # references to external>>       02355000
   pfext'refid0        = pfep1(1)#, << segment reference list >>        02360000
      pfext'refsttnum  = (0:8)#,    << stt entry containing ref>>       02365000
      pfext'refsegnum  = (8:8)#;    << segment containing ref >>        02370000
$page "SL FILE FIELD DEFINITIONS"                                       02375000
<<------------------------------------------------------------->>       02380000
<<                                                             >>       02385000
<< miscellaneous sl file constants.                            >>       02390000
<<                                                             >>       02395000
<<------------------------------------------------------------->>       02400000
                                                                        02405000
equate                                                                  02410000
   slfilecode       = 1031,       << file system file code >>           02415000
   lastslformatid   =    3,       << last valid sl format id >>         02420000
   maxnumslsegs     =  256;       << max # segments in sl files>>       02425000
                                                                        02430000
<<------------------------------------------------------------->>       02435000
<<                                                             >>       02440000
<< sl file record 0.                                           >>       02445000
<<                                                             >>       02450000
<<------------------------------------------------------------->>       02455000
<<                                                             >>       02460000
<< record 0 in all sl files contains general header and space  >>       02465000
<< allocation information for the rest of the file, and is di- >>       02470000
<< vided into two basic pieces.  the first 33 words contain    >>       02475000
<< miscellaneous counters and other information, while the     >>       02480000
<< last 95 words contain the list heads for the entry point    >>       02485000
<< directory hash buckets, each bucket being a linked list of  >>       02490000
<< disc records containing directory entries whese symbolic    >>       02495000
<< names have identical hash function values.                  >>       02500000
<<                                                             >>       02505000
<<------------------------------------------------------------->>       02510000
<<                                                             >>       02515000
<< pointers referenced:                                        >>       02520000
<<                                                             >>       02525000
<<    sl0p  - integer pointer to 1st word of sl file record 0. >>       02530000
<<    sl0lp - logical pointer to 1st word of sl file record 0. >>       02535000
<<                                                             >>       02540000
<<------------------------------------------------------------->>       02545000
equate                                                                  02550000
   numsldirhashbuckets = 95;      << # words in hash list >>            02555000
                                                                        02560000
define                                                                  02565000
   sl0'formatid        = sl0p#,                                         02570000
   sl0'numdrecsinfile  = sl0lp(1)#,                                     02575000
   sl0'numdrecsperext  = sl0lp(2)#,                                     02580000
   sl0'lasttoolboxid   = sl0lp(3)#,                                     02585000
   sl0'numactivesegs   = sl0p(4)#,                                      02590000
   sl0'nextfreesegnum  = sl0p(7)#,                                      02595000
   sl0'numsegsalloc    = sl0p(9)#,                                      02600000
   sl0'numsections     = sl0p(11)#; << 1 sect = 2k disc recs >>         02605000
                                                                        02610000
$page                                                                   02615000
<<------------------------------------------------------------->>       02620000
<<                                                             >>       02625000
<< sl file entry point directory records.                      >>       02630000
<<                                                             >>       02635000
<<------------------------------------------------------------->>       02640000
<<                                                             >>       02645000
<< each entry point directory record contains one or more      >>       02650000
<< variable-length entries, all of which share the same value  >>       02655000
<< of a hash function applied to their symbolic names.  a link >>       02660000
<< field in each record points to the next record containing   >>       02665000
<< entries for the same hash value, thus producing a linked    >>       02670000
<< list of directory entry records.  each such linked list     >>       02675000
<< forms a hash bucket for a given hash function value, with   >>       02680000
<< the header links for the buckets stored in record 0.  a     >>       02685000
<< null link is represented by the value 0.                    >>       02690000
<<                                                             >>       02695000
<< when the number of entries in a record goes to zero, the    >>       02700000
<< record is removed from the list and is marked as available  >>       02705000
<< in the free space map which begins in record 2.             >>       02710000
<<                                                             >>       02715000
<<------------------------------------------------------------->>       02720000
<<                                                             >>       02725000
<< pointers referenced:                                        >>       02730000
<<                                                             >>       02735000
<<   sldirrecp  - integer pointer to 1st word of an entry      >>       02740000
<<                point directory record.                      >>       02745000
<<   sldirreclp - logical pointer to 1st word of an entry      >>       02750000
<<                point directory record.                      >>       02755000
<<                                                             >>       02760000
<<------------------------------------------------------------->>       02765000
                                                                        02770000
define                                                                  02775000
   sldirrec'link       = sldirreclp#,                                   02780000
   sldirrec'numwdsused = sldirrecp(1)#; << includes words 0, 1 >>       02785000
$page                                                                   02790000
<<------------------------------------------------------------->>       02795000
<<                                                             >>       02800000
<< sl file entry point directory entries.                      >>       02805000
<<                                                             >>       02810000
<<------------------------------------------------------------->>       02815000
<<                                                             >>       02820000
<< each entry in the entry point directory is used to describe >>       02825000
<< the attributes of a procedure entry point, as well as to    >>       02830000
<< locate the code for the procedure within the sl.  once an   >>       02835000
<< entry in the directory is reached, the segment number       >>       02840000
<< stored in the entry may be used to access the segment ref-  >>       02845000
<< erence table entry for that segment, which contains all the >>       02850000
<< information needed to access the segment in the sl.         >>       02855000
<<                                                             >>       02860000
<<------------------------------------------------------------->>       02865000
<<                                                             >>       02870000
<< pointers referenced:                                        >>       02875000
<<                                                             >>       02880000
<<   sldirentp   - integer pointer to 1st word of an entry     >>       02885000
<<                 point directory entry.                      >>       02890000
<<   sldirentlp - logical pointer to 1st word of an entry      >>       02895000
<<                point directory entry.                       >>       02900000
<<   sldirentp1  - integer pointer to 1st word after the name  >>       02905000
<<                 in an entry point directory entry.          >>       02910000
<<                                                             >>       02915000
<<------------------------------------------------------------->>       02920000
                                                                        02925000
define                                                                  02930000
   sldirent'ptrdecs =                                                   02935000
      integer pointer sldirentp;                                        02940000
      integer pointer sldirentp1#,                                      02945000
   sldirent'ptrs = sldirentp, sldirentp1#;                              02950000
                                                                        02955000
define                                                                  02960000
   sldirent'flags         = sldirentlp.(0:4)#,                          02965000
      sldirent'uncallable = sldirentlp.(2:1)#,                          02970000
      sldirent'permalloc  = sldirentlp.(3:1)#,                          02975000
   sldirent'nameblock     = sldirentbp#,                                02980000
   sldirent'sttnum        = sldirentp1.(0:8)#,                          02985000
   sldirent'segnum        = sldirentp1.(8:8)#,                          02990000
   sldirent'parmdesc      = sldirentp1(1)#;                             02995000
$page                                                                   03000000
<<------------------------------------------------------------->>       03005000
<<                                                             >>       03010000
<< sl file segment reference table entries.                    >>       03015000
<<                                                             >>       03020000
<<------------------------------------------------------------->>       03025000
<<                                                             >>       03030000
<< a segment reference table entry is used to specify proper-  >>       03035000
<< ties of each segment in the sl and identifies other areas   >>       03040000
<< of the file containing data pertinent to the segment.       >>       03045000
<< these include the segment's code image, its programmatic    >>       03050000
<< pmap, and the toolbox symbolic debug information.           >>       03055000
<<                                                             >>       03060000
<< included at the end of each entry is a bit map (refsegsmap) >>       03065000
<< which is used to quickly tell the loader which sl segments  >>       03070000
<< are referenced by the one associated with the entry and     >>       03075000
<< must also be loaded.  each set bit indicates the corre-     >>       03080000
<< sponding segment must be loaded.                            >>       03085000
<<                                                             >>       03090000
<< the segment's code image has two additional structures ap-  >>       03095000
<< appended to it.  the first is a 256-byte stt map array      >>       03100000
<< which, for each stt entry corresponding to an external ref- >>       03105000
<< erence satisfied by the sl, gives the number of the satis-  >>       03110000
<< fying segment.  if the corresponding stt is not that of a   >>       03115000
<< satisfied external, the value in the array is 255.  the stt >>       03120000
<< map array is followed by an external list, which is termi-  >>       03125000
<< nated by a zero word.                                       >>       03130000
<<                                                             >>       03135000
<< segment reference table entries are blocked 4 per disc rec- >>       03140000
<< record, and a list of disc record numbers of all such       >>       03145000
<< blocks, ordered sequentially by the numbers of the segments >>       03150000
<< contained in the blocks, is maintained in record 1.         >>       03155000
<<                                                             >>       03160000
<< once a segment reference table block is created, it is      >>       03165000
<< never deleted and added to the free list which starts in    >>       03170000
<< record 2.  instead, when sl segments are deleted by the     >>       03175000
<< -purgesl command, their reference table entries are added   >>       03180000
<< to a special free list chain whose header is placed in rec- >>       03185000
<< ord 0 (nextfreesegnum).  the first word of each reference   >>       03190000
<< table entry on the free list becomes a link field, giving   >>       03195000
<< the number of the next free segment.  the null link in this >>       03200000
<< chain is represented by -1.                                 >>       03205000
<<                                                             >>       03210000
<<------------------------------------------------------------->>       03215000
<<                                                             >>       03220000
<< pointers referenced:                                        >>       03225000
<<                                                             >>       03230000
<<   slrefp  - integer pointer to 1st word of a reference      >>       03235000
<<             table entry.                                    >>       03240000
<<   slreflp - logical pointer to 1st word of a reference     >>        03245000
<<             table entry.                                   >>        03250000
<<   slrefbp - byte pointer to 1st byte of a reference table   >>       03255000
<<             entry.                                          >>       03260000
<<                                                             >>       03265000
<<------------------------------------------------------------->>       03270000
$page                                                                   03275000
equate                                                                  03280000
   slrefblocknumwds     =   128,                                        03285000
   slrefblockfact       =     4,                                        03290000
   slrefentnumwds       =    32,                                        03295000
                                                                        03300000
   maxnumslrefblocks = (maxnumslsegs + slrefblockfact - 1) /            03305000
                       slrefblockfact;                                  03310000
                                                                        03315000
define                                                                  03320000
   slref'seglendesc     = slreflp#,                                     03325000
      slref'privseg     = slreflp.(0:1)#,                               03330000
      slref'newstt      = slreflp.(1:1)#,                               03335000
      slref'segnumwds   = slrefp.(2:14)#,                               03340000
   slref'codedrecnum    = slreflp(1)#,                                  03345000
   slref'codenumdrecs   = slrefp(2)#, << code, map, ext list >>         03350000
   slref'flags          = slreflp(3)#,                                  03355000
      slref'deleted     = slreflp(3).(0:1)#,                            03360000
      slref'extsat      = slreflp(3).(1:1)#,                            03365000
      slref'permalloc   = slreflp(3).(4:1)#,                            03370000
      slref'resident    = slreflp(3).(5:1)#,                            03375000
      slref'mpeseg      = slreflp(3).(6:1)#,                            03380000
      slref'numentpts   = slrefp(3).(9:7)#,                             03385000
   slref'pmapdrecnum    = slreflp(4)#,                                  03390000
   slref'toolboxdrecnum = slreflp(5)#,                                  03395000
   slref'segname0       = slrefbp(16)#, << 16-byte name >>              03400000
   slref'refsegsmap     = slrefp(20)#;                                  03405000
$page                                                                   03410000
<<------------------------------------------------------------->>       03415000
<<                                                             >>       03420000
<< sl file segment external list entries.                      >>       03425000
<<                                                             >>       03430000
<<------------------------------------------------------------->>       03435000
<<                                                             >>       03440000
<< the segment external list is found at the end of the code   >>       03445000
<< segment image section of the sl as described in the segment >>       03450000
<< reference table entry declarations.  the list contains the  >>       03455000
<< symbolic names and parameter descriptor arrays for all ex-  >>       03460000
<< ternal routines referenced by the associated segment.  if   >>       03465000
<< the external resides within the sl file, its segment and    >>       03470000
<< stt numbers are also given.                                 >>       03475000
<<                                                             >>       03480000
<<------------------------------------------------------------->>       03485000
<<                                                             >>       03490000
<< pointers referenced:                                        >>       03495000
<<                                                             >>       03500000
<<   slextp  - integer pointer to 1st word of an external list >>       03505000
<<             entry.                                          >>       03510000
<<   slextlp - logical pointer to 1st word of an external list >>       03515000
<<             entry.                                          >>       03520000
<<   slextp1 - integer pointer to 1st word after the name      >>       03525000
<<             field of an external list entry.                >>       03530000
<<                                                             >>       03535000
<<------------------------------------------------------------->>       03540000
                                                                        03545000
define                                                                  03550000
   slext'ptrdecs =                                                      03555000
      integer pointer slextp;                                           03560000
      logical pointer slextlp = slextp;                                 03565000
      integer pointer slextp1#,                                         03570000
   slext'ptrs = slextp, slextp1#;                                       03575000
                                                                        03580000
define                                                                  03585000
   slext'flags        = slextlp.(0:4)#,                                 03590000
      slext'satisfied = slextlp.(0:1)#,                                 03595000
   slext'nameblock    = slextp#,                                        03600000
   slext'stt          = slextp1.(0:8)#,                                 03605000
   slext'seg          = slextp1.(8:8)#,                                 03610000
   slext'parmdesc     = slextp1(1)#;                                    03615000
$page                                                                   03620000
<<------------------------------------------------------------->>       03625000
<<                                                             >>       03630000
<< internal pmap records.                                      >>       03635000
<<                                                             >>       03640000
<<------------------------------------------------------------->>       03645000
<<                                                             >>       03650000
<< pointers referenced:                                        >>       03655000
<<                                                             >>       03660000
<<    ipmapp   - integer pointer to 1st word of an internal    >>       03665000
<<               record.                                       >>       03670000
<<    ipmapbp  - byte pointer to 1st byte of an internal pmap  >>       03675000
<<               record.                                       >>       03680000
<<    ipmapp1  - integer pointer to 1st word after name in an  >>       03685000
<<               internal pmap record.                         >>       03690000
<<    ipmapdp1 - double pointer to 1st word after name in an   >>       03695000
<<               internal pmap record.                         >>       03700000
<<                                                             >>       03705000
<<------------------------------------------------------------->>       03710000
                                                                        03715000
equate ipmaprecmax      = 20; << internal pmap rec size     >> <<06555>>03720000
equate ipmaprec'var'max = 12; << max ipmap record size      >> <<06555>>03725000
                              << excluding name field       >> <<06555>>03730000
equate ipmaprec'var'min = 2;  << min ipmap record size      >> <<06555>>03735000
                              << excluding name field       >> <<06555>>03740000
equate maxtypetablelen  = 10; << this constant needs to be  >> <<06555>>03745000
                              << changed if more types are  >> <<06555>>03750000
                              << added to ipmap records     >> <<06555>>03755000
equate mintypetablelen  = 4;  << originally there are 3 types  <<06555>>03760000
                                                                        03765000
<< field definitions common to all record types: >>                     03770000
                                                                        03775000
define                                                                  03780000
   ipmap'type      = ipmapp.(0:4)#;                                     03785000
   equate                                                               03790000
      pmapsegtype     = 0,        << pmap segment >>                    03795000
      pmapproctype    = 1,        << pmap procedure >>                  03800000
      pmapsectype     = 2;        << pmap secondary entry>>             03805000
define                                                                  03810000
   ipmap'namenumch = ipmapp.(4:4)#, << # chars in ent name >>           03815000
   ipmap'name      = ipmapbp#,                                          03820000
                                                                        03825000
<< segment record field definitions: >>                                 03830000
                                                                        03835000
   ipmap'sttlen    = ipmapp1.(0:8)#,                                    03840000
   ipmap'segnum    = ipmapp1.(8:8)#,                                    03845000
   ipmap'seglen    = ipmapp1(1)#, << segment length, including >>       03850000
                                  <<   the stt.                >>       03855000
                                                                        03860000
<< procedure record field definitions: >>                               03865000
                                                                        03870000
   ipmap'flags     = ipmapp1#,                                          03875000
      ipmap'hidden = ipmapp1.(0:1)#,                                    03880000
                                                                        03885000
   ipmap'procstart = ipmapp1(1)#,                                       03890000
   ipmap'proclen   = ipmapp1(2)#,                                       03895000
   ipmap'procentry = ipmapp1(3)#,                                       03900000
   ipmap'tboxlink  = ipmapdp1(2)#,                                      03905000
   ipmap'tboxid    = ipmapp1(6)#,                                       03910000
                                                                        03915000
<< secondary entry point record definitions: >>                         03920000
                                                                        03925000
   ipmap'secentry  = ipmapp1(1)#,                                       03930000
   ipmap'secentnum = ipmapp1(2)#;                                       03935000
$page                                                                   03940000
<<------------------------------------------------------------->>       03945000
<<                                                             >>       03950000
<< external pmap records.                                      >>       03955000
<<                                                             >>       03960000
<<------------------------------------------------------------->>       03965000
<< pointers referenced:                                        >>       03970000
<<                                                             >>       03975000
<<    xpmapp  - integer pointer to 1st word of external pmap   >>       03980000
<<              record.                                        >>       03985000
<<    xpmapbp - byte pointer to 1st byte of external pmap rec- >>       03990000
<<              ord.                                           >>       03995000
<<    xpmapdp - double pointer to 1st word of external pmap    >>       04000000
<<              record.                                        >>       04005000
<<                                                             >>       04010000
<<------------------------------------------------------------->>       04015000
                                                                        04020000
equate xpmaprecmax = 36;          << external pmap rec size >>          04025000
                                                                        04030000
define                                                                  04035000
   xpmap'type      = xpmapp#,      << pmap record type >>               04040000
   xpmap'segname   = xpmapbp(2)#,  << segment name >>                   04045000
   xpmap'procname  = xpmapbp(18)#, << procedure name >>                 04050000
   xpmap'secname   = xpmapbp(34)#, << sec entry point name >>           04055000
   xpmap'segnum    = xpmapp(25)#,  << segment number >>                 04060000
   xpmap'seglen    = xpmapp(26)#,  << seg len, incl stt >>              04065000
   xpmap'sttlen    = xpmapp(27)#,  << stt length >>                     04070000
   xpmap'procstart = xpmapp(28)#,  << code starting addr >>             04075000
   xpmap'proclen   = xpmapp(29)#,  << procedure length >>               04080000
   xpmap'procentry = xpmapp(30)#,  << primary entry point >>            04085000
   xpmap'secentry  = xpmapp(31)#,  << secondary entry pt >>             04090000
   xpmap'secentnum = xpmapp(32)#,  << sec entry point # >>              04095000
   xpmap'tboxid    = xpmapp(33)#,  << toolbox id >>                     04100000
   xpmap'tboxlink  = xpmapdp(17)#; << toolbox id link >>                04105000
$page                                                                   04110000
<<------------------------------------------------------------->>       04115000
<<                                                             >>       04120000
<< pmap control block.                                         >>       04125000
<<                                                             >>       04130000
<<------------------------------------------------------------->>       04135000
<<                                                             >>       04140000
<< the pmap control block is used to save all data required to >>       04145000
<< access the pmap data stored in program and sl files.  it    >>       04150000
<< serves as a replacement for global and own variables, which >>       04155000
<< are not allowed in sl procedures.  the control block is     >>       04160000
<< allocated in each of the externally-callable pmap intrin-   >>       04165000
<< sics and is passed as a parameter to each of the internal   >>       04170000
<< procedures which manage the pmap data stored in program and >>       04175000
<< sl files.                                                   >>       04180000
<<                                                             >>       04185000
<< the structure of the data in the control block varies       >>       04190000
<< slightly, depending on whether or not the file containing   >>       04195000
<< the pmap is a program or sl file.  the first part of the    >>       04200000
<< block contains data required in reading both program and sl >>       04205000
<< files.  after this area, two variants in the pascal sense   >>       04210000
<< follow, one for use in reading program files, the other for >>       04215000
<< sl files.                                                   >>       04220000
<<                                                             >>       04225000
<<------------------------------------------------------------->>       04230000
                                                                        04235000
<< declarations for the static control information: >>                  04240000
                                                                        04245000
define                                                                  04250000
   pmapflags      = pmapcb#,      << control flags >>                   04255000
      pmappreset  = pmapcbl.(0:1)#,                                     04260000
                                  << true if pmapbufx is set   >>       04265000
                                  << at next pmap record to be >>       04270000
                                  << returned, instead of last >>       04275000
                                  << one returned.             >>       04280000
      pmapend     = pmapcbl.(1:1)#,                                     04285000
                                  << true if end-of-pmap con-  >>       04290000
                                  << dition should be returned >>       04295000
                                  << on next pmap read.        >>       04300000
      slrefblockloaded = pmapcbl.(2:1)#,                                04305000
                                  << true if an sl reference   >>       04310000
                                  << table block has beed read.>>       04315000
      firsthalfsegptrloaded = pmapcbl.(3:1)#,                           04320000
                              << true if the first 128 segment >>       04325000
                              << pointers has been loaded onto >>       04330000
                              << pmapcb, otherwise the rest of >>       04335000
                              << the pointers were loaded.     >>       04340000
      segpmapmaped= pmapcbl.(4:1)#,                                     04345000
                                  << true if segment pmap was  >>       04350000
                                  << previously maped. use for >>       04355000
                                  << stopping the scanning as  >>       04360000
                                  << scancode = scancurseg     >>       04365000
   ipmapfnum      = pmapcb(1)#,   << # of prog/sl file >>               04370000
   ipmapfilecode  = pmapcb(2)#,   << prog/sl file code >>               04375000
   pmapcursegnum  = pmapcb(3)#,   << # current pmap seg >>              04380000
   pmapcurdrecnum = pmapcb(4)#,   << 1st rec in pmap buf  >>            04385000
   pmapbufx       = pmapcb(5)#;   << index to last pmap record >>       04390000
                                  << processed.                >>       04395000
                                                                        04400000
<< constant offsets for variant declarations: >>                        04405000
                                                                        04410000
equate                                                                  04415000
   infolen        = 6,                                                  04420000
   sapmapbuf      = infolen  + maxtypetablelen,                         04425000
   varbase        = sapmapbuf + ipmapbufnumwds,                         04430000
   progoff1       = varbase  + pf0'infonumwds,                          04435000
   sloff1         = varbase  + drecnumwds,                              04440000
   sloff2         = sloff1   + maxnumslrefblocks,                       04445000
   pmapcblen      = sloff2   + slrefblocknumwds;                        04450000
                                                                        04455000
define                                                                  04460000
   typetablelen = typetable(0)#,                                        04465000
   segpmaplen   = typetable(1)#,                                        04470000
   pritypelen   = typetable(2)#,                                        04475000
   sectypelen   = typetable(3)#;                                        04480000
                                                                        04485000
define ia = integer array#;                                             04490000
                                                                        04495000
define pmapcbdec =                                                      04500000
   logical array pmapcbl(*)           = pmapcb;                         04505000
   ia            typetable(*)         = pmapcb(infolen);                04510000
   ia            pmapbuf(*)           = pmapcb(sapmapbuf);              04515000
   double  array pmapbufd(*)          = pmapcb(sapmapbuf);              04520000
   ia            pf0p(*)              = pmapcb(varbase);                04525000
   logical array pf0lp(*)             = pf0p;                           04530000
   double  array progpmapptrs(*)      = pmapcb(progoff1);               04535000
   ia            progpmapptrsi(*)     = pmapcb(progoff1);               04540000
   ia            sl0p(*)              = pmapcb(varbase);                04545000
   logical array sl0lp(*)             = sl0p;                           04550000
   ia            sl0'dirhashptrs(*)   = sl0p(33);                       04555000
   logical array slrefblockdrecnum(*) = pmapcb(sloff1);                 04560000
   ia            slrefblock(*)        = pmapcb(sloff2)                  04565000
#;                                                                      04570000
$page                                                                   04575000
<<------------------------------------------------------------->>       04580000
<<                                                             >>       04585000
<< macro to test the condition code returned by file system    >>       04590000
<< intrinsics.                                                 >>       04595000
<<                                                             >>       04600000
<<------------------------------------------------------------->>       04605000
                                                                        04610000
define checkipmapio =                                                   04615000
   if <> then                                                           04620000
      begin                                                             04625000
      status := stat'ipmapioerr;                                        04630000
      return;                                                           04635000
      end                                                               04640000
#;                                                                      04645000
                                                                        04650000
<<------------------------------------------------------------->>       04655000
<<                                                             >>       04660000
<< macro to turn off user traps.                               >>       04665000
<<                                                             >>       04670000
<<------------------------------------------------------------->>       04675000
                                                                        04680000
define turnofftraps =                                                   04685000
   push(status);                  << get status register >>             04690000
   tos.(2:1) := 0;                << turn off user traps >>             04695000
   set(status)                    << replace status register >>         04700000
#;                                                                      04705000
$page "INTRINSICS REFERENCED"                                           04710000
<<------------------------------------------------------------->>       04715000
<<                                                             >>       04720000
<< intrinsics referenced.                                      >>       04725000
<<                                                             >>       04730000
<<------------------------------------------------------------->>       04735000
                                                                        04740000
intrinsic activate;                                                     04745000
                                                                        04750000
procedure awake(pcbindex, oldwait, newwait);                            04755000
   value   pcbindex, oldwait, newwait;                                  04760000
   integer pcbindex, oldwait, newwait;                                  04765000
   option  external;                                                    04770000
                                                                        04775000
procedure chek(intrinsic, flags, parms, capmask, optvmask);             04780000
   value   intrinsic, flags, parms, capmask, optvmask;                  04785000
   logical intrinsic, flags, optvmask;                                  04790000
   double  parms, capmask;                                              04795000
   option  variable, external;                                          04800000
                                                                        04805000
intrinsic create;                                                       04810000
intrinsic fclose;                                                       04815000
intrinsic fgetinfo;                                                     04820000
intrinsic fopen;                                                        04825000
intrinsic fpoint;                                                       04830000
intrinsic fread;                                                        04835000
intrinsic freaddir;                                                     04840000
intrinsic fwrite;                                                       04845000
intrinsic fwritedir;                                                    04850000
intrinsic fcheck;                                                       04855000
intrinsic getprocid;                                                    04860000
intrinsic kill;                                                         04865000
intrinsic print;                                                        04870000
intrinsic receivemail;                                                  04875000
intrinsic sendmail;                                                     04880000
$page "INITUSLF"                                               <<00207>>04885000
integer procedure inituslf (uslfnum,rec0);                              04890000
   <<this procedure initializes the record 0 buffer of a usl file.      04895000
                                                                        04900000
     condition code conventions:                                        04905000
                                                                        04910000
         cce   request granted                                          04915000
         ccl   request denied - error nr. returned as result            04920000
                                                                        04925000
     note that this procedure always returns to the caller>>            04930000
   value uslfnum;                                                       04935000
   integer array rec0;                                                  04940000
   integer uslfnum;                                                     04945000
   option privileged;                                                   04950000
   begin                                                                04955000
   double array drec0 (*) = rec0;                                       04960000
   double drecords;                                                     04965000
   integer records = drecords+1;                                        04970000
                                                                        04975000
   <<* * * check for legal request * * *>>                              04980000
                                                                        04985000
   chek([10/82,6/2],[8/0,2/1,1/0,5/2],[2/2,2/0]d);                      04990000
   fgetinfo(uslfnum,,,,,,,,,,,drecords);                                04995000
   if not (drecords > 4d) or not (drecords < 32768d) then               05000000
      begin                                                             05005000
      tos _ err3; go nfg                                                05010000
      end;                                                              05015000
                                                                        05020000
   <<* * * initialize record 0 buffer * * *>>                           05025000
                                                                        05030000
   tos _ @rec0; ps0 _ 0;                                                05035000
   assemble(dup,incb); tos _ 127; assemble(move 3);                     05040000
   usllid _ 1;                                                          05045000
   uslfl _ drecords&dlsl(7);                                            05050000
   uslsaad _ 128;                                                       05055000
   tos _ (logical(records)+3)&lsr(3);                                   05060000
   if s0 > 255 then tos _ 255;                                          05065000
   usladl _ tos&lsl(7);                                                 05070000
   uslsai _ double(usladl)+128d;                                        05075000
   uslsaai _ uslsai;                                                    05080000
   uslail _ uslfl-uslsai;                                               05085000
   tos _ cce;                                                           05090000
   go getout;                                                           05095000
                                                                        05100000
   nfg:                                                                 05105000
   inituslf _ tos;  <<error nr.>>                                       05110000
   tos _ ccl;                                                           05115000
                                                                        05120000
   getout:                                                              05125000
   condcode _ tos                                                       05130000
   end;                                                                 05135000
$page "ADJUSTUSLF"                                             <<00207>>05140000
integer procedure adjustuslf (uslfnum,records);                         05145000
   <<this procedure moves the info block:                               05150000
         if records > 0 the info block is moved down, thereby increasing05155000
            the available directory block and decreasing the available  05160000
            info block                                                  05165000
         if records < 0 the info block is moved up, thereby decreasing  05170000
            the available directory block and increasing the available  05175000
            info block                                                  05180000
                                                                        05185000
     condition code conventions:                                        05190000
                                                                        05195000
         cce   request granted                                          05200000
         ccl   request denied - error nr. returned as result            05205000
                                                                        05210000
     note that this procedure must be called with db set to the stack>> 05215000
   value uslfnum,records;                                               05220000
   integer uslfnum,records;                                             05225000
   option privileged;                                                   05230000
   begin                                                                05235000
   integer array rec0 (0:127);  <<usl record 0 buffer>>                 05240000
   double array drec0 (*) = rec0;                                       05245000
   double dsrecd;                                                       05250000
   integer srecd = dsrecd+1;                                            05255000
   double dtrecd;                                                       05260000
   integer trecd = dtrecd+1;                                            05265000
   double dnrwords;                                                     05270000
   integer nrwords = dnrwords+1;                                        05275000
                                                                        05280000
   <<* * * check for legal request * * *>>                              05285000
                                                                        05290000
   chek([10/83,6/2],[8/0,2/1,1/0,5/2]);                                 05295000
   if records = 0 then go finished;  <<null request?>>                  05300000
   freaddir(uslfnum,rec0,128,0d);  <<read record 0>>                    05305000
   if <> then  <<error?>>                                               05310000
      begin                                                             05315000
      fileerror:                                                        05320000
      tos _ if > then err0 else err1;                                   05325000
      go nfg                                                            05330000
      end;                                                              05335000
   dnrwords _ double(records)&dasl(7);                                  05340000
   usladl _ usladl+nrwords;                                             05345000
   if < then  <<directory too small?>>                                  05350000
      begin                                                             05355000
      tos _ err5; go nfg                                                05360000
      end;                                                              05365000
   uslsai _ uslsai+dnrwords;                                            05370000
   if uslsai > 32768d then                                              05375000
      begin                                                             05380000
      tos _ err4; go nfg                                                05385000
      end;                                                              05390000
   uslsaai _ uslsaai+dnrwords;                                          05395000
   uslail _ uslail-dnrwords;                                            05400000
   if < then  <<info too small?>>                                       05405000
      begin                                                             05410000
      tos _ err6; go nfg                                                05415000
      end;                                                              05420000
   fwritedir(uslfnum,rec0,128,0d);  <<save record 0>>                   05425000
   if <> then go fileerror;  <<error?>>                                 05430000
                                                                        05435000
   <<* * * move records * * *>>                                         05440000
                                                                        05445000
   xreg _ records;                                                      05450000
   if < then tos _ uslsai else tos _ uslsaai;                           05455000
   dtrecd _ ds1&dlsr(7);  <<target rec. nr.>>                           05460000
   dsrecd _ (tos-dnrwords)&dlsr(7);  <<source rec. nr.>>                05465000
   tos _ (uslil+127d)&dlsr(7);  <<record counter>>                      05470000
   while <> do                                                          05475000
      begin                                                             05480000
      freaddir(uslfnum,rec0,128,dsrecd);                                05485000
      if <> then go fileerror;  <<error?>>                              05490000
      fwritedir(uslfnum,rec0,128,dtrecd);                               05495000
      if <> then go fileerror;  <<error?>>                              05500000
      xreg _ records;                                                   05505000
      if < then                                                         05510000
         begin                                                          05515000
         srecd _ srecd+1;                                               05520000
         trecd _ trecd+1                                                05525000
         end                                                            05530000
      else                                                              05535000
         begin                                                          05540000
         srecd _ srecd-1;                                               05545000
         trecd _ trecd-1                                                05550000
         end;                                                           05555000
      tos _ tos-1                                                       05560000
      end;                                                              05565000
                                                                        05570000
   finished:                                                            05575000
   tos _ cce;                                                           05580000
   go getout;                                                           05585000
                                                                        05590000
   nfg:                                                                 05595000
   adjustuslf _ tos;  <<error nr.>>                                     05600000
   tos _ ccl;                                                           05605000
                                                                        05610000
   getout:                                                              05615000
   condcode _ tos                                                       05620000
   end;                                                                 05625000
$page "EXPANDUSLF"                                             <<00207>>05630000
integer procedure expanduslf (uslfnum,records);                         05635000
   <<this procedure alters the file size of the specified usl file by   05640000
     creating a new usl file and copying the old usl file into the      05645000
     new usl file:                                                      05650000
         if records < 0 then the new usl file is that many records      05655000
            shorter than the old usl file                               05660000
         if records > 0 then the new usl file is that many records      05665000
            longer than the old usl file                                05670000
                                                                        05675000
     condition code conventions:                                        05680000
                                                                        05685000
         cce   request granted                                          05690000
         ccl   request denied - error nr. returned as result            05695000
                                                                        05700000
     note that this procedure must be called with db set to the stack>> 05705000
   value uslfnum,records;                                               05710000
   integer uslfnum,records;                                             05715000
   option privileged;                                                   05720000
   begin                                                                05725000
   integer array rec0 (0:127);  <<record 0 buffer>>                     05730000
   double array drec0 (*) = rec0;                                       05735000
   byte array newuslfname (0:35);  <<new usl file name>>                05740000
   integer newuslfnum _ 0;  <<new usl file nr.>>                        05745000
   integer                                                     <<00.02>>05750000
       errorcode,                                              <<04978>>05755000
       fopt,       <<foption of source (input) usl>>           <<00.02>>05760000
       aopt;       <<aoption "   "       "     "  >>           <<00.02>>05765000
                                                               <<00.02>>05770000
   define                                                      <<00.02>>05775000
       oldpass = fopt.(10:3) = 3 #,                            <<00.02>>05780000
       domain  = fopt.(14:2) #,                                <<00.02>>05785000
       newfile = domain = 0 #;                                 <<00.02>>05790000
                                                                        05795000
   <<* * * check for legal request * * *>>                              05800000
                                                                        05805000
   chek([10/84,6/2],[8/0,2/1,1/0,5/2]);                                 05810000
   freaddir(uslfnum,rec0,128,0d);  <<read record 0>>                    05815000
   if <> then  <<error?>>                                               05820000
      begin                                                             05825000
      fileerror:                                                        05830000
      tos _ if > then err0 else err1;                                   05835000
      go nfg                                                            05840000
      end;                                                              05845000
   uslfl _ uslfl+double(records)&dasl(7);                               05850000
   if uslfl > 4194304d then  <<too big?>>                               05855000
      begin                                                             05860000
      tos _ err3; go nfg                                                05865000
      end;                                                              05870000
   uslail _ uslail+double(records)&dasl(7);                             05875000
   if < then  <<too small?>>                                            05880000
      begin                                                             05885000
      tos _ err6; go nfg                                                05890000
      end;                                                              05895000
                                                                        05900000
   <<* * * open new usl file * * *>>                                    05905000
                                                                        05910000
   assemble(adds 15);                                                   05915000
   fgetinfo(uslfnum,newuslfname,s12,s11,,,,,s0,,,ds4,,,s6,,s2,s7);      05920000
   fopt := s12;                                                <<00.02>>05925000
   aopt := s11;                                                <<00.02>>05930000
   @bps13 _ @newuslfname;                                               05935000
   s12.(14:2) _ 0;  <<"NEW" domain>>                                    05940000
   s11.(12:4) := 4; <<insure read/write access>>               <<00.06>>05945000
   s6 _ s6&lsr(7);  <<blocking factor>>                                 05950000
   s5 _ 1;  <<nr. buffers>>                                             05955000
   ds4 _ ds4+double(records);  <<file size>>                            05960000
   tos _ %(2)1110001111101;  <<option variable list>>                   05965000
   if s13.(10:3) = 2 then  <<$newpass?>>                                05970000
      begin                                                             05975000
      fclose(uslfnum,0,0);  <<close $newpass making it $oldpass>>       05980000
      if < then  <<error?>>                                             05985000
         begin                                                          05990000
         tos _ err10; go nfg                                            05995000
         end;                                                           06000000
      uslfnum _ fopen(,%(2)10000011010,%(2)001000100);  <<$oldpass>>    06005000
      if < then  <<error?>>                                             06010000
         begin                                                          06015000
         tos _ err11; go nfg                                            06020000
         end;                                                           06025000
      tos.(3:1) _ 0; <<no file designator>>                    <<00.06>>06030000
      fpoint (uslfnum,1d);  <<reposition>>                     <<00.06>>06035000
      end                                                               06040000
   else if s13.(10:3) = 3 then  <<$oldpass?>>                           06045000
      begin                                                             06050000
      s13.(10:3) _ 2;  <<$newpass>>                                     06055000
      tos.(3:1) _ 0  <<no file designator>>                             06060000
      end;                                                              06065000
   assemble(pcal fopen);                                                06070000
   newuslfnum _ tos;  <<new usl file nr.>>                              06075000
   if < then  <<error?>>                                                06080000
      begin                                                             06085000
      tos _ err7; go nfg                                                06090000
      end;                                                              06095000
                                                                        06100000
   <<* * * copy old usl into new usl * * *>>                            06105000
                                                                        06110000
   tos _ (uslil+127d)&dlsr(7);  <<info record counter>>                 06115000
   tos _ uslsai&dlsr(7);  <<info rec. nr.>>                             06120000
   tos _ (usldl+255)&lsr(7);  <<directory record counter>>              06125000
   go firsttime;                                                        06130000
   do begin  <<copy record 0 and directory>>                            06135000
      fread(uslfnum,rec0,128);                                          06140000
      if <> then go fileerror;  <<error?>>                              06145000
      firsttime:                                                        06150000
      fwrite(newuslfnum,rec0,128,0);                                    06155000
      if <> then go fileerror;  <<error?>>                              06160000
      tos _ tos-1                                                       06165000
      end until =;                                                      06170000
   fpoint(uslfnum,ds2);                                                 06175000
   fpoint(newuslfnum,ds2);                                              06180000
   assemble(del,ddel; delb,test);                                       06185000
   while <> do  <<copy info>>                                           06190000
      begin                                                             06195000
      fread(uslfnum,rec0,128);                                          06200000
      if <> then go fileerror;  <<error?>>                              06205000
      fwrite(newuslfnum,rec0,128,0);                                    06210000
      if <> then go fileerror;  <<error?>>                              06215000
      tos _ tos-1                                                       06220000
      end;                                                              06225000
                                                                        06230000
   <<* * * purge old usl file * * *>>                                   06235000
                                                                        06240000
   expanduslf _ newuslfnum;  <<new usl file nr.>>                       06245000
   if not logical (newfile) or oldpass then                    <<00.02>>06250000
   begin           <<make it oldpass,oldtemp,or perm>>         <<00.02>>06255000
       fclose (newuslfnum,domain,0);                           <<00.02>>06260000
       if < then                                               <<00.02>>06265000
       begin                                                   <<00.02>>06270000
           fcheck(newuslfnum,errorcode);                       <<04978>>06275000
           if errorcode = 100 or errorcode = 101 then          <<04978>>06280000
              begin                                            <<04815>>06285000
                 fclose(uslfnum,4,0);                          <<04815>>06290000
                 if < then                                     <<04815>>06295000
                    begin                                      <<04815>>06300000
                       tos:=err8;                              <<04815>>06305000
                       go nfg;                                 <<04815>>06310000
                    end;                                       <<04815>>06315000
                 fclose(newuslfnum,domain,0);                  <<04918>>06320000
                 if < then                                     <<04918>>06325000
                    begin                                      <<04918>>06330000
                       tos:=err9;                              <<04918>>06335000
                       go nfg';                                <<04918>>06340000
                    end;                                       <<04918>>06345000
              end                                              <<04815>>06350000
           else                                                <<04815>>06355000
              begin                                            <<04815>>06360000
                 tos:=err9;                                    <<04815>>06365000
                 go nfg';                                      <<04815>>06370000
              end;                                             <<04815>>06375000
       end                                                     <<04815>>06380000
       else                                                    <<04815>>06385000
          begin                                                <<04815>>06390000
             fclose(uslfnum,4,0);                              <<04815>>06395000
             if < then                                         <<04815>>06400000
                begin                                          <<04815>>06405000
                   tos:=err8;                                  <<04815>>06410000
                   go nfg;                                     <<04815>>06415000
                end;                                           <<04815>>06420000
          end;                                                 <<04815>>06425000
       expanduslf := fopen (newuslfname,fopt,aopt);            <<00.02>>06430000
       if < then                                               <<00.02>>06435000
       begin                                                   <<00.02>>06440000
           tos := err7;                                        <<00.02>>06445000
           go nfg';                                            <<00.02>>06450000
       end;                                                    <<00.02>>06455000
   end                                                         <<04815>>06460000
   else                                                        <<04815>>06465000
      fclose(uslfnum,4,0);                                     <<04815>>06470000
   tos _ cce;  <<ok condition code>>                                    06475000
   go getout;                                                           06480000
                                                                        06485000
   nfg:                                                                 06490000
   if newuslfnum <> 0 then  <<purge new usl file?>>                     06495000
      begin                                                             06500000
      fclose(newuslfnum,4,0);                                           06505000
      if < then tos _ err9  <<error?>>                                  06510000
      end;                                                              06515000
   nfg':                                                       <<00.02>>06520000
   expanduslf _ tos;  <<error nr.>>                                     06525000
   tos _ ccl;  <<error condition code>>                                 06530000
                                                                        06535000
   getout:                                                              06540000
   condcode _ tos  <<store condition code>>                             06545000
   end;                                                                 06550000
$page "MOVESTRING"                                             <<00207>>06555000
procedure movestring (source,target);                                   06560000
   <<moves a string (terminated by a blank) from source to target.      06565000
     the number of char's is inserted in the first byte of target       06570000
     and the string is truncated to 15 char's if necessary>>            06575000
   byte array source,target;                                            06580000
   option internal,uncallable;                                          06585000
   begin                                                                06590000
   byte array source' (0:15);                                           06595000
   move source' := source,(15),2;  <<first 15 char's of string>>        06600000
   bps0 := " ";  <<add blank terminator>>                               06605000
   tos := @target; assemble(delb,inca); tos := @source';                06610000
   l1: move * := * while ans,0;  <<move and upshift string>>            06615000
   if bps0 <> " " then  <<non-blank special?>>                          06620000
      begin                                                             06625000
      move * := *,(1),1;                                                06630000
      go l1                                                             06635000
      end;                                                              06640000
   target := tos-@source'  <<string length>>                            06645000
   end;                                                                 06650000
$page "SEGMENTER"                                              <<00207>>06655000
procedure segmenter (pin,command,error,num1,num2,num3,num4,num5,        06660000
                     num6,string1,string2,fname1,fname2);      <<00629>>06665000
   <<segmenter subsystem process communication procedure.  the          06670000
     first call must have pin = 0 to initiate the process; after        06675000
     that, pin must not be changed.                                     06680000
                                                                        06685000
     condition code conventions:                                        06690000
                                                                        06695000
         cce   command accepted                                         06700000
         ccg   command rejected - segmenter process intact              06705000
         ccl   command rejected - segmenter process terminated          06710000
                                                                        06715000
     if ccg or ccl then error contains one of the following error       06720000
     numbers:                                                           06725000
                                                                        06730000
         0  command rejected - error(s) printed on list device          06735000
         1  command conditionally accepted - warning(s) printed on      06740000
            list device                                                 06745000
         2  illegal calling sequence                                    06750000
         3  unable to create segmenter process                          06755000
         4  unable to activate segmenter process                        06760000
         5  unable to sendmail to segmenter process                     06765000
         6  unable to receivemail from segmenter process                06770000
         7  segmenter process aborted                                   06775000
                                                                        06780000
     note that error 0,1 indicates that the segmenter process received  06785000
     and acted on the command, whereas the remaining errors indicate    06790000
     that the segmenter process never received the command.             06795000
                                                                        06800000
       command         parameters                                       06805000
       -------         ----------                                       06810000
                                                                        06815000
      0 addrl          string1     - rbm name                           06820000
                       num1        - index                              06825000
                                                                        06830000
      1 addsl          string2                                          06835000
                       num3.(15:1) - pmap                               06840000
                                                                        06845000
      2 auxusl         fname1      - auxusl file name                   06850000
                                                                        06855000
      3 buildrl        fname1      - name of rl file                    06860000
                       num1        - size of rl file                    06865000
                       num2        - # extents in rl file               06870000
                                                                        06875000
      4 buildsl        fname1      - name of sl file                    06880000
                       num1        - size of sl file                    06885000
                       num2        - # extents in sl file               06890000
                                                                        06895000
      5 buildusl       fname1      - name of usl file                   06900000
                       num1        - size of usl file                   06905000
                       num2        - # extents in usl file              06910000
                                                                        06915000
      6 cease          string1     - name                               06920000
                       num1        - index                              06925000
                       num3.(12:2) - class                              06930000
                                                                        06935000
      7 copy           string1     - name                               06940000
                       num1        - index                              06945000
                       num3.(12:2) - class                              06950000
                                                                        06955000
      8 exit           (none)                                           06960000
                                                                        06965000
      9 hide           string1     - name                               06970000
                       num1        - index                              06975000
                                                                        06980000
     10 listrl         num3.(15:1) - list                               06985000
                                                                        06990000
     11 listsl         fname1      - segment name                       06995000
                       num3.(15:1) - list                               07000000
                                                                        07005000
     12 listusl        string2     - segment name                       07010000
                       num3.(15:1) - list                               07015000
                                                                        07020000
     13 newseg         string2     - new segment name                   07025000
                       string1     - rbm name                           07030000
                       num1        - index                              07035000
                                                                        07040000
     14 prepare        fname1      - program file name                  07045000
                       fname2      - rl file name                       07050000
                       num3.(14:1) - zerodb                             07055000
                       num3.(15:1) - pmap                               07060000
                       num1        - stack size (-1 default)            07065000
                       num2        - dl size (-1 default)               07070000
                       num4        - maxdata size (-1 default)          07075000
                       num5        - cap                                07080000
                  bit -    6  7  8  9 10 11 12 13 14 15                 07085000
                          ns ba ia pm cr rt mr cd ds ph                 07090000
                       num6        - patch size (-1 no patch)           07095000
                                                                        07100000
     15 purgerbm       string1     - name                               07105000
                       num1        - index                              07110000
                       num3.(12:2) - class                              07115000
                                                                        07120000
     16 purgerl        string1     - name                               07125000
                       num3.(12:2) - class                              07130000
                                                                        07135000
     17 purgesl        string1     - name                               07140000
                       num3.(12:2) - class                              07145000
                                                                        07150000
     18 reveal         string1     - name                               07155000
                       num1        - index                              07160000
                                                                        07165000
     19 rl             fname1      - rl file name                       07170000
                                                                        07175000
     20 sl             fname1      - sl file name                       07180000
                                                                        07185000
     21 use            string1     - name                               07190000
                       num1        - index                              07195000
                       num3.(12:2) - class                              07200000
                                                                        07205000
     22 usl            fname1      - usl file name                      07210000
                                                                        07215000
     23 debug          (none)                                           07220000
                                                                        07225000
     24 copysl         num1        - percent                            07230000
                       fname1      - new sl file name                   07235000
                                                                        07240000
     25 copyusl        num1        - percent                            07245000
                       fname1      - new usl file name                  07250000
                                                                        07255000
     26 cleansl        fname1      - new sl file name                   07260000
                                                                        07265000
     27 cleanusl       fname1      - new usl file name                  07270000
                                                                        07275000
      29 listaux        string2     - segment name                      07280000
                        num3.(15:1) - list                              07285000
                                                                        07290000
     note:                                                              07295000
                   0 - segment                                          07300000
         class =   1 - unit                                             07305000
                   2 - entry                                            07310000
                                                                        07315000
     the last command must be the exit command (command = 8).  this     07320000
     will terminate the segmenter process>>                             07325000
   value command,num1,num2,num3,num4,num5,num6;                <<00629>>07330000
   integer pin,command,error,num1,num2,num3,num4,num5,num6;    <<00629>>07335000
   byte array string1,string2,fname1,fname2;                            07340000
   option variable;                                            <<00.02>>07345000
   begin                                                                07350000
   integer parmword = q-4;  <<parameter bits>>                          07355000
   equate maillength = 59,                                     <<00629>>07360000
          mailbnd = maillength-1;                                       07365000
   byte array segmenter(0:27);    << name of segproc program >><<04102>>07370000
   integer array combuf (0:mailbnd);  <<command buffer>>                07375000
   byte array bcombuf (*) = combuf;                                     07380000
                                                                        07385000
   <<* * * check parameters * * *>>                                     07390000
                                                                        07395000
   tos _ parmword;  <<option variable bits>>                            07400000
   if s0.(0:6) <> %(2)111 then  <<missing required parm's?>>   <<00629>>07405000
      begin                                                             07410000
      tos _ 2; go soft                                                  07415000
      end;                                                              07420000
   tos _ @combuf; ps0 _ 0;                                              07425000
   assemble(dup,incb); tos _ 22; assemble(move 3);             <<00629>>07430000
   tos _ @combuf(23); ps0 _ "  ";                              <<00629>>07435000
   assemble(dup,incb); tos _ 35; assemble(move 3);                      07440000
   combuf _ command;                                                    07445000
   if ls0.(6:1) then combuf(1) := num1;                        <<00629>>07450000
   if ls0.(7:1) then combuf(2) := num2;                        <<00629>>07455000
   if ls0.(8:1) then combuf(3) := num3;                        <<00629>>07460000
   if ls0.(9:1) then combuf(4) := num4;                        <<00629>>07465000
   if ls0.(10:1) then combuf(5) := num5;                       <<00629>>07470000
   if ls0.(11:1) then combuf(6) := num6;                       <<00629>>07475000
   if ls0.(12:1) then movestring(string1,bcombuf(14));         <<00629>>07480000
   if ls0.(13:1) then movestring(string2,bcombuf(30));         <<00629>>07485000
   if ls0.(14:1) then move bcombuf(46) _ fname1,(36);          <<00629>>07490000
   if tos then move bcombuf(82) _ fname2,(36);                 <<00629>>07495000
                                                                        07500000
   <<* * * fire-up segmenter subsystem * * *>>                          07505000
                                                                        07510000
   if pin = 0 then  <<create segmenter process?>>                       07515000
      begin                                                             07520000
      if command = 8 then go aok;  <<exit command?>>                    07525000
      move segmenter _ "SEGPROC.PUB.SYS ";                              07530000
      create(segmenter,,pin,,1);                               <<00.02>>07535000
      if < then  <<failure to create?>>                                 07540000
         begin                                                          07545000
         tos _ 3; go hard                                               07550000
         end;                                                           07555000
      activate(pin,2);  <<wake son & wait>>                    <<00.02>>07560000
      if <> then  <<error?>>                                            07565000
         begin                                                          07570000
         sick:                                                          07575000
         tos _ 4; go hard                                               07580000
         end                                                            07585000
      end;                                                              07590000
                                                                        07595000
   <<* * * send command thru the mail * * *>>                           07600000
                                                                        07605000
   sendmail(pin,maillength,combuf,false);                               07610000
   if <> then  <<unable to send mail?>>                                 07615000
      begin                                                             07620000
      tos _ 5; go hard                                                  07625000
      end;                                                              07630000
   activate(pin,2);  <<wake son & wait>>                       <<00.02>>07635000
   if <> then go sick;  <<failure to re-activate?>>                     07640000
   if command = 8 then go aok;  <<exit command?>>                       07645000
   if getprocid(1) = 0 then <<son died>>                       <<00.02>>07650000
      begin                                                             07655000
      tos _ 7; go hard                                                  07660000
      end;                                                              07665000
                                                                        07670000
   <<* * * return error condition to caller * * *>>                     07675000
                                                                        07680000
   receivemail(pin,combuf,false);                                       07685000
   if <> then  <<unable to receive mail?>>                              07690000
      begin                                                             07695000
      tos _ 6; go hard                                                  07700000
      end;                                                              07705000
   tos _ combuf;  <<error nr.>>                                         07710000
   if >= then go soft;  <<error?>>                                      07715000
                                                                        07720000
   <<* * * return to caller * * *>>                                     07725000
                                                                        07730000
   aok:                                                                 07735000
   tos _ cce;  <<ok condition code>>                                    07740000
   go getout;                                                           07745000
                                                                        07750000
   hard:                                                                07755000
   kill(pin);  <<kill subsystem>>                                       07760000
   error _ tos;  <<error nr.>>                                          07765000
   tos _ ccl;  <<hard error condition code>>                            07770000
   go getout;                                                           07775000
                                                                        07780000
   soft:                                                                07785000
   error _ tos;  <<error nr.>>                                          07790000
   tos _ ccg;  <<soft error condition code>>                            07795000
                                                                        07800000
   getout:                                                              07805000
   condcode _ tos  <<store condition code>>                             07810000
   end;                                                                 07815000
$page "CLEANUSL"                                               <<00207>>07820000
integer procedure cleanusl(uslfile,filename);                  <<00207>>07825000
   value uslfile;                                              <<00207>>07830000
   integer uslfile;                                            <<00207>>07835000
   byte array filename;                                        <<00207>>07840000
                                                               <<00207>>07845000
begin                                                          <<00207>>07850000
                                                               <<00207>>07855000
intrinsic freaddir,fopen,fclose,debug,print'file'info;         <<00207>>07860000
intrinsic fcontrol,fgetinfo,fwritedir,quit;                    <<00207>>07865000
integer         newusl=cleanusl;                               <<00660>>07870000
integer         recsize;                                       <<00207>>07875000
double pointer  dbl;                                           <<00207>>07880000
integer         length;                                        <<00207>>07885000
integer         nc;                                            <<00207>>07890000
integer         subl;                                          <<00207>>07895000
integer         nwc;                                           <<00207>>07900000
integer         inx;                                           <<00207>>07905000
integer         inx'prc;                                       <<00207>>07910000
integer         secl;                                          <<00207>>07915000
integer         oldsegl:=0;                                    <<00207>>07920000
integer         oldipl:=0;                                     <<00207>>07925000
integer         oldbdl:=0;                                     <<00207>>07930000
integer         oldsubl;                                       <<00207>>07935000
integer         oldsecl;                                       <<00207>>07940000
integer         nh;                                            <<00207>>07945000
integer         jinx;                                          <<00207>>07950000
double          sac;                                           <<00207>>07955000
double          sah;                                           <<00207>>07960000
logical         code'not'seen;                                 <<00207>>07965000
array           drt'buf (0: 127);                              <<00207>>07970000
array           info'buf (0: 127);                             <<00207>>07975000
array           drt'inbuf(0:1151);                             <<00207>>07980000
array           info'inbuf(0:1151);                            <<00207>>07985000
integer         offset:=0;                                     <<00207>>07990000
integer         offset1:=0;                                    <<00207>>07995000
integer         offseti:=0;                                    <<00207>>08000000
integer         offset2:=0;                                    <<00207>>08005000
equate sec'ents = %(2)0000000100101000;                        <<00649>>08010000
equate     brother = 0,                                        <<01026>>08015000
           son     = 1;                                        <<01026>>08020000
logical array   directory(0:127);                              <<00207>>08025000
double array    ddirectory(*)=directory;                       <<00207>>08030000
define          lid  =  directory#,                            <<00207>>08035000
                ne   =  directory(1)#,                         <<00207>>08040000
                dl   =  directory(2)#,                         <<00207>>08045000
                tdg  =  directory(3)#,                         <<00207>>08050000
                ndg  =  directory(4)#,                         <<00207>>08055000
                bdl  =  directory(5)#,                         <<00207>>08060000
                ipl  =  directory(6)#,                         <<00207>>08065000
                segl =  directory(7)#,                         <<00207>>08070000
                fl   = ddirectory(4)#,                         <<00207>>08075000
                saad =  directory(10)#,                        <<00207>>08080000
                adl  =  directory(11)#,                        <<00207>>08085000
                sai  = ddirectory(6)#,                         <<00207>>08090000
                il   = ddirectory(7)#,                         <<00207>>08095000
                il2  =  directory(15)#,                        <<00207>>08100000
                saai = ddirectory(8)#,                         <<00207>>08105000
                ail  = ddirectory(9)#,                         <<00207>>08110000
                tig  = ddirectory(10)#,                        <<00207>>08115000
                nig  =  directory(22)#;                        <<00207>>08120000
                                                               <<00207>>08125000
logical array directoryn(0:127);                               <<00207>>08130000
double array  ddirectoryn(*)=directoryn;                       <<00207>>08135000
define        n'lid  =  directoryn#,                           <<00207>>08140000
              n'ne   =  directoryn(1)#,                        <<00207>>08145000
              n'dl   =  directoryn(2)#,                        <<00207>>08150000
              n'tdg  =  directoryn(3)#,                        <<00207>>08155000
              n'ndg  =  directoryn(4)#,                        <<00207>>08160000
              n'bdl  =  directoryn(5)#,                        <<00207>>08165000
              n'ipl  =  directoryn(6)#,                        <<00207>>08170000
              n'segl =  directoryn(7)#,                        <<00207>>08175000
              n'fl   = ddirectoryn(4)#,                        <<00207>>08180000
              n'saad =  directoryn(10)#,                       <<00207>>08185000
              n'adl  =  directoryn(11)#,                       <<00207>>08190000
              n'sai  = ddirectoryn(6)#,                        <<00207>>08195000
              n'il   = ddirectoryn(7)#,                        <<00207>>08200000
              n'il2  =  directoryn(15)#,                       <<00207>>08205000
              n'saai = ddirectoryn(8)#,                        <<00207>>08210000
              n'ail  = ddirectoryn(9)#,                        <<00207>>08215000
              n'tig  = ddirectoryn(10)#,                       <<00207>>08220000
              n'nig  =  directoryn(22)#;                       <<00207>>08225000
array           hl(*)=directoryn(33);                          <<00207>>08230000
                                                               <<00207>>08235000
byte pointer    name;                                          <<00207>>08240000
double          dkey;                                          <<00207>>08245000
byte array      key(*)=dkey;                                   <<00207>>08250000
integer         xreg=x;                                        <<00207>>08255000
integer         i;                                             <<00207>>08260000
integer         j;                                             <<00207>>08265000
integer         p;                                             <<00207>>08270000
double          recnum;  <<current record number>>             <<00207>>08275000
integer         index;  <<word position in record>>            <<00207>>08280000
double          recordnum;                                     <<00207>>08285000
integer         size;                                          <<00207>>08290000
double          codeinx;                                       <<00207>>08295000
double          oldrecnum;                                     <<00207>>08300000
double          hednum;  <<variable header number in file>>    <<00207>>08305000
integer         numextents;                                    <<00207>>08310000
integer         fopt;                                          <<00660>>08315000
define  newpass  = fopt.(10:3) = 2 #,                          <<00660>>08320000
        oldpass  = fopt.(10:3) = 3 #;                          <<00660>>08325000
byte array      newname(0:9);                                  <<00660>>08330000
$page "USLCLEAN  -  ERROR"                                     <<00207>>08335000
subroutine error(errnum);                                      <<00207>>08340000
  value errnum;                                                <<00207>>08345000
  integer errnum;                                              <<00207>>08350000
begin                                                          <<00207>>08355000
                                                               <<00207>>08360000
  cleanusl:=errnum;   <<return error number to caller>>        <<00207>>08365000
  condcode:=ccl;      <<set condition code>>                   <<00207>>08370000
  assemble (exit 2);  <<exit from procedure>>                  <<00207>>08375000
end;                                                           <<00207>>08380000
$page  "USLCLEAN  -  FETCH'ENTRY"                              <<00207>>08385000
subroutine fetch'entry(recnum,buf);                            <<00207>>08390000
  value recnum;                                                <<00207>>08395000
  double recnum;                                               <<00207>>08400000
  logical array buf;                                           <<00207>>08405000
                                                               <<00207>>08410000
begin                                                          <<00207>>08415000
                                                               <<00207>>08420000
                                                               <<00207>>08425000
                                                               <<00207>>08430000
  recordnum:=recnum&dasr(7);                                   <<00207>>08435000
  i:=integer(recnum - recordnum&dasl(7));                      <<00207>>08440000
                                                               <<00207>>08445000
  freaddir(uslfile,buf,128,recordnum);  <<get a record>>       <<00207>>08450000
  if <> then error(if > then err0 else err1);                  <<00207>>08455000
  length:=buf(i).(1:10);  <<number of words in it>>            <<00207>>08460000
                                                               <<00207>>08465000
  if i>0 then                                                  <<00207>>08470000
  begin                                                        <<00207>>08475000
    j:=(if length < 128-i then length else 128-i);             <<00207>>08480000
    move buf:=buf(i),(j);                                      <<00207>>08485000
    if length>j then                                           <<00207>>08490000
     begin      <<get the rest>>                               <<00207>>08495000
       freaddir(uslfile,buf(j),length-j,recordnum+1d);         <<00207>>08500000
       if <> then error(if > then err0 else err1);             <<00207>>08505000
     end;                                                      <<00207>>08510000
  end                                                          <<00207>>08515000
 else                                                          <<00207>>08520000
   if length>128 then                                          <<00207>>08525000
     begin                                                     <<00207>>08530000
       freaddir(uslfile,buf(128),length-128,recordnum+1d);     <<00207>>08535000
       if <> then error(if > then err0 else err1);             <<00207>>08540000
     end;                                                      <<00207>>08545000
end;                                                           <<00207>>08550000
$page "USLCLEAN  -  DUMP'DRT"                                  <<00207>>08555000
subroutine dump'drt;                                           <<00207>>08560000
                                                               <<00207>>08565000
begin     <<copy directory entry from old usl to new usl>>     <<00207>>08570000
  n'ne:=n'ne+1;                                                <<00207>>08575000
  length:=drt'inbuf.(1:10);                                    <<00207>>08580000
  offset1:=0;                                                  <<00207>>08585000
loop:                                                          <<00207>>08590000
  if (128-offset)>length then                                  <<00207>>08595000
    begin                                                      <<00207>>08600000
      move drt'buf(offset):=drt'inbuf(offset1),(length);       <<00207>>08605000
      offset:=offset+length;                                   <<00207>>08610000
      n'saad:=integer(n'saad)+length;                          <<00207>>08615000
    end                                                        <<00207>>08620000
  else                                                         <<00207>>08625000
    begin                                                      <<00207>>08630000
    move drt'buf(offset):=drt'inbuf(offset1),                  <<00207>>08635000
    (i:=if (128-offset)>length then length else (128-offset)); <<00207>>08640000
      length:=length-i;                                        <<00207>>08645000
      offset1:=offset1+i;                                      <<00207>>08650000
      fwritedir(newusl,drt'buf,128,double(n'saad&asr(7)));     <<00207>>08655000
      if <> then error(if > then err0 else err1);              <<00207>>08660000
      n'saad:=integer(n'saad)+i;                               <<00207>>08665000
      offset:=0;                                               <<00207>>08670000
      if length>0 then go to loop;                             <<00207>>08675000
    end;                                                       <<00207>>08680000
end;                                                           <<00207>>08685000
$page "USLCLEAN  -  DUMP'INFO"                                 <<00207>>08690000
subroutine dump'info(len);                                     <<00207>>08695000
  value len;                                                   <<00207>>08700000
  integer len;                                                 <<00207>>08705000
begin     <<copy information form new usl to old usl>>         <<00207>>08710000
  offset2:=0;                                                  <<00207>>08715000
loop:                                                          <<00207>>08720000
  if (128-offseti)>len then                                    <<00207>>08725000
    begin                                                      <<00207>>08730000
      move info'buf(offseti):=info'inbuf(offset2),(len);       <<00207>>08735000
      offseti:=offseti+len;                                    <<00207>>08740000
      n'saai:=n'saai+double(len);                              <<00207>>08745000
    end                                                        <<00207>>08750000
  else                                                         <<00207>>08755000
    begin                                                      <<00207>>08760000
      move info'buf(offseti):=info'inbuf(offset2),             <<00207>>08765000
       (i:=if (128-offseti)>len then len else (128-offseti));  <<00207>>08770000
      len:=len-i;                                              <<00207>>08775000
      offset2:=offset2+i;                                      <<00207>>08780000
      fwritedir(newusl,info'buf,128,(n'saai&dasr(7)));         <<00207>>08785000
      if <> then error(if > then err0 else err1);              <<00207>>08790000
      n'saai:=n'saai+double(i);                                <<00207>>08795000
      offseti:=0;                                              <<00207>>08800000
      if len>0 then go to loop;                                <<00207>>08805000
    end;                                                       <<00207>>08810000
end;                                                           <<00207>>08815000
$page "USLCLEAN  -  FIXUP"                                     <<00207>>08820000
subroutine fixup(old,family);                                  <<01026>>08825000
  value old,family;                                            <<01026>>08830000
  integer old,family;                                          <<01026>>08835000
    begin<<not first segment, procedure or secondary entry>>   <<00207>>08840000
      if old.(0:9)=integer(n'saad.(0:9)) then                  <<00207>>08845000
        begin                                                  <<00207>>08850000
          i:=old.(9:7);                                        <<00207>>08855000
          i:=i+integer(drt'buf(i+2).(4:4))/2+3;                <<00207>>08860000
          if family = brother then                             <<01026>>08865000
             drt'buf(i) := n'saad                              <<01026>>08870000
          else                                                 <<01026>>08875000
             drt'buf(i+1) := logical(old) lor %100000;         <<01026>>08880000
        end                                                    <<00207>>08885000
      else                                                     <<00207>>08890000
        begin                                                  <<00207>>08895000
          fwritedir(newusl,drt'buf,128,double(n'saad&asr(7))); <<00207>>08900000
          if <> then error(if > then err0 else err1);          <<00207>>08905000
          freaddir(newusl,info'inbuf,256,double(old&asr(7)));  <<00207>>08910000
          if <> then error(if > then err0 else err1);          <<00207>>08915000
          i:=old.(9:7);                                        <<00207>>08920000
          i:=i+integer(info'inbuf(i+2).(4:4))/2+3;             <<00207>>08925000
          if family = brother then                             <<01026>>08930000
             info'inbuf(i) := n'saad                           <<01026>>08935000
          else                                                 <<01026>>08940000
             info'inbuf(i+1) := logical(old) lor %100000;      <<01026>>08945000
          fwritedir(newusl,info'inbuf,256,double(old&asr(7))); <<00207>>08950000
          if <> then error(if > then err0 else err1);          <<00207>>08955000
          <<refresh the drt'buf>>                              <<00207>>08960000
          freaddir(newusl,drt'buf,128,double(n'saad&asr(7)));  <<00207>>08965000
          if <> then error(if > then err0 else err1);          <<00207>>08970000
        end;                                                   <<00207>>08975000
    end;                                                       <<00207>>08980000
$page "USLCLEAN  -  DUMP'CODE"                                 <<00207>>08985000
subroutine dump'code(start,length);                            <<00207>>08990000
  value start,length;                                          <<00207>>08995000
  double start;                                                <<00207>>09000000
  integer length;                                              <<00207>>09005000
                                                               <<00207>>09010000
begin     <<copy code form old usl to new usl>>                <<00207>>09015000
                                                               <<00207>>09020000
                                                               <<00207>>09025000
                                                               <<00207>>09030000
                                                               <<00207>>09035000
  recnum:=start&dasr(7);    <<record number>>                  <<00207>>09040000
  index:=integer(start - recnum&dasl(7));  <<word index>>      <<00207>>09045000
                                                               <<00207>>09050000
  freaddir(uslfile,info'inbuf,128,recnum);                     <<00207>>09055000
  if <> then error(if > then err0 else err1);                  <<00207>>09060000
  if length<=128-index then                                    <<00207>>09065000
    begin                                                      <<00207>>09070000
      move info'inbuf:=info'inbuf(index),(128-index);          <<00207>>09075000
      dump'info(length);                                       <<00207>>09080000
    end                                                        <<00207>>09085000
  else   <<have to get more>>                                  <<00207>>09090000
    begin                                                      <<00207>>09095000
    j:=0;                                                      <<00207>>09100000
l:                                                             <<00207>>09105000
      j:=if length<128 then length else 128;                   <<00207>>09110000
      length:=length-(128-index);                              <<00207>>09115000
      move info'inbuf:=info'inbuf(index),(128-index);          <<00207>>09120000
      if length>0 then                                         <<00207>>09125000
        begin                                                  <<00207>>09130000
          freaddir(uslfile,info'inbuf(128-index),index,        <<00207>>09135000
                  (recnum:=recnum+1d));                        <<00207>>09140000
          if <> then error(if > then err0 else err1);          <<00207>>09145000
          length:=length-index;                                <<00207>>09150000
        end;                                                   <<00207>>09155000
      dump'info(j);                                            <<00207>>09160000
      if length>0 then                                         <<00207>>09165000
        begin                                                  <<00207>>09170000
          freaddir(uslfile,info'inbuf,128,recnum);             <<00207>>09175000
          if <> then error(if > then err0 else err1);          <<00207>>09180000
          go to l;                                             <<00207>>09185000
        end;                                                   <<00207>>09190000
    end;                                                       <<00207>>09195000
end;  <<subroutine dump'code>>                                 <<00207>>09200000
$page "USLCLEAN  -  SET'HL"                                    <<00207>>09205000
subroutine set'hl;                                             <<00207>>09210000
begin     <<calculate hask link>>                              <<00207>>09215000
                                                               <<00207>>09220000
  @name:=@drt'inbuf(2)&lsl(1);                                 <<00207>>09225000
  length:=name.(12:4);                                         <<00207>>09230000
  key:=length;                                                 <<00207>>09235000
  key(1):=name(1);                                             <<00207>>09240000
  key(2):=if length>1 then name(length-1) else length;         <<00207>>09245000
  key(3):=name(length);                                        <<00207>>09250000
  i:=integer(dkey-95d*(dkey/95d));                             <<00207>>09255000
                                                               <<00207>>09260000
  if hl(i)=0 then                                              <<00207>>09265000
    begin                                                      <<00207>>09270000
      drt'inbuf(1):=0;                                         <<00207>>09275000
      hl(i):=n'saad;                                           <<00207>>09280000
    end                                                        <<00207>>09285000
  else                                                         <<00207>>09290000
    begin                                                      <<00207>>09295000
      drt'inbuf(1):=hl(i);                                     <<00207>>09300000
      hl(i):=n'saad;                                           <<00207>>09305000
    end;                                                       <<00207>>09310000
                                                               <<00207>>09315000
end;                                                           <<00207>>09320000
$page "USLCLEAN  -  DO'HEADER"                                 <<00207>>09325000
subroutine do'header(header);                                  <<00207>>09330000
array header;                                                  <<00207>>09335000
begin                                                          <<00207>>09340000
                                                               <<00207>>09345000
  nh:=header.(1:15);                                           <<00207>>09350000
  @dbl:=@header(1);                                            <<00207>>09355000
  sah:=dbl;                                                    <<00207>>09360000
  dbl:=n'saai-n'sai;                                           <<00207>>09365000
                                                               <<00207>>09370000
  while nh>0 do                                                <<00207>>09375000
  begin                                                        <<00207>>09380000
    if sah=sac and code'not'seen then                          <<00207>>09385000
      begin                                                    <<00207>>09390000
        sah:=sah+double(nwc);  <<skip over code>>              <<00207>>09395000
        code'not'seen:=false;                                  <<00207>>09400000
      end                                                      <<00207>>09405000
    else                                                       <<00207>>09410000
      begin                                                    <<00207>>09415000
        fetch'entry((sah+sai),info'inbuf);                     <<00207>>09420000
        j:=info'inbuf.(1:10);                                  <<00207>>09425000
        dump'info(j);                                          <<00207>>09430000
        sah:=sah+double(j);                                    <<00207>>09435000
        nh:=nh-1;                                              <<00207>>09440000
      end;                                                     <<00207>>09445000
  end;                                                         <<00207>>09450000
end;                                                           <<00207>>09455000
$page  "USLCLEAN  -  DO'SEC'ENTRY"                             <<00207>>09460000
subroutine do'sec'entry;                                       <<00207>>09465000
                                                               <<00207>>09470000
begin                                                          <<00207>>09475000
  oldsecl:=0;                                                  <<00207>>09480000
                                                               <<00207>>09485000
l:                                                             <<00207>>09490000
                                                               <<00207>>09495000
  if logical(secl.(0:1)) then return;                          <<00207>>09500000
  fetch'entry(double(secl),drt'inbuf);  <<get it>>             <<00207>>09505000
  nc:=drt'inbuf(2).(4:4);                                      <<00207>>09510000
  inx:=nc/2+3;                                                 <<00207>>09515000
                                                               <<00207>>09520000
  if drt'inbuf(2).(0:1)=1 then                                 <<00207>>09525000
    begin <<inactive>>                                         <<00207>>09530000
      secl:=drt'inbuf(inx);                                    <<00207>>09535000
      go to l;                                                 <<00207>>09540000
    end;                                                       <<00207>>09545000
                                                               <<00207>>09550000
  set'hl;                                                      <<00207>>09555000
                                                               <<00207>>09560000
  secl:=drt'inbuf(inx);                                        <<00207>>09565000
  drt'inbuf(inx):=%100000 lor logical(oldsubl);                <<00207>>09570000
  if not sec'ents&csr(drt'inbuf.(11:5)) then error(illegalusl);<<00649>>09575000
                                                               <<00207>>09580000
  if oldsecl<>0 then                                           <<00207>>09585000
    fixup(oldsecl,brother);                                    <<01026>>09590000
                                                               <<00207>>09595000
  oldsecl:=n'saad;                                             <<00207>>09600000
                                                               <<00207>>09605000
  dump'drt;                                                    <<00207>>09610000
                                                               <<00207>>09615000
                                                               <<00207>>09620000
  go to l;                                                     <<00207>>09625000
end;  <<subroutine do'sec'entry>>                              <<00207>>09630000
$page  "USLCLEAN  -  DO'PROC'ENTRY"                            <<00207>>09635000
subroutine do'proc'entry;                                      <<00207>>09640000
begin                                                          <<00207>>09645000
                                                               <<00207>>09650000
  oldsubl:=0;                                                  <<00207>>09655000
                                                               <<00207>>09660000
l:                                                             <<00207>>09665000
  code'not'seen := true;                                       <<01015>>09670000
                                                               <<00207>>09675000
  if logical(subl.(0:1)) then return;                          <<00207>>09680000
  fetch'entry(double(subl),drt'inbuf);                         <<00207>>09685000
                                                               <<00207>>09690000
  nc:=drt'inbuf(2).(4:4);  <<identifier length>>               <<00207>>09695000
  inx:=nc/2+3;  <<index of subl thing>>                        <<00207>>09700000
                                                               <<00207>>09705000
  if drt'inbuf(2).(0:1)=1 then                                 <<00207>>09710000
  begin   <<inactive>>                                         <<00207>>09715000
    subl:=drt'inbuf(inx);                                      <<00207>>09720000
    go to l;                                                   <<00207>>09725000
  end;                                                         <<00207>>09730000
                                                               <<00207>>09735000
  set'hl;                                                      <<00207>>09740000
                                                               <<00207>>09745000
  if drt'inbuf.(11:5)<>2 and drt'inbuf.(11:5)<>4 then          <<00207>>09750000
     error(illegalusl);                                        <<00207>>09755000
                                                               <<00207>>09760000
                                                               <<00207>>09765000
  subl:=drt'inbuf(inx);                                        <<00207>>09770000
  secl:=drt'inbuf(inx+1);                                      <<00207>>09775000
  drt'inbuf(inx):=%100000 lor logical(oldsegl); <<new subl>>   <<00207>>09780000
  drt'inbuf(inx+1):=if drt'inbuf(inx+1).(0:1) then             <<00207>>09785000
            n'saad lor %100000  <<points to itself>>           <<00207>>09790000
          else                                                 <<00207>>09795000
            n'saad+drt'inbuf.(1:10);  <<points to first son>>  <<00207>>09800000
  @dbl:=@drt'inbuf(inx+3);      <<double sac>>                 <<00207>>09805000
  sac:=dbl;                                                    <<00207>>09810000
  nwc:=drt'inbuf(inx+5).(2:14);  <<number of words of code>>   <<00207>>09815000
  if drt'inbuf.(11:5)=4 then                                   <<00207>>09820000
  <<subroutine  block.  have to  squeeze around >>             <<00207>>09825000
      <<the parameter checking crap>>                          <<00207>>09830000
  case drt'inbuf(inx+11).(0:2) of                              <<00207>>09835000
  begin                                                        <<00207>>09840000
       jinx:=inx+12; <<no checking - no parm word>>            <<00207>>09845000
       jinx:=inx+13; <<tn present, no parm word>>              <<00207>>09850000
       jinx:=inx+13; <<tn present, no parm word>>              <<00207>>09855000
       jinx:=inx+13+integer(drt'inbuf(inx+11).(2:6));          <<00207>>09860000
  end                                                          <<00207>>09865000
 else                                                          <<00207>>09870000
  jinx:=inx+11;  <<outer block>>                               <<00207>>09875000
                                                               <<00207>>09880000
<<now jinx is index of first header section>>                  <<00207>>09885000
                                                               <<00207>>09890000
  if integer(drt'inbuf.(1:10)) > jinx then                     <<00207>>09895000
  begin  <<some header blocks exist>>                          <<00207>>09900000
p1:  <<start a loop>>                                          <<00207>>09905000
    do'header(drt'inbuf(jinx));                                <<00207>>09910000
    if drt'inbuf(jinx).(0:1)=0 then     <<nh>>                 <<00207>>09915000
    begin  <<not the last one>>                                <<00207>>09920000
      jinx:=jinx+integer(drt'inbuf(jinx).(1:15))+3;            <<00207>>09925000
      go to p1;  <<repeat the thing>>                          <<00207>>09930000
    end                                                        <<00207>>09935000
  end;                                                         <<00207>>09940000
                                                               <<00207>>09945000
  @dbl:=@drt'inbuf(inx+3);                                     <<00207>>09950000
  dbl:=n'saai-n'sai;  <<new sac>>                              <<00207>>09955000
  dump'code((sai+sac),nwc);   <<copy the code>>                <<00207>>09960000
  if oldsubl<>0 then                                           <<00207>>09965000
    fixup(oldsubl,brother);                                    <<01026>>09970000
                                                               <<00207>>09975000
  oldsubl:=n'saad;                                             <<00207>>09980000
                                                               <<00207>>09985000
  dump'drt;                                                    <<00207>>09990000
                                                               <<00207>>09995000
  if not(logical(secl).(0:1)) then << could be sons >>         <<01026>>10000000
     begin                                                     <<01026>>10005000
     tos := n'saad;                                            <<01026>>10010000
     do'sec'entry;                                             <<01026>>10015000
     if tos = n'saad then  << all sons were inactive >>        <<01026>>10020000
        fixup(oldsubl,son);                                    <<01026>>10025000
     end;                                                      <<01026>>10030000
                                                               <<01026>>10035000
  go l;                                                        <<01026>>10040000
  go to l;                                                     <<00207>>10045000
end;  <<subroutine do'proc'entry>>                             <<00207>>10050000
$page  "USLCLEAN  -  DO'SEGMENT"                               <<00207>>10055000
subroutine do'segment;                                         <<00207>>10060000
begin                                                          <<00207>>10065000
                                                               <<00207>>10070000
  if segl=0 then return;  <<no segments>>                      <<00438>>10075000
  n'segl:=n'saad;                                              <<00207>>10080000
  oldsegl:=0;                                                  <<00207>>10085000
l:                                                             <<00207>>10090000
                                                               <<00207>>10095000
  if segl = 0 then   <<no more segments>>                      <<01026>>10100000
     begin                                                     <<01026>>10105000
     if n'saad = 128 then n'segl := 0; <<no segments copied>>  <<01026>>10110000
     return;                                                   <<01026>>10115000
     end;                                                      <<01026>>10120000
  fetch'entry(double(segl),drt'inbuf); <<get segment in core>> <<00207>>10125000
  if drt'inbuf.(11:5)<>1 then error(illegalusl);<<not segmnt>> <<00207>>10130000
  nc:=drt'inbuf(2).(4:4);   <<# of characters>>                <<00207>>10135000
  inx:=nc/2+3;    <<index to segl>>                            <<00207>>10140000
  if logical(drt'inbuf(2).(0:1)) then                          <<00207>>10145000
    begin     <<inactive>>                                     <<00207>>10150000
      segl:=drt'inbuf(inx);                                    <<00207>>10155000
      go to l;  <<go get next segment>>                        <<00207>>10160000
    end;                                                       <<00207>>10165000
                                                               <<00207>>10170000
  set'hl;                                                      <<00207>>10175000
                                                               <<00207>>10180000
  subl:=drt'inbuf(inx+1);  <<first procedure entry>>           <<00207>>10185000
  segl:=drt'inbuf(inx);    <<next segment>>                    <<00207>>10190000
  drt'inbuf(inx):=0;  <<new segl>>                             <<00207>>10195000
  drt'inbuf(inx+1):=if drt'inbuf(inx+1).(0:1) then             <<00207>>10200000
             n'saad lor %100000<<no son; points to itself>>    <<00207>>10205000
           else                                                <<00207>>10210000
             n'saad+drt'inbuf.(1:10);  <<points to first son>> <<00207>>10215000
  if oldsegl<>0 then                                           <<00207>>10220000
    fixup(oldsegl,brother);                                    <<01026>>10225000
                                                               <<00207>>10230000
  oldsegl:=n'saad;                                             <<00207>>10235000
  dump'drt;                                                    <<00207>>10240000
                                                               <<00207>>10245000
  tos := n'saad;                                               <<01026>>10250000
  do'proc'entry;                                               <<00207>>10255000
  if tos = n'saad then << no sons exist >>                     <<01026>>10260000
     fixup(oldsegl,son);                                       <<01026>>10265000
  go to l;                                                     <<00207>>10270000
end;  <<subroutine do'segment>>                                <<00207>>10275000
$page  "USLCLEAN  -  DO'INTERRUPT"                             <<00207>>10280000
subroutine do'interrupt;                                       <<00207>>10285000
begin                                                          <<00207>>10290000
                                                               <<00438>>10295000
  if ipl=0 then return;  <<no interrupt procs>>                <<00438>>10300000
  n'ipl := n'saad;                                             <<00438>>10305000
  oldipl:=0;                                                   <<00207>>10310000
l:                                                             <<00207>>10315000
  code'not'seen := true;                                       <<01015>>10320000
  if ipl=0 then return;  <<no more interrupt proc>>            <<00207>>10325000
  fetch'entry(double(ipl),drt'inbuf); <<get interrupt proc>>   <<00207>>10330000
  if drt'inbuf.(11:5)<>6 then error(illegalusl);               <<00438>>10335000
  nc:=drt'inbuf(2).(4:4);   <<# of characters>>                <<00207>>10340000
  inx:=nc/2+3;    <<index to ipl>>                             <<00207>>10345000
  if logical(drt'inbuf(2).(0:1)) then                          <<00207>>10350000
    begin     <<inactive>>                                     <<00207>>10355000
      ipl:=drt'inbuf(inx);                                     <<00207>>10360000
      go to l;  <<go get next interrupt proc>>                 <<00207>>10365000
    end;                                                       <<00207>>10370000
                                                               <<00207>>10375000
  set'hl;                                                      <<00207>>10380000
                                                               <<00207>>10385000
  ipl:=drt'inbuf(inx);    <<next interrupt proc>>              <<00207>>10390000
  drt'inbuf(inx):=0;  <<new ipl>>                              <<00207>>10395000
  @dbl:=@drt'inbuf(inx+3);      <<double sac>>                 <<00438>>10400000
  sac:=dbl;                                                    <<00438>>10405000
  nwc:=drt'inbuf(inx+5).(2:14);  <<number of words of code>>   <<00438>>10410000
  jinx:=inx+6;                                                 <<00438>>10415000
                                                               <<00438>>10420000
<<now jinx is index of first header section>>                  <<00438>>10425000
                                                               <<00438>>10430000
  if integer(drt'inbuf.(1:10)) > jinx then                     <<00438>>10435000
  begin  <<some header blocks exist>>                          <<00438>>10440000
p1:  <<start a loop>>                                          <<00438>>10445000
    do'header(drt'inbuf(jinx));                                <<00438>>10450000
    if drt'inbuf(jinx).(0:1)=0 then     <<nh>>                 <<00438>>10455000
    begin  <<not the last one>>                                <<00438>>10460000
      jinx:=jinx+integer(drt'inbuf(jinx).(1:15))+3;            <<00438>>10465000
      go to p1;  <<repeat the thing>>                          <<00438>>10470000
    end                                                        <<00438>>10475000
  end;                                                         <<00438>>10480000
                                                               <<00438>>10485000
  @dbl:=@drt'inbuf(inx+3);                                     <<00438>>10490000
  dbl:=n'saai-n'sai;  <<new sac>>                              <<00438>>10495000
  dump'code((sai+sac),nwc);   <<copy the code>>                <<00438>>10500000
  if oldipl<>0 then                                            <<00207>>10505000
    fixup(oldipl,brother);                                     <<01026>>10510000
                                                               <<00207>>10515000
  oldipl:=n'saad;                                              <<00207>>10520000
  dump'drt;                                                    <<00207>>10525000
                                                               <<00207>>10530000
  go to l;                                                     <<00207>>10535000
end;  <<subroutine do'interrupt proc>>                         <<00207>>10540000
$page  "USLCLEAN  -  DO'BLOCKDATA"                             <<00207>>10545000
subroutine do'blockdata;                                       <<00207>>10550000
begin                                                          <<00207>>10555000
                                                               <<00438>>10560000
  if bdl=0 then return;  <<no blockdata's>>                    <<00438>>10565000
  n'bdl := n'saad;                                             <<00438>>10570000
  oldbdl:=0;                                                   <<00207>>10575000
l:                                                             <<00207>>10580000
  code'not'seen := true;                                       <<01015>>10585000
  if bdl=0 then return;  <<no more blockdata>>                 <<00207>>10590000
  fetch'entry(double(bdl),drt'inbuf); <<get blockdata in core>><<00207>>10595000
  if drt'inbuf.(11:5)<>7 then error(illegalusl);               <<00438>>10600000
  nc:=drt'inbuf(2).(4:4);   <<# of characters>>                <<00207>>10605000
  inx:=nc/2+3;    <<index to bdl>>                             <<00207>>10610000
  if logical(drt'inbuf(2).(0:1)) then                          <<00207>>10615000
    begin     <<inactive>>                                     <<00207>>10620000
      bdl:=drt'inbuf(inx);                                     <<00207>>10625000
      go to l;  <<go get next blockdata>>                      <<00207>>10630000
    end;                                                       <<00207>>10635000
                                                               <<00207>>10640000
  set'hl;                                                      <<00207>>10645000
                                                               <<00207>>10650000
  bdl:=drt'inbuf(inx);    <<next blockdata>>                   <<00207>>10655000
  drt'inbuf(inx):=0;  <<new bdl>>                              <<00207>>10660000
                                                               <<00438>>10665000
  jinx:=inx+2;                                                 <<00438>>10670000
  while integer(drt'inbuf.(1:10)) > jinx do                    <<00438>>10675000
     begin                                                     <<00438>>10680000
     jinx := jinx+integer(drt'inbuf(jinx).(4:3))+1;            <<00438>>10685000
p1:                                                            <<00438>>10690000
     do'header(drt'inbuf(jinx));                               <<00438>>10695000
     if drt'inbuf(jinx).(0:1) = 0 then                         <<00438>>10700000
        begin                                                  <<00438>>10705000
        jinx := jinx+integer(drt'inbuf(jinx).(1:15))+3;        <<00438>>10710000
        go p1;                                                 <<00438>>10715000
        end;                                                   <<00438>>10720000
     jinx := jinx+integer(drt'inbuf(jinx).(1:15))+4;           <<00438>>10725000
     end;                                                      <<00438>>10730000
                                                               <<00438>>10735000
  if oldbdl<>0 then                                            <<00207>>10740000
    fixup(oldbdl,brother);                                     <<01026>>10745000
                                                               <<00207>>10750000
  oldbdl:=n'saad;                                              <<00207>>10755000
  dump'drt;                                                    <<00207>>10760000
                                                               <<00207>>10765000
  go to l;                                                     <<00207>>10770000
end;  <<subroutine do'blockdata>>                              <<00207>>10775000
$page   "USLCLEAN"                                             <<00207>>10780000
chek([10/85,6/2],[8/0,2/1,1/0,5/2],[2/3,2/0]d);                <<00207>>10785000
freaddir(uslfile,directory,128,0d);  <<get directory>>         <<00207>>10790000
if <> then error((if < then err1 else err0));                  <<00207>>10795000
fgetinfo(uslfile,,fopt,,,,,,,,,,,,,,,numextents);              <<00660>>10800000
if <> then error((if < then err1 else err0));                  <<00207>>10805000
assemble( zero ); <<room for result of fopen>>                 <<00660>>10810000
if oldpass and filename = " " or                               <<00660>>10815000
   filename = "$OLDPASS" then                                  <<00660>>10820000
   begin                                                       <<00660>>10825000
   move newname := "$NEWPASS ";                                <<00660>>10830000
   tos := @newname;                                            <<00660>>10835000
   end                                                         <<00660>>10840000
else                                                           <<00660>>10845000
   tos := @filename;                                           <<00660>>10850000
                                                               <<00207>>10855000
newusl:=fopen(*,0,%424,128,,,,,,fl&dlsr(7),numextents,,        <<00660>>10860000
      uslfilecode);                                            <<00438>>10865000
if < then error(err7);                                         <<00207>>10870000
                                                               <<00207>>10875000
i:=inituslf(newusl,directoryn);                                <<00207>>10880000
if <> then error(i);                                           <<00207>>10885000
                                                               <<00207>>10890000
n'saai:=n'sai:=sai;                                            <<00207>>10895000
                                                               <<00207>>10900000
fwritedir(newusl,info'buf,128,(n'sai&dasr(7)));                <<00207>>10905000
if <> then error((if < then err1 else err0));                  <<00207>>10910000
                                                               <<00207>>10915000
<<now go down the segments>>                                   <<00207>>10920000
                                                               <<00207>>10925000
do'segment;                                                    <<00207>>10930000
do'blockdata;                                                  <<00438>>10935000
do'interrupt;                                                  <<00438>>10940000
                                                               <<00207>>10945000
                                                               <<00207>>10950000
n'dl:=n'saad-%200;                                             <<00207>>10955000
n'adl:=logical(n'sai)-n'saad;                                  <<00207>>10960000
n'il:=n'saai-n'sai;                                            <<00207>>10965000
n'ail:=n'fl-n'saai;                                            <<00207>>10970000
                                                               <<00207>>10975000
<<write out new record zero>>                                  <<00207>>10980000
fwritedir(newusl,directoryn,128,0d);                           <<00207>>10985000
if <> then error((if < then err1 else err0));                  <<00207>>10990000
                                                               <<00207>>10995000
<<flush directory buffer>>                                     <<00207>>11000000
fwritedir(newusl,drt'buf,128,double(n'saad&asr(7)));           <<00207>>11005000
if <> then error((if < then err1 else err0));                  <<00207>>11010000
                                                               <<00207>>11015000
<<flush information buffer>>                                   <<00207>>11020000
fwritedir(newusl,info'buf,128,(n'saai&dasr(7)));               <<00207>>11025000
if <> then error((if < then err1 else err0));                  <<00207>>11030000
                                                               <<00207>>11035000
                                                               <<00207>>11040000
condcode:=cce;                                                 <<00207>>11045000
end;  <<procedure cleanusl>>                                   <<00207>>11050000
$page "GENERAL-PURPOSE UTILITY PROCEDURES - NAMENUMCH"                  11055000
integer procedure namenumch(nameblock);                                 11060000
                                                                        11065000
   byte array nameblock;                                                11070000
                                                                        11075000
<<------------------------------------------------------------->>       11080000
<<                                                             >>       11085000
<< this procedure returns the number of characters in a name   >>       11090000
<< stored in a name block.                                     >>       11095000
<<                                                             >>       11100000
<<------------------------------------------------------------->>       11105000
<<                                                             >>       11110000
<< input:                                                      >>       11115000
<<                                                             >>       11120000
<<    nameblock - this is the name block containing the sym-   >>       11125000
<<       bolic name whose length is to be returned.            >>       11130000
<<                                                             >>       11135000
<< procedure value:                                            >>       11140000
<<                                                             >>       11145000
<<    the number of characters in the symbolic name in the     >>       11150000
<<    name block is returned.                                  >>       11155000
<<                                                             >>       11160000
<<------------------------------------------------------------->>       11165000
                                                                        11170000
begin << namenumch >>                                                   11175000
                                                                        11180000
equate null'blank = %40;                                                11185000
                                                                        11190000
<< namenumch >>                                                         11195000
                                                                        11200000
   if nameblock.(12:4) <> 0 then                                        11205000
      namenumch := nameblock.(12:4)                                     11210000
   else                                                                 11215000
      begin                                                             11220000
      scan nameblock(1) until null'blank, 1;                            11225000
      namenumch := tos - @nameblock(1);                                 11230000
      end;                                                              11235000
                                                                        11240000
end; << namenumch >>                                                    11245000
$page "GENERAL-PURPOSE UTILITY PROCEDURES - NAMESMATCH"                 11250000
logical procedure namesmatch(nameblock1, nameblock2);                   11255000
                                                                        11260000
   byte array nameblock1;                                               11265000
   byte array nameblock2;                                               11270000
                                                                        11275000
<<------------------------------------------------------------->>       11280000
<<                                                             >>       11285000
<< this procedure compares the strings in two name blocks for  >>       11290000
<< equality.                                                   >>       11295000
<<                                                             >>       11300000
<<------------------------------------------------------------->>       11305000
<<                                                             >>       11310000
<< input:                                                      >>       11315000
<<                                                             >>       11320000
<<    nameblock1 - this is a name block containing the first   >>       11325000
<<       symbolic name to be compared.                         >>       11330000
<<                                                             >>       11335000
<<    nameblock2 - this is a name block containing the second  >>       11340000
<<       symbolic name to be compared.                         >>       11345000
<<                                                             >>       11350000
<< procedure value:                                            >>       11355000
<<                                                             >>       11360000
<<    if the symbolic names are equal, true is returned;       >>       11365000
<<    otherwise, false is returned.                            >>       11370000
<<                                                             >>       11375000
<<------------------------------------------------------------->>       11380000
                                                                        11385000
begin << namesmatch >>                                                  11390000
                                                                        11395000
integer len1;                                                           11400000
integer len2;                                                           11405000
                                                                        11410000
<< namesmatch >>                                                        11415000
                                                                        11420000
   len1 := namenumch(nameblock1);                                       11425000
   len2 := namenumch(nameblock2);                                       11430000
   if len1 = len2 then                                                  11435000
      namesmatch := (nameblock1(1) = nameblock2(1), (len1))             11440000
   else                                                                 11445000
      namesmatch := false;                                              11450000
                                                                        11455000
end; << namesmatch >>                                                   11460000
$page "GENERAL PURPOSE UTILITY PROCEDURE - BUILDNAMEBLOCK"              11465000
procedure buildnameblock(nameblock, nameblocklen,                       11470000
                         string, stringlen, status);                    11475000
                                                                        11480000
   value nameblocklen, stringlen;                                       11485000
   integer nameblocklen, stringlen, status;                             11490000
   byte array nameblock, string;                                        11495000
   option variable;                                                     11500000
                                                                        11505000
<< this procedure format string into nameblock        >>                11510000
<<    nameblocklen specifies the length of nameblock  >>                11515000
<<    to be returned.                                 >>                11520000
<<    stringlen specifies the length of string to be  >>                11525000
<<    formated, if not specified then string is ter-  >>                11530000
<<    minated by a blank.                             >>                11535000
<<    status returned :                               >>                11540000
<<      = 0   formated ok                             >>                11545000
<<      = 101 name truncated because stringlen        >>                11550000
<<            specified smaller than the length of    >>                11555000
<<            string                                  >>                11560000
<<      = 102 name truncated because nameblocklen     >>                11565000
<<            specified too small                     >>                11570000
<<      = 103 illegal parameters, only stringlen is   >>                11575000
<<            optional                                >>                11580000
begin                                                                   11585000
   integer numch;  << number of characters to be moved >>               11590000
   logical parms = q-4;                                                 11595000
   logical parmsmap := %(2)11101;                                       11600000
                                                                        11605000
   if (parms land parmsmap) <> parmsmap then                            11610000
      begin                                                             11615000
         status:=103;                                                   11620000
         return;                                                        11625000
      end;                                                              11630000
   status:=0;                                                           11635000
   numch:=0;                                                            11640000
   if parms.(14:1) = 0 then                                             11645000
      stringlen:=%77777;                                                11650000
   while numch < stringlen and string(numch) <> " " do                  11655000
      numch:=numch+1;                                                   11660000
   if numch = stringlen and not (string(numch) = " ")                   11665000
      then status:=101;                                                 11670000
   if numch > 15 and numch > nameblocklen-2 then                        11675000
      begin                                                             11680000
         numch := nameblocklen - 2;                                     11685000
         status:=102;                                                   11690000
      end;                                                              11695000
   if numch <= 15 and numch > nameblocklen-1 then                       11700000
      begin                                                             11705000
         numch := nameblocklen - 1;                                     11710000
         status:=102;                                                   11715000
      end;                                                              11720000
   if numch <= 15 then                                                  11725000
      nameblock := numch                                                11730000
   else                                                                 11735000
      move nameblock(numch+1) := " ";                                   11740000
   move nameblock(1):=string,(numch);                                   11745000
end;                                                                    11750000
$page "FEOF"                                                            11755000
integer procedure feof(fnum);                                           11760000
value fnum;                                                             11765000
integer fnum;                                                           11770000
begin                                                                   11775000
   tos:=0d;                                                             11780000
   fgetinfo(fnum,,,,,,,,,,ds1);                                         11785000
   feof:=tos;                                                           11790000
end;                                                                    11795000
$page "GENERAL PURPOSE UTILITY PROCEDURES - FREADMR"                    11800000
procedure freadmr(fnum,target,count,recnum,status);                     11805000
                                                                        11810000
value fnum,count,recnum;                                                11815000
integer fnum,count,recnum,status;                                       11820000
integer array target;                                                   11825000
                                                                        11830000
begin                                                                   11835000
   freaddir(fnum,target,count,double(recnum));                          11840000
   if > then                                                            11845000
      begin                                                             11850000
         count := (feof(fnum)-recnum)&lsl(7);                           11855000
         freaddir(fnum,target,count,double(recnum));                    11860000
      end;                                                              11865000
   checkipmapio;                                                        11870000
end;                                                                    11875000
$page "GENERAL PURPOES UTILITY PROCEDURE - FWRITEMR"                    11880000
procedure fwritemr(fnum,target,count,recnum,status);                    11885000
                                                                        11890000
value fnum,count,recnum;                                                11895000
integer fnum,count,recnum,status;                                       11900000
integer array target;                                                   11905000
                                                                        11910000
begin                                                                   11915000
   fwritedir(fnum,target,count,double(recnum));                         11920000
   if > then                                                            11925000
      begin                                                             11930000
         count := (feof(fnum)-recnum)&lsl(7);                           11935000
         fwritedir(fnum,target,count,double(recnum));                   11940000
      end;                                                              11945000
   checkipmapio;                                                        11950000
end;                                                                    11955000
$page "GENERAL-PURPOSE UTILITY PROCEDURES - HASH"                       11960000
integer procedure hash(symname, symnamelen);                            11965000
                                                                        11970000
   value symnamelen;                                                    11975000
                                                                        11980000
   byte    array symname;         << symbolic name to hash >>           11985000
   integer       symnamelen;      << length of symbolic name >>         11990000
                                                                        11995000
   option internal;                                                     12000000
                                                                        12005000
<<------------------------------------------------------------->>       12010000
<<                                                             >>       12015000
<< this function returns the value of the segmenter hash func- >>       12020000
<< tion as applied to the symbolic name 'symname'.  the length >>       12025000
<< of the name as passed in 'symnamelen' is assumed to be cor- >>       12030000
<< rect, and the name itself is assumed to be valid.           >>       12035000
<<                                                             >>       12040000
<< input:                                                      >>       12045000
<<                                                             >>       12050000
<<    symname - this is a byte array containing the symbolic   >>       12055000
<<       name to be hashed.  the first byte in this array is   >>       12060000
<<       assumed to be the first character of the name (and    >>       12065000
<<       not the "length byte," as in some implementations),   >>       12070000
<<       and the name itself is assumed to be valid (no spe-   >>       12075000
<<       cial characters, 1st character alphabetic).  upper/   >>       12080000
<<       lower-case is not significant.                        >>       12085000
<<                                                             >>       12090000
<<    symnamelen - this is the number of characters in the     >>       12095000
<<       symbolic name.  it is assumed to be in the range      >>       12100000
<<       [1, 15].                                              >>       12105000
<<                                                             >>       12110000
<< procedure value:                                            >>       12115000
<<                                                             >>       12120000
<<    the value of the hash function is returned.  it will be  >>       12125000
<<    in the range [0, 94].                                    >>       12130000
<<                                                             >>       12135000
<<------------------------------------------------------------->>       12140000
<<                                                             >>       12145000
<< algorithm:                                                  >>       12150000
<<                                                             >>       12155000
<< first, a doubleword integer is constructed from 4 bytes as  >>       12160000
<< follows:                                                    >>       12165000
<<                                                             >>       12170000
<<    byte 0 - binary number of characters in the name.        >>       12175000
<<    byte 1 - first character of the name.                    >>       12180000
<<    byte 2 - second-to-last character of the name.           >>       12185000
<<    byte 3 - last character of the name.                     >>       12190000
<<                                                             >>       12195000
<< for one-word names, bytes 2 and 3 will be the same as bytes >>       12200000
<< 0 and 1.                                                    >>       12205000
<<                                                             >>       12210000
<< next, the doubleword is treated as a binary integer (always >>       12215000
<< positive due to the maximum name length), and the value of  >>       12220000
<< the hash function is this number modulo 95.                 >>       12225000
<<                                                             >>       12230000
<<------------------------------------------------------------->>       12235000
$page                                                                   12240000
begin << hash >>                                                        12245000
                                                                        12250000
double  foldedname;               << folded name >>                     12255000
logical word0 = foldedname;       << word 0 of the coded name >>        12260000
logical word1 = foldedname + 1;   << word 1 of the coded name >>        12265000
                                                                        12270000
<<------------------------------------------------------------->>       12275000
                                                                        12280000
<< hash >>                                                              12285000
                                                                        12290000
   word0 := logical(symnamelen) & lsl(8) lor                            12295000
            logical(integer(symname));                                  12300000
   if symnamelen = 1 then                                               12305000
      word1 := word0                                                    12310000
   else                                                                 12315000
      word1 := logical(integer(symname(symnamelen - 2))) &              12320000
               lsl(8) lor                                               12325000
               logical(integer(symname(symnamelen - 1)));               12330000
   turnofftraps;                                                        12335000
   hash := foldedname modd 95;                                          12340000
                                                                        12345000
end; << hash >>                                                         12350000
$page "GENERAL-PURPOSE UTILITY PROCEDURES - GETDRECOFFSET"              12355000
procedure getdrecoffset(wordaddr, drecnum, drecoffset);                 12360000
                                                                        12365000
   value wordaddr;                                                      12370000
                                                                        12375000
   double  wordaddr;              << file address to convert >>         12380000
   integer drecnum;               << disc file record number >>         12385000
   integer drecoffset;            << disc record word offset >>         12390000
                                                                        12395000
   option internal;                                                     12400000
                                                                        12405000
<<------------------------------------------------------------->>       12410000
<<                                                             >>       12415000
<< this procedure converts word addresses for disc files       >>       12420000
<< treated as word streams into a disc record number and word  >>       12425000
<< offset.                                                     >>       12430000
<<                                                             >>       12435000
<<------------------------------------------------------------->>       12440000
<<                                                             >>       12445000
<< input:                                                      >>       12450000
<<                                                             >>       12455000
<<    wordaddr - this is the disc file word address to be con- >>       12460000
<<       verted.                                               >>       12465000
<<                                                             >>       12470000
<< output:                                                     >>       12475000
<<                                                             >>       12480000
<<    drecnum - this is the number of the disc file record     >>       12485000
<<       containing the word addressed by wordaddr.            >>       12490000
<<                                                             >>       12495000
<<    drecoffset - this is the word offset in record drecnum   >>       12500000
<<       to the word addressed by wordaddr.                    >>       12505000
<<                                                             >>       12510000
<<------------------------------------------------------------->>       12515000
                                                                        12520000
begin << getdrecoffset >>                                               12525000
                                                                        12530000
   drecnum    := wordaddr // drecnumwds;                                12535000
   drecoffset := wordaddr modd drecnumwds;                              12540000
                                                                        12545000
end; << getdrecoffset >>                                                12550000
$page "GENERAL-PURPOSE UTILITY PROCEDURES - MAPSLDIRENT"                12555000
procedure mapsldirent(sldirentry, sldirentp, sldirentbp,                12560000
                      sldirentp1,len);                                  12565000
                                                                        12570000
   integer array   sldirentry;    << entry to be mapped >>              12575000
   integer pointer sldirentp;     << 1st word of directory ent >>       12580000
   byte pointer    sldirentbp;                                          12585000
   integer pointer sldirentp1;    << 1st word after name >>             12590000
   integer         len;           << length of entry returned >>        12595000
                                                                        12600000
   option internal;                                                     12605000
                                                                        12610000
<<------------------------------------------------------------->>       12615000
<<                                                             >>       12620000
<< this procedure initializes the pointers required to sym-    >>       12625000
<< bolically access fields in a particular sl entry point      >>       12630000
<< directory entry, and also returns the length of the entry.  >>       12635000
<< see the field definitions for the sl file entry point       >>       12640000
<< directory entry in the global declarations for complete     >>       12645000
<< details on the use of these pointers.                       >>       12650000
<<                                                             >>       12655000
<<------------------------------------------------------------->>       12660000
<<                                                             >>       12665000
<< input:                                                      >>       12670000
<<                                                             >>       12675000
<<    sldirentry - this is an integer array containing the     >>       12680000
<<       directory entry to be mapped.  the entry is assumed   >>       12685000
<<       to begin at the first word of the array.              >>       12690000
<<                                                             >>       12695000
<< output:                                                     >>       12700000
<<                                                             >>       12705000
<<    sldirentp - this is an integer pointer to the first word >>       12710000
<<       of the directory entry.                               >>       12715000
<<                                                             >>       12720000
<<    sldirentp1 - this is an integer pointer to the first     >>       12725000
<<       word after the name field in the directory entry.     >>       12730000
<<                                                             >>       12735000
<<    len - this is the number of words used by the directory  >>       12740000
<<       entry.                                                >>       12745000
<<                                                             >>       12750000
<<------------------------------------------------------------->>       12755000
$page                                                                   12760000
begin << mapsldirent >>                                                 12765000
                                                                        12770000
integer pointer parmdesc;         << directory entry parm desc >>       12775000
byte array sldirentryb(*)=sldirentry;                                   12780000
                                                                        12785000
<< mapsldirent >>                                                       12790000
                                                                        12795000
   << load the pointers. >>                                             12800000
                                                                        12805000
   @sldirentp  := @sldirentry;                                          12810000
   @sldirentbp := @sldirentry & lsl(1);                                 12815000
   @sldirentp1 := @sldirentp + namenumch(sldirentryb) / 2 + 1;          12820000
                                                                        12825000
   << calculate the entry length. >>                                    12830000
                                                                        12835000
   @parmdesc := @sldirent'parmdesc;                                     12840000
   case parmdesc(pda'checklevel) of                                     12845000
      begin                                                             12850000
      << 0 >> len := @sldirentp1 - @sldirentp + 2;                      12855000
      << 1 >> len := @sldirentp1 - @sldirentp + 3;                      12860000
      << 2 >> len := @sldirentp1 - @sldirentp + 3;                      12865000
      << 3 >> len := @sldirentp1 - @sldirentp + 3 +                     12870000
                     parmdesc(pda'numparms);                            12875000
      end;                                                              12880000
                                                                        12885000
end; << mapsldirent >>                                                  12890000
$page "SL FILE UTILITY PROCEDURES - MAPSLREFENT"                        12895000
procedure mapslrefent(slrefentry, slrefp, slrefbp);                     12900000
   integer array   slrefentry;    << entry to be mapped >>              12905000
   integer pointer slrefp;        << 1st word of entry >>               12910000
   byte    pointer slrefbp;       << 1st byte of entry >>               12915000
                                                                        12920000
   option internal;                                                     12925000
                                                                        12930000
<<------------------------------------------------------------->>       12935000
<<                                                             >>       12940000
<< this procedure initializes the pointers required to symbol- >>       12945000
<< ically access fields in a particular sl segment reference   >>       12950000
<< table entry.  see the field definitions for sl files in the >>       12955000
<< global declarations for details on the use of these point-  >>       12960000
<< ers.                                                        >>       12965000
<<                                                             >>       12970000
<<------------------------------------------------------------->>       12975000
<<                                                             >>       12980000
<< input:                                                      >>       12985000
<<                                                             >>       12990000
<<    slrefentry - this is an integer array containing the sl  >>       12995000
<<       reference table entry to be mapped.  note that this   >>       13000000
<<       is assumed to be the first word of the entry, not the >>       13005000
<<       block containing the entry.                           >>       13010000
<<                                                             >>       13015000
<< output:                                                     >>       13020000
<<                                                             >>       13025000
<<    slrefentp - this is an integer pointer to the first word >>       13030000
<<       of the reference table entry.                         >>       13035000
<<                                                             >>       13040000
<<    slrefentbp - this is a byte pointer to the first byte of >>       13045000
<<       the reference table entry.                            >>       13050000
<<                                                             >>       13055000
<<------------------------------------------------------------->>       13060000
                                                                        13065000
begin << mapslrefent >>                                                 13070000
                                                                        13075000
<< mapslrefent >>                                                       13080000
                                                                        13085000
   @slrefp  := @slrefentry;                                             13090000
   @slrefbp := @slrefentry & lsl(1);                                    13095000
                                                                        13100000
end; << mapslrefent >>                                                  13105000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            13110000
$     "LOADIPMAPBUF"                                                    13115000
procedure loadipmapbuf(drecnum, offset, pmapcb, status);                13120000
                                                                        13125000
   value drecnum, offset;                                               13130000
   integer       drecnum;         << record part of address >>          13135000
   integer       offset;          << word part of address >>            13140000
   integer array pmapcb;          << pmap control block >>              13145000
   integer       status;          << status code returned >>            13150000
                                                                        13155000
   option internal;                                                     13160000
                                                                        13165000
<<------------------------------------------------------------->>       13170000
<<                                                             >>       13175000
<< this procedure loads pmapbuf with records drecnum and       >>       13180000
<< drecnum+1 and set pmapbufx to offset                        >>       13185000
<<                                                             >>       13190000
<<------------------------------------------------------------->>       13195000
<<                                                             >>       13200000
<< input:                                                      >>       13205000
<<                                                             >>       13210000
<<    drecnum - this is the number of the disc record from     >>       13215000
<<       which the address of the desired word(s) is to be     >>       13220000
<<       calculated.                                           >>       13225000
<<                                                             >>       13230000
<<    offset - this is the offset from the specified disc rec- >>       13235000
<<       ord number to be used to calculate the address of the >>       13240000
<<       desired word(s).                                      >>       13245000
<<                                                             >>       13250000
<<    pmapcb - this is the pmap control block as described in  >>       13255000
<<       the global declarations.  it must be initialized to   >>       13260000
<<       the extent that status of its pmap buffer is correct- >>       13265000
<<       ly represented.                                       >>       13270000
<<                                                             >>       13275000
<< output:                                                     >>       13280000
<<                                                             >>       13285000
<<    pmapcb - the pmap control block is returned with the     >>       13290000
<<       quested words present in its internal pmap buffer.    >>       13295000
<<                                                             >>       13300000
<<    status - a status code indicating any file system errors >>       13305000
<<       on the program/sl file containing the pmap is re-     >>       13310000
<<       turned.                                               >>       13315000
<<                                                             >>       13320000
<<------------------------------------------------------------->>       13325000
                                                                        13330000
begin << loadipmapbuf >>                                                13335000
   pmapcbdec;                                                           13340000
   integer i;                                                  <<06555>>13345000
   freadmr(ipmapfnum,pmapbuf,drecnumwds*2,drecnum,status);              13350000
   if status = stat'ipmapioerr then return;                             13355000
   if ipmapfilecode = slfilecode then                                   13360000
      begin                                                             13365000
         if pmapbuf > maxtypetablelen or <<check ipmap validity<<06555>>13370000
            pmapbuf < mintypetablelen then                     <<06555>>13375000
            begin                                              <<06555>>13380000
               status := stat'badipmap;                        <<06555>>13385000
               return;                                         <<06555>>13390000
            end;                                               <<06555>>13395000
         i := 1;                                               <<06555>>13400000
         while i <  pmapbuf do                                 <<06555>>13405000
            begin                                              <<06555>>13410000
               if pmapbuf(i) > ipmaprec'var'max or             <<06555>>13415000
                  pmapbuf(i) < ipmaprec'var'min then           <<06555>>13420000
                  begin                                        <<06555>>13425000
                     status := stat'badipmap;                  <<06555>>13430000
                     return;                                   <<06555>>13435000
                  end;                                         <<06555>>13440000
               i := i + 1;                                     <<06555>>13445000
            end;                                               <<06555>>13450000
         move typetable := pmapbuf,(pmapbuf);                           13455000
         pmapbufx:=typetablelen;                                        13460000
      end                                                               13465000
   else                                                                 13470000
      pmapbufx:=offset;                                                 13475000
   pmapcurdrecnum:=drecnum;                                             13480000
end; << loadipmapbuf >>                                                 13485000
$page "GENERAL-PURPOSE UTILITY PROCEDURES - MAPIPMAPREC"                13490000
procedure mapipmaprec(buffer,ipmapp,ipmapbp,ipmapp1,len,pmapcb);        13495000
                                                                        13500000
   integer array   buffer;        << int pmap rec to be mapped >>       13505000
   integer array pmapcb;                                                13510000
   integer pointer ipmapp;        << 1st word of int pmap rec >>        13515000
   byte    pointer ipmapbp;       << 1st byte of int pmap rec >>        13520000
   integer pointer ipmapp1;       << 1st word after name >>             13525000
   integer         len;           << # words in pmap record >>          13530000
                                                                        13535000
   option internal;                                                     13540000
                                                                        13545000
<<------------------------------------------------------------->>       13550000
<<                                                             >>       13555000
<< this procedure initializes the pointers required to sym-    >>       13560000
<< bolically access fields in a particular internal pmap rec-  >>       13565000
<< ord, and also returns the length of the record.  see the    >>       13570000
<< field definitions for the internal pmap record in the glo-  >>       13575000
<< bal declarations for complete details on the use of these   >>       13580000
<< pointers.                                                   >>       13585000
<<                                                             >>       13590000
<< input:                                                      >>       13595000
<<                                                             >>       13600000
<<    buffer - this is an integer array containing the inter-  >>       13605000
<<       nal pmap record to be mapped.  the record is assumed  >>       13610000
<<       to begin at the first word of the array.              >>       13615000
<<                                                             >>       13620000
<< output:                                                     >>       13625000
<<                                                             >>       13630000
<<    ipmapp - this is an integer pointer to the first word of >>       13635000
<<       the internal pmap record.                             >>       13640000
<<                                                             >>       13645000
<<    ipmapbp - this is a byte pointer to the first byte of    >>       13650000
<<       the internal pmap record.                             >>       13655000
<<                                                             >>       13660000
<<    ipmapp1 - this is an integer pointer to the first word   >>       13665000
<<       after the name field in the internal pmap record.     >>       13670000
<<                                                             >>       13675000
<<    len - this is the number of words used by the internal   >>       13680000
<<       pmap record.                                          >>       13685000
<<                                                             >>       13690000
<<------------------------------------------------------------->>       13695000
                                                                        13700000
begin << mapipmaprec >>                                                 13705000
pmapcbdec;                                                              13710000
                                                                        13715000
$page                                                                   13720000
<< mapipmaprec >>                                                       13725000
                                                                        13730000
   @ipmapp  := @buffer;                                                 13735000
   @ipmapbp := @ipmapp & lsl(1);                                        13740000
   @ipmapp1 := @ipmapp + ipmap'namenumch & lsr(1) + 1;                  13745000
   len      := @ipmapp1 - @ipmapp + typetable(ipmap'type+1);            13750000
                                                                        13755000
end; << mapipmaprec >>                                                  13760000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            13765000
$     "PMAPCBINIT"                                                      13770000
procedure pmapcbinit(progfile, pmapcb, status);                         13775000
                                                                        13780000
   value progfile;                                                      13785000
                                                                        13790000
   integer       progfile;        << program/sl file number >>          13795000
   integer array pmapcb;          << pmap control block >>              13800000
   integer       status;          << status returned >>                 13805000
                                                                        13810000
                                                                        13815000
<<------------------------------------------------------------->>       13820000
<<                                                             >>       13825000
<< this procedure first verifies that a program/sl file which  >>       13830000
<< was passed to one of the pmap intrinsics has a valid file   >>       13835000
<< code and is compatible with this version of the pmap        >>       13840000
<< intrinsics.  then the pmap control block pmapcb is par-     >>       13845000
<< tially intialized with data from the beginning of the file. >>       13850000
<<                                                             >>       13855000
<< upon return, the caller must complete initialization of the >>       13860000
<< pmap control block by calling one of the support procedures >>       13865000
<< which sts the pmap pointers to a specified segment record.  >>       13870000
<<                                                             >>       13875000
<< input:                                                      >>       13880000
<<                                                             >>       13885000
<<    progfile - this is the number of the program/sl file     >>       13890000
<<       passed to one of the pmap intrinsics.                 >>       13895000
<<                                                             >>       13900000
<< output:                                                     >>       13905000
<<                                                             >>       13910000
<<    pmapcb - this is the pmap control block as described in  >>       13915000
<<       the global declarations.  it will be returned par-    >>       13920000
<<       tially initialized.                                   >>       13925000
<<                                                             >>       13930000
<<    status - this is a status code indicating any errors de- >>       13935000
<<       tected as follows:                                    >>       13940000
<<                                                             >>       13945000
<<       ok:            no errors.                             >>       13950000
<<       badfilecode:   the file code of progfile is not that  >>       13955000
<<                      of a program or sl file.               >>       13960000
<<       nopmap:        progfile does not contain a pmap.      >>       13965000
<<       badloaderid:   the loader id in sl file progfile is   >>       13970000
<<                      not compatible with this version of    >>       13975000
<<                      of the pmap intrinsics.                >>       13980000
<<                                                             >>       13985000
<<------------------------------------------------------------->>       13990000
$page                                                                   13995000
begin << pmapcbinit >>                                                  14000000
                                                                        14005000
<< the following declarations provide access to the pmap con-  >>       14010000
<< trol block:                                                 >>       14015000
                                                                        14020000
pmapcbdec;                   << pmap control block arrays >>            14025000
                                                                        14030000
<< miscellaneous declarations: >>                                       14035000
                                                                        14040000
logical aoptions;                 << pmap file aoptions >>              14045000
integer i;                                                     <<06555>>14050000
define                                                                  14055000
   multirec = (11:1)#;                                                  14060000
$page                                                                   14065000
<< pmapcbinit >>                                                        14070000
                                                                        14075000
   << check the file code and aoptions. >>                              14080000
                                                                        14085000
   status := stat'ok;                                          <<04917>>14090000
   fgetinfo(progfile,,, aoptions,,,,, ipmapfilecode);                   14095000
   checkipmapio;                                                        14100000
   if ipmapfilecode <> progfilecode and                                 14105000
      ipmapfilecode <> slfilecode then                                  14110000
      begin                                                             14115000
      status := stat'badfilecode;                                       14120000
      return;                                                           14125000
      end;                                                              14130000
                                                                        14135000
   if not aoptions.multirec then                                        14140000
      begin                                                             14145000
      status := stat'ipmapbadfopen;                                     14150000
      return;                                                           14155000
      end;                                                              14160000
                                                                        14165000
   << miscellaneous pmap control block initialization: >>               14170000
                                                                        14175000
   ipmapfnum := progfile;                                               14180000
   pmapflags := 0;                << means pmap pointer is at  >>       14185000
                                  <<   last internal pmap rec- >>       14190000
                                  <<   ord returned, and end-  >>       14195000
                                  <<   of-pmap condition is    >>       14200000
                                  <<   cleared.                >>       14205000
   pmapcursegnum := -1;           << means initialization is   >>       14210000
                                  <<   not complete.           >>       14215000
                                                                        14220000
   << fetch info from the program/sl file header records: >>            14225000
                                                                        14230000
   if ipmapfilecode = progfilecode then                                 14235000
                                                                        14240000
      begin << process program file header records. >>                  14245000
                                                                        14250000
      << read info block from record 0. >>                              14255000
                                                                        14260000
      freaddir(progfile, pf0p, pf0'infonumwds, 0d);                     14265000
      checkipmapio;                                                     14270000
                                                                        14275000
      << check for presence of pmap in program file. >>                 14280000
                                                                        14285000
      if not pf0'zeroed or pf0'pmapdrecnum = 0 then                     14290000
         begin                                                          14295000
         status := stat'nopmap;                                         14300000
         return;                                                        14305000
         end;                                                           14310000
                                                                        14315000
      freadmr(ipmapfnum,progpmapptrsi,256+maxtypetablelen,              14320000
              pf0'pmapdrecnum,status);                                  14325000
      if status= stat'ipmapioerr then return;                           14330000
      if progpmapptrsi>maxtypetablelen or<<check ipmap validity<<06555>>14335000
         progpmapptrsi < mintypetablelen then                  <<06555>>14340000
         begin                                                 <<06555>>14345000
            status := stat'badipmap;                           <<06555>>14350000
            return;                                            <<06555>>14355000
         end;                                                  <<06555>>14360000
      i := 1;                                                  <<06555>>14365000
      while i <  progpmapptrsi do                              <<06555>>14370000
         begin                                                 <<06555>>14375000
            if progpmapptrsi(i) > ipmaprec'var'max or          <<06555>>14380000
               progpmapptrsi(i) < ipmaprec'var'min then        <<06555>>14385000
               begin                                           <<06555>>14390000
                  status := stat'badipmap;                     <<06555>>14395000
                  return;                                      <<06555>>14400000
               end;                                            <<06555>>14405000
            i := i + 1;                                        <<06555>>14410000
         end;                                                  <<06555>>14415000
      move typetable := progpmapptrsi,(progpmapptrsi);                  14420000
      if pf0'numsegs > 128 then                                         14425000
         move progpmapptrsi := progpmapptrsi(typetablelen),             14430000
                               (256)                                    14435000
      else                                                              14440000
         move progpmapptrsi := progpmapptrsi(typetablelen),             14445000
                               (pf0'numsegs*2);                         14450000
      firsthalfsegptrloaded := true;                                    14455000
                                                                        14460000
      end << process program file header records. >>                    14465000
$page                                                                   14470000
   else                                                                 14475000
      begin << process sl file header records. >>                       14480000
                                                                        14485000
      << read records 0 and 1. >>                                       14490000
                                                                        14495000
      freadmr(progfile, sl0p, drecnumwds + maxnumslrefblocks,           14500000
               0,status);                                               14505000
      if status = stat'ipmapioerr then return;                          14510000
                                                                        14515000
      << check the sl's format id. >>                                   14520000
                                                                        14525000
      if sl0'formatid > lastslformatid then                             14530000
         begin                                                          14535000
         status := stat'badloaderid;                                    14540000
         return;                                                        14545000
         end;                                                           14550000
                                                                        14555000
      end; << process sl file records 0/1. >>                           14560000
                                                                        14565000
   status := stat'ok;                                                   14570000
                                                                        14575000
end; << pmapcbinit >>                                                   14580000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            14585000
$     "LOADSLREFENT"                                                    14590000
procedure loadslrefent(reqsegnum, slrefp, slrefbp, pmapcb,              14595000
                       status);                                         14600000
                                                                        14605000
   value reqsegnum;                                                     14610000
                                                                        14615000
   integer         reqsegnum;     << requested segment number >>        14620000
   integer pointer slrefp;        << 1st word of req entry >>           14625000
   byte    pointer slrefbp;       << 1st byte of req entry >>           14630000
   integer array   pmapcb;        << pmap control block >>              14635000
   integer         status;        << status code returned >>            14640000
                                                                        14645000
   option internal;                                                     14650000
                                                                        14655000
<<------------------------------------------------------------->>       14660000
<<                                                             >>       14665000
<< this procedure loads the slrefblock buffer in the pmap con- >>       14670000
<< trol block with the sl segment reference table block con-   >>       14675000
<< taining a specified reference table entry, and returns word >>       14680000
<< and byte pointers to the entry.                             >>       14685000
<<                                                             >>       14690000
<< the variable pmapcursegnum in the pmap control block is     >>       14695000
<< used to determine if the needed block is already loaded,    >>       14700000
<< thus avoiding unnecessary disc reads.  it is updated by     >>       14705000
<< this routine, and upon entry its contents are assumed to    >>       14710000
<< accurately reflect the contents of slrefblock.              >>       14715000
<<                                                             >>       14720000
<< input:                                                      >>       14725000
<<                                                             >>       14730000
<<    reqsegnum - this is an integer specifying the number of  >>       14735000
<<       the requested segment.  it is assumed to be in the    >>       14740000
<<       range [0, pmapnumsegs - 1].                           >>       14745000
<<                                                             >>       14750000
<<    pmapcb - this is the pmap control block as described in  >>       14755000
<<       the global declarations.  prior to the first call to  >>       14760000
<<       this routine it must have been partially initialized  >>       14765000
<<       by pmapcbinit.                                        >>       14770000
<<                                                             >>       14775000
<< output:                                                     >>       14780000
<<                                                             >>       14785000
<<    slrefp - this is an integer pointer to the first word of >>       14790000
<<       the requested segment reference table entry.          >>       14795000
<<                                                             >>       14800000
<<    slrefbp - this is a byte pointer to the first byte of    >>       14805000
<<       the requested segment reference table entry.          >>       14810000
<<                                                             >>       14815000
<<    pmapcb - this is the pmap control block as described in  >>       14820000
<<       the global declarations.  it will be returned updated >>       14825000
<<       as appropriate.                                       >>       14830000
<<                                                             >>       14835000
<<    status - this is a standard pmap intrinsic error code    >>       14840000
<<       returned to indicate detection of any abnormal con-   >>       14845000
<<       dition.  any value other than 0 should be passed on   >>       14850000
<<       to the caller of the originating pmap intrinsic.      >>       14855000
<<                                                             >>       14860000
<<------------------------------------------------------------->>       14865000
$page                                                                   14870000
begin << loadslrefent >>                                                14875000
                                                                        14880000
<< the following declarations provide access to the pmap con-  >>       14885000
<< trol block:                                                 >>       14890000
                                                                        14895000
pmapcbdec;                   << pmap control block arrays >>            14900000
                                                                        14905000
<< miscellaneous variables. >>                                          14910000
                                                                        14915000
integer reqblocknum;              << seg ref tab block con-    >>       14920000
                                  <<   taining reqested seg.   >>       14925000
                                                                        14930000
<<------------------------------------------------------------->>       14935000
                                                                        14940000
<< loadslrefent >>                                                      14945000
                                                                        14950000
   reqblocknum := reqsegnum / slrefblockfact;                           14955000
   if not slrefblockloaded or                                           14960000
      pmapcursegnum / slrefblockfact <> reqblocknum then                14965000
                                                                        14970000
      begin << load the proper block. >>                                14975000
      freaddir(ipmapfnum, slrefblock, slrefblocknumwds,                 14980000
               double(slrefblockdrecnum(reqblocknum)));                 14985000
      checkipmapio;                                                     14990000
      slrefblockloaded := true;                                         14995000
      end;                                                              15000000
                                                                        15005000
   pmapcursegnum := reqsegnum;                                          15010000
   mapslrefent(slrefblock((pmapcursegnum mod slrefblockfact)*           15015000
                 slrefentnumwds),slrefp,slrefbp);                       15020000
   status     := stat'ok;                                               15025000
                                                                        15030000
end; << loadslrefent >>                                                 15035000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURE - ",&             15040000
$     "GETPMAPSEGPTR"                                                   15045000
procedure getpmapsegptr(pmapcb,reqsegnum,recnum,recoffset,status);      15050000
value reqsegnum;                                                        15055000
integer array pmapcb;                                                   15060000
integer reqsegnum,recoffset,status;                                     15065000
integer recnum;                                                         15070000
                                                                        15075000
begin                                                                   15080000
   pmapcbdec;                                                           15085000
   if reqsegnum > 128 then                                              15090000
      begin                                                             15095000
         if firsthalfsegptrloaded then                                  15100000
            begin                                                       15105000
               freadmr(ipmapfnum,progpmapptrsi,pf0'numsegs*             15110000
                       2-256+typetablelen,pf0'pmapdrecnum+2,            15115000
                       status);                                         15120000
               if status=stat'ipmapioerr then return;                   15125000
               move progpmapptrsi:=progpmapptrsi(typetablelen)          15130000
                                   ,(256);                              15135000
               firsthalfsegptrloaded:=false;                            15140000
             end;                                                       15145000
          reqsegnum:=reqsegnum-128;                                     15150000
       end                                                              15155000
   else                                                                 15160000
      begin                                                             15165000
         if not firsthalfsegptrloaded then                              15170000
            begin                                                       15175000
               freadmr(ipmapfnum,progpmapptrsi,256+                     15180000
                       typetablelen,pf0'pmapdrecnum,status);            15185000
               if status=stat'ipmapioerr then return;                   15190000
               move progpmapptrsi:=progpmapptrsi(typetablelen)          15195000
                                   ,(256);                              15200000
               firsthalfsegptrloaded:=true;                             15205000
            end;                                                        15210000
      end;                                                              15215000
   getdrecoffset(progpmapptrs(reqsegnum),recnum,recoffset);             15220000
end;                                                                    15225000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            15230000
$     "PMAPFINDSEGNUM"                                                  15235000
procedure pmapfindsegnum(reqsegnum, pmapcb, status);                    15240000
                                                                        15245000
   value reqsegnum;                                                     15250000
                                                                        15255000
   integer       reqsegnum;       << requested segment number >>        15260000
   integer array pmapcb;          << pmap control block >>              15265000
   integer       status;          << status returned >>                 15270000
                                                                        15275000
                                                                        15280000
<<------------------------------------------------------------->>       15285000
<<                                                             >>       15290000
<< this procedure completes initialization of the data in the  >>       15295000
<< pmap control block, causing the next internal pmap record   >>       15300000
<< returned by getipmaprec to be that of a requested segment   >>       15305000
<< number or the first active segment in the pmap file.  the   >>       15310000
<< procedure pmapcbinit must be called prior to calling this   >>       15315000
<< one.                                                        >>       15320000
<<                                                             >>       15325000
<< input:                                                      >>       15330000
<<                                                             >>       15335000
<<    reqsegnum - this is the number of the segment whose      >>       15340000
<<       internal pmap record is to be returned by the next    >>       15345000
<<       call to getipmaprec.  a value of -1 is a request for  >>       15350000
<<       the first active segment in an sl file, or for seg-   >>       15355000
<<       ment 0 in a program file.                             >>       15360000
<<                                                             >>       15365000
<<       if an inactive or illegal segment number is given, an >>       15370000
<<       error status will be returned.  if -1 is passed as a  >>       15375000
<<       segment number and the program or sl file is empty or >>       15380000
<<       has no active segments, the end-of-pmap flag in the   >>       15385000
<<       pmap control block will be set and a status of ok     >>       15390000
<<       will be returned.                                     >>       15395000
<<                                                             >>       15400000
<<    pmapcb - this is the pmap control block as described in  >>       15405000
<<       the global declarations.  prior to the first call to  >>       15410000
<<       this routine it must have been partially initialized  >>       15415000
<<       by pmapcbinit.                                        >>       15420000
<<                                                             >>       15425000
<< output:                                                     >>       15430000
<<                                                             >>       15435000
<<    pmapcb - this is the pmap control block as described in  >>       15440000
<<       the global declarations.  it will be returned updated >>       15445000
<<       as appropriate.                                       >>       15450000
<<                                                             >>       15455000
<<    status - this is a standard pmap intrinsic error code    >>       15460000
<<       returned to indicate detection of any abnormal con-   >>       15465000
<<       dition.  any value other than 0 should be passed on   >>       15470000
<<       to the caller of the originating pmap intrinsic.      >>       15475000
<<                                                             >>       15480000
<<------------------------------------------------------------->>       15485000
$page                                                                   15490000
begin << pmapfindsegnum >>                                              15495000
                                                                        15500000
<< the following declarations provide access to the pmap con-  >>       15505000
<< trol block:                                                 >>       15510000
                                                                        15515000
pmapcbdec;                   << pmap control block arrays >>            15520000
                                                                        15525000
<< the following pointers provide access to an sl segment ref- >>       15530000
<< erence table entry.                                         >>       15535000
                                                                        15540000
integer pointer slrefp;                                                 15545000
logical pointer slreflp = slrefp;                                       15550000
byte    pointer slrefbp;                                                15555000
integer recnum,recoffset;                                               15560000
                                                                        15565000
<< miscellaneous declarations: >>                                       15570000
                                                                        15575000
                                                                        15580000
<<------------------------------------------------------------->>       15585000
                                                                        15590000
   pmapend := false;          << reset flags for          >>            15595000
   segpmapmaped := false;     << next call to getipmaprec >>            15600000
                                                                        15605000
<< pmapfindsegnum >>                                                    15610000
                                                                        15615000
   if ipmapfilecode = progfilecode then                                 15620000
                                                                        15625000
      << resolve the segment request to a specific segment     >>       15630000
      << number.                                               >>       15635000
                                                                        15640000
      begin                                                             15645000
      pmapcursegnum := reqsegnum;                                       15650000
                                                                        15655000
      << make sure the specified segment exists. >>                     15660000
                                                                        15665000
      if not (0 <= pmapcursegnum <= pf0'numsegs - 1) then               15670000
         begin                                                          15675000
         status := stat'badsegid;                                       15680000
         return;                                                        15685000
         end;                                                           15690000
                                                                        15695000
      getpmapsegptr(pmapcb,reqsegnum,recnum,recoffset,status);          15700000
      if status=stat'ipmapioerr then return;                            15705000
      loadipmapbuf (recnum,recoffset,pmapcb,status);                    15710000
      if status=stat'ipmapioerr then return;                            15715000
                                                                        15720000
      end                                                               15725000
$page                                                                   15730000
   else << ipmapfilecode = slfilecode >>                                15735000
                                                                        15740000
      << first find the sl segment reference table entry for   >>       15745000
      << the requested segment.                                >>       15750000
                                                                        15755000
      begin                                                             15760000
                                                                        15765000
         if not (0 <= reqsegnum <= sl0'numsegsalloc-1) then             15770000
            begin                                                       15775000
            status := stat'badsegid;                                    15780000
            return;                                                     15785000
            end;                                                        15790000
                                                                        15795000
         loadslrefent(reqsegnum, slrefp, slrefbp, pmapcb,               15800000
                      status);                                          15805000
         if status <> stat'ok then                                      15810000
            return;                                                     15815000
         if slref'deleted then                                          15820000
            begin                                                       15825000
            status := stat'segdeleted;                                  15830000
            return;                                                     15835000
            end;                                                        15840000
         if slref'pmapdrecnum = 0 then                                  15845000
            begin                                                       15850000
               status:=stat'nopmap;                                     15855000
               return;                                                  15860000
            end;                                                        15865000
                                                                        15870000
      << next, use the pointer in the sl reference table entry >>       15875000
      << to locate the segment's pmap.                         >>       15880000
                                                                        15885000
         loadipmapbuf(slref'pmapdrecnum,0,pmapcb,                       15890000
                     status);                                           15895000
         if status <> stat'ok then                                      15900000
            return;                                                     15905000
      end;                                                              15910000
$page                                                                   15915000
   << if we got this far, the buffer was successfully loaded   >>       15920000
   << and is currently pointing at the requested pmap segment  >>       15925000
   << record.  we indicate this in the pmap control block and  >>       15930000
   << perform a normal return.                                 >>       15935000
                                                                        15940000
   pmappreset := true;            << means pmap pointer is at  >>       15945000
                                  <<   next record to return.  >>       15950000
   status     := stat'ok;                                               15955000
                                                                        15960000
end; << pmapfindsegnum >>                                               15965000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            15970000
$     "PMAPFINDSEGNAME"                                                 15975000
procedure pmapfindsegname(reqsegname, pmapcb, status);                  15980000
   byte    array reqsegname;      << segment name to be found >>        15985000
   integer array pmapcb;          << pmap control block >>              15990000
   integer       status;          << status code returned >>            15995000
                                                                        16000000
   option internal;                                                     16005000
                                                                        16010000
<< this procedure completes initialization of the data in the  >>       16015000
<< pmap control block, causing the next internal pmap record   >>       16020000
<< returned by 'getipmaprec' to be that of a requested segment >>       16025000
<< name.  the procedure 'pmapcbinit' must be called prior to   >>       16030000
<< calling this one.                                           >>       16035000
<<                                                             >>       16040000
<< input:                                                      >>       16045000
<<                                                             >>       16050000
<<    reqsegname - this is a 16-byte array containing the name >>       16055000
<<       of the segment to be found.  the name is assumed to   >>       16060000
<<       be valid, as well as left-justified with blank fill.  >>       16065000
<<                                                             >>       16070000
<<    pmapcb - this is the pmap control block as described in  >>       16075000
<<       the global declarations.  prior to the first call to  >>       16080000
<<       this routine it must have been partially initialized  >>       16085000
<<       by pmapcbinit.                                        >>       16090000
<<                                                             >>       16095000
<< output:                                                     >>       16100000
<<                                                             >>       16105000
<<    pmapcb - this is the pmap control block as described in  >>       16110000
<<       the global declarations.  it will be returned updated >>       16115000
<<       as appropriate.                                       >>       16120000
<<                                                             >>       16125000
<<    status - this is a standard pmap intrinsic error code    >>       16130000
<<       returned to indicate detection of any abnormal con-   >>       16135000
<<       dition.  any value other than 0 should be passed on   >>       16140000
<<       to the caller of the originating pmap intrinsic.      >>       16145000
<<                                                             >>       16150000
                                                                        16155000
begin << pmapfindsegname >>                                             16160000
                                                                        16165000
<< the following declarations provide access to the pmap con-  >>       16170000
<< trol block:                                                 >>       16175000
pmapcbdec;                   << pmap control block arrays >>            16180000
integer pointer slrefp;           << current ref table entry >>         16185000
logical pointer slreflp = slrefp;                                       16190000
byte    pointer slrefbp;                                                16195000
integer pointer ipmapp;           << current internal pmap rec >>       16200000
byte    pointer ipmapbp;                                                16205000
integer pointer ipmapp1;          << 1st word after name >>             16210000
                                                                        16215000
<< miscellaneous variables: >>                                          16220000
integer len;                      << scratch length >>                  16225000
logical namefound := false;       << true when seg name found >>        16230000
integer recoffset;                                                      16235000
logical recnum;                                                         16240000
                                  <<   word in pmap buffer.    >>       16245000
byte array reqsegnameblock(0:16);                                       16250000
byte array slsegname (0:16);                                            16255000
$page                                                                   16260000
<< pmapfindsegname >>                                                   16265000
                                                                        16270000
   buildnameblock(reqsegnameblock,17,reqsegname,,status);               16275000
   pmapcursegnum := 0;                                                  16280000
   namefound     := false;                                              16285000
   if ipmapfilecode = progfilecode then                                 16290000
                                                                        16295000
      begin                                                             16300000
                                                                        16305000
      << segment names in program files are found by looking   >>       16310000
      << up the internal pmap segment records via the pmap     >>       16315000
      << pointers.                                             >>       16320000
                                                                        16325000
      while not namefound and pmapcursegnum < pf0'numsegs do            16330000
         begin                                                          16335000
                                                                        16340000
         << the pmap segment pointers are fetched one record   >>       16345000
         << at a time; test to see if we need a new batch.     >>       16350000
                                                                        16355000
            getpmapsegptr(pmapcb,pmapcursegnum,recnum,                  16360000
                          recoffset,status);                            16365000
            if status = stat'ipmapioerr then return;                    16370000
            loadipmapbuf(recnum,recoffset,pmapcb,status);               16375000
            if status =stat'ipmapioerr then return;                     16380000
            mapipmaprec(pmapbuf(pmapbufx),ipmapp,ipmapbp,               16385000
                        ipmapp1,len,pmapcb);                            16390000
            if namesmatch(reqsegnameblock,ipmap'name) then              16395000
               namefound:=true                                          16400000
            else                                                        16405000
               pmapcursegnum:=pmapcursegnum+1;                          16410000
         end;                                                           16415000
      end                                                               16420000
$page                                                                   16425000
   else << ipmapfilecode = slfilecode >>                                16430000
      begin                                                             16435000
      while not namefound and pmapcursegnum < sl0'numsegsalloc do       16440000
         begin                                                          16445000
         loadslrefent(pmapcursegnum, slrefp, slrefbp, pmapcb,           16450000
                      status);                                          16455000
         if status = stat'ipmapioerr then                               16460000
            return;                                                     16465000
         if not slref'deleted then                                      16470000
            begin                                                       16475000
               buildnameblock(slsegname,17,slref'segname0,,             16480000
                              status);                                  16485000
               if namesmatch(slsegname,reqsegnameblock) then            16490000
                  begin                                                 16495000
                  if slref'pmapdrecnum = 0 then                         16500000
                     begin                                              16505000
                        status:=stat'nopmap;                            16510000
                        return;                                         16515000
                     end;                                               16520000
                  namefound:=true;                                      16525000
                  end                                                   16530000
               else                                                     16535000
                  pmapcursegnum:=pmapcursegnum+1;                       16540000
            end                                                         16545000
         else                                                           16550000
            pmapcursegnum:=pmapcursegnum+1;                             16555000
         end;                                                           16560000
      if namefound then                                                 16565000
         begin                                                          16570000
            loadipmapbuf(slref'pmapdrecnum,0,                           16575000
                         pmapcb,status);                                16580000
            if status <> stat'ok then return;                           16585000
         end;                                                           16590000
      end;                                                              16595000
                                                                        16600000
   if namefound then                                                    16605000
      begin                                                             16610000
      pmappreset := true;                                               16615000
      status := stat'ok;                                                16620000
      end                                                               16625000
   else                                                                 16630000
      status := stat'badsegid;                                          16635000
                                                                        16640000
end; << pmapfindsegname >>                                              16645000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            16650000
$     "FINDSLENTNAME"                                                   16655000
procedure pmapfindslentname(reqentname, pmapcb, status);                16660000
   byte    array reqentname;      << requested entry name >>            16665000
   integer array pmapcb;          << pmap control block >>              16670000
   integer       status;          << status code returned >>            16675000
                                                                        16680000
   option internal;                                                     16685000
                                                                        16690000
<< this procedure completes initialization of the data in the  >>       16695000
<< pmap control block, causing the next internal pmap record   >>       16700000
<< returned by 'getipmaprec' to be that of the segment con-    >>       16705000
<< taining a requested procedure or entry point name.  the     >>       16710000
<< procedure 'pmapcbinit' must be called prior to calling >>            16715000
<< this one.                                                   >>       16720000
<<                                                             >>       16725000
<< note that this procedure will not find hidden procedures or >>       16730000
<< entry points.                                               >>       16735000
<<                                                             >>       16740000
<< input:                                                      >>       16745000
<<                                                             >>       16750000
<<    reqentname - this is a 16-byte array containing the name >>       16755000
<<       of the procedure or secondary entry point to be       >>       16760000
<<       found.  it is assumed to be left-justified with blank >>       16765000
<<       fill.                                                 >>       16770000
<<                                                             >>       16775000
<<    pmapcb - this is the pmap control block as described in  >>       16780000
<<       the global declarations.  prior to the first call to  >>       16785000
<<       this routine it must have been partially initialized  >>       16790000
<<       by pmapcbinit.                                        >>       16795000
<<                                                             >>       16800000
<< output:                                                     >>       16805000
<<                                                             >>       16810000
<<    pmapcb - this is the pmap control block as described in  >>       16815000
<<       the global declarations.  it will be returned updated >>       16820000
<<       as appropriate.                                       >>       16825000
<<                                                             >>       16830000
<<    status - this is a standard pmap intrinsic error code    >>       16835000
<<       returned to indicate detection of any abnormal con-   >>       16840000
<<       dition.  any value other than 0 should be passed on   >>       16845000
<<       to the caller of the originating pmap intrinsic.      >>       16850000
<<                                                             >>       16855000
$page                                                                   16860000
begin << pmapfindslentname >>                                           16865000
                                                                        16870000
<< the following declarations provide access to the pmap con-  >>       16875000
<< trol block:                                                 >>       16880000
pmapcbdec;                   << pmap control block arrays >>            16885000
byte array reqentnameblock (0:16);                                      16890000
integer pointer slrefp;           << current ref tab entry >>           16895000
logical pointer slreflp = slrefp;                                       16900000
byte    pointer slrefbp;          << 1st byte of entry >>               16905000
                                                                        16910000
<< sl entry point directory buffer declarations: >>                     16915000
integer array sldirrec(0:drecnumwds - 1); << current sl dir rec>>       16920000
integer pointer sldirrecp  = sldirrec;                                  16925000
logical pointer sldirreclp = sldirrec;                                  16930000
integer pointer sldirentp;        << sl entry pt directory ent >>       16935000
byte    pointer sldirentbp;                                             16940000
integer pointer sldirentp1;       << 1st word after name >>             16945000
integer         sldirsect;        << # current sl directory rec>>       16950000
integer         sldirx;           << index to cur sl dir entry >>       16955000
integer         sldirentlen;      << length of current dir ent >>       16960000
                                                                        16965000
<< miscellaneous declarations: >>                                       16970000
integer reqnamelen;               << length of requested name >>        16975000
integer pointer sldirhashptrs;                                          16980000
$page                                                                   16985000
<< pmapfindslentname >>                                                 16990000
                                                                        16995000
   buildnameblock(reqentnameblock,17,reqentname,,status);               17000000
   reqnamelen:=namenumch(reqentnameblock);                              17005000
   sldirsect:=sl0'dirhashptrs(hash(reqentname,reqnamelen));             17010000
   while sldirsect <> 0 do                                              17015000
      begin                                                             17020000
      freaddir(ipmapfnum, sldirrec, drecnumwds,                         17025000
               double(sldirsect));                                      17030000
      checkipmapio;                                                     17035000
      sldirx := 2;                                                      17040000
      while sldirx < sldirrec'numwdsused do                             17045000
         begin                                                          17050000
         mapsldirent(sldirrec(sldirx), sldirentp, sldirentbp,           17055000
                     sldirentp1,sldirentlen);                           17060000
         if namesmatch(sldirent'nameblock, reqentnameblock) then        17065000
            begin                                                       17070000
            loadslrefent(sldirent'segnum, slrefp, slrefbp,              17075000
                         pmapcb, status);                               17080000
            if status <> stat'ok then                                   17085000
               return;                                                  17090000
            if slref'pmapdrecnum = 0 then                               17095000
               begin                                                    17100000
                  status:=stat'nopmap;                                  17105000
                  return;                                               17110000
               end;                                                     17115000
            loadipmapbuf(slref'pmapdrecnum,0,                           17120000
                         pmapcb,status);                                17125000
            pmappreset := true;                                         17130000
            status     := stat'ok;                                      17135000
            return;                                                     17140000
            end                                                         17145000
         else                                                           17150000
            sldirx := sldirx + sldirentlen;                             17155000
         end;                                                           17160000
      sldirsect := sldirrec'link;                                       17165000
      end;                                                              17170000
   status := stat'entnamenotfound;                                      17175000
                                                                        17180000
end; << pmapfindslentname >>                                            17185000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            17190000
$     "GETIPMAPREC"                                                     17195000
logical procedure getipmaprec(ipmaprec, ipmaprecp1, scancode,           17200000
                              pmapcb, status);                          17205000
   value scancode;                                                      17210000
   integer array ipmaprec;        << int. pmap rec returned >>          17215000
   integer pointer ipmaprecp1;    << 1st word after name >>             17220000
   integer scancode;              << procedure scan code >>             17225000
   integer array pmapcb;          << pmap control block >>              17230000
   integer status;                << status code returned >>            17235000
                                                                        17240000
                                                                        17245000
<< this procedure gets the next internal pmap record from the  >>       17250000
<< program or sl file being read.  upon return, pointers in    >>       17255000
<< the pmap control block will be set to point to the next     >>       17260000
<< pmap record.  a special stop code is provided for the       >>       17265000
<< caller to indicate if he wants reading to stop at the end   >>       17270000
<< of the pmap or at the end of the segment being scanned.     >>       17275000
<<                                                             >>       17280000
<< prior to calling this procedure, two initialization proce-  >>       17285000
<< dures must be called to set up the pmap control block.  the >>       17290000
<< first of these is 'pmapcbinit', which performs general      >>       17295000
<< validation of the program/sl file containing the pmap and   >>       17300000
<< partially initializes the pmap control block.  the second   >>       17305000
<< routine must be one of 'pmapfindsegnum', 'pmapfindsegname', >>       17310000
<< and 'pmapfindslentname', each of which completes the ini-   >>       17315000
<< tialization process.  refer to the documentation on each of >>       17320000
<< these procedures for further details.                       >>       17325000
<<                                                             >>       17330000
<< input:                                                      >>       17335000
<<                                                             >>       17340000
<<    scancode - this is a code used to indicate when an end-  >>       17345000
<<       of-pmap condition should be returned.  scancurseg     >>       17350000
<<       means it should be returned at the end of the current >>       17355000
<<       segment.  scanallsegs means it should be returned at  >>       17360000
<<       the end of the last segment in the file.              >>       17365000
<<                                                             >>       17370000
<<    pmapcb - this is the pmap control block as described in  >>       17375000
<<       the global declarations.  it is assumed to have been  >>       17380000
<<       initialized for access to internal pmap records.      >>       17385000
<<                                                             >>       17390000
<< output:                                                     >>       17395000
<<                                                             >>       17400000
<<    ipmaprec - this is an array in which the next internal   >>       17405000
<<       pmap record is returned.  it is assumed to be large   >>       17410000
<<       enough to contain the largest possible record (cur-   >>       17415000
<<       rently 32 words).                                     >>       17420000
<<                                                             >>       17425000
<<    ipmaprecp1 - this is an integer pointer to the first     >>       17430000
<<       word after the name in internal pmap record returned. >>       17435000
<<                                                             >>       17440000
<<    pmapcb - this is the pmap control block as described in  >>       17445000
<<       the global declarations.  it will be returned updated >>       17450000
<<       as appropriate.                                       >>       17455000
<<                                                             >>       17460000
<<    status - this is a standard pmap intrinsic error code    >>       17465000
<<       returned to indicate detection of any abnormal con-   >>       17470000
<<       dition.  any value other than 0 should be passed on   >>       17475000
<<       to the caller of the originating pmap intrinsic.      >>       17480000
<<                                                             >>       17485000
                                                                        17490000
begin << getipmaprec >>                                                 17495000
                                                                        17500000
<< the following declarations provide access to the pmap con-  >>       17505000
<< trol block:                                                 >>       17510000
pmapcbdec;                   << pmap control block arrays >>            17515000
                                                                        17520000
<< internal pmap record declarations: >>                                17525000
integer pointer ipmapp;           << 1st word of pmap record >>         17530000
byte    pointer ipmapbp;                                                17535000
integer pointer ipmapp1;                                                17540000
double  pointer ipmapdp1 = ipmapp1;                                     17545000
integer         ipmapreclen;      << # words in current record >>       17550000
$page                                                                   17555000
<< getipmaprec >>                                                       17560000
                                                                        17565000
   if pmapend then                                                      17570000
      begin                                                             17575000
      status := stat'endofpmap;                                         17580000
      return;                                                           17585000
      end;                                                              17590000
   if not pmappreset then                                               17595000
      begin                                                             17600000
      mapipmaprec(pmapbuf(pmapbufx), ipmapp, ipmapbp, ipmapp1,          17605000
               ipmapreclen,pmapcb);                                     17610000
      pmapbufx := pmapbufx + ipmapreclen;                               17615000
      end;                                                              17620000
   if pmapbuf(pmapbufx) = 0 then                                        17625000
      begin                                                             17630000
      status:=stat'endofpmap;                                           17635000
      pmapend:=true;                                                    17640000
      return;                                                           17645000
      end;                                                              17650000
   if pmapbufx+ipmaprecmax > ipmapbufnumwds-1 then                      17655000
   << all or parts of next pmap record probably lies >>                 17660000
   << outside of pmapbuf.                           >>                  17665000
   begin                                                                17670000
      pmapcurdrecnum:=pmapcurdrecnum+1;                                 17675000
      freadmr(ipmapfnum,pmapbuf,ipmapbufnumwds,                         17680000
              pmapcurdrecnum,status);                                   17685000
      if status=stat'ipmapioerr then return;                            17690000
      pmapbufx:=pmapbufx-128;                                           17695000
   end;                                                                 17700000
   mapipmaprec(pmapbuf(pmapbufx), ipmapp, ipmapbp, ipmapp1,             17705000
               ipmapreclen,pmapcb);                                     17710000
   if segpmapmaped and scancode=scancurseg and                          17715000
      ipmap'type=pmapsegtype then                                       17720000
   begin                                                                17725000
      status:=stat'endofpmap;                                           17730000
      return;                                                           17735000
   end;                                                                 17740000
   if ipmap'type = pmapsegtype then                                     17745000
      segpmapmaped := true;                                             17750000
                                                                        17755000
   if ipmapreclen > ipmaprecmax then                           <<06555>>17760000
      begin                                                    <<06555>>17765000
         status := stat'badipmap;                              <<06555>>17770000
         return;                                               <<06555>>17775000
      end;                                                     <<06555>>17780000
   move ipmaprec:=ipmapp,(ipmapreclen);                                 17785000
   @ipmaprecp1:=@ipmaprec+ipmap'namenumch/2+1;                          17790000
   status:=stat'ok;                                                     17795000
   getipmaprec:=true;                                                   17800000
   pmappreset:=false;                                                   17805000
                                                                        17810000
end; << getipmaprec >>                                                  17815000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            17820000
$     "UPDATEIPMAPREC"                                                  17825000
procedure updateipmaprec(ipmaprec, pmapcb, status);                     17830000
   integer array ipmaprec;        << new int. pmap record >>            17835000
   integer array pmapcb;          << pmap control block >>              17840000
   integer status;                << status code returned >>            17845000
                                                                        17850000
   option internal;                                                     17855000
                                                                        17860000
<< this procedure updates the current internal pmap record in  >>       17865000
<< the program or sl file.  a previous call to 'getipmaprec'   >>       17870000
<< is assumed, and the length of the internal pmap record      >>       17875000
<< being updated is assumed not to have changed.               >>       17880000
<<                                                             >>       17885000
<< input:                                                      >>       17890000
<<                                                             >>       17895000
<<    ipmaprec - this is an array containing the updated copy  >>       17900000
<<       of the internal pmap record returned from the last    >>       17905000
<<       call to 'getipmaprec'.  no change in the length of    >>       17910000
<<       this record is allowed.                               >>       17915000
<<                                                             >>       17920000
<<    pmapcb - this is the pmap control block as described in  >>       17925000
<<       the global declarations.  it is assumed to have been  >>       17930000
<<       initialized for access to internal pmap records.      >>       17935000
<<                                                             >>       17940000
<< output:                                                     >>       17945000
<<                                                             >>       17950000
<<    pmapcb - this is the pmap control block as described in  >>       17955000
<<       the global declarations.  it will be returned updated >>       17960000
<<       as appropriate.                                       >>       17965000
<<                                                             >>       17970000
<<    status - this is a standard pmap intrinsic error code    >>       17975000
<<       returned to indicate detection of any abnormal con-   >>       17980000
<<       dition.  any value other than 0 should be passed on   >>       17985000
<<       to the caller of the originating pmap intrinsic.      >>       17990000
<<                                                             >>       17995000
                                                                        18000000
begin << updateipmaprec >>                                              18005000
                                                                        18010000
<< the following declarations provide access to the pmap con-  >>       18015000
<< trol block:                                                 >>       18020000
pmapcbdec;                   << pmap control block arrays >>            18025000
                                                                        18030000
<< internal pmap declarations: >>                                       18035000
integer pointer ipmapp;           << 1st word of pmap record >>         18040000
byte    pointer ipmapbp;                                                18045000
integer pointer ipmapp1;                                                18050000
double  pointer ipmapdp1 = ipmapp1;                                     18055000
integer         ipmapreclen;      << # words in current record >>       18060000
                                                                        18065000
$page                                                                   18070000
<< updateipmaprec >>                                                    18075000
                                                                        18080000
   mapipmaprec(pmapbuf(pmapbufx),ipmapp,ipmapbp,ipmapp1,                18085000
               ipmapreclen,pmapcb);                                     18090000
   move pmapbuf(pmapbufx) := ipmaprec, (ipmapreclen);                   18095000
   fwritemr(ipmapfnum,pmapbuf,drecnumwds*2,pmapcurdrecnum,              18100000
            status);                                                    18105000
   if status=stat'ipmapioerr then return;                               18110000
   status := stat'ok;                                                   18115000
                                                                        18120000
end; << updateipmaprec >>                                               18125000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            18130000
$     "UNPACKPMAPREC"                                                   18135000
procedure unpackpmaprec(xpmaprec, ipmaprec, pmapcb);                    18140000
   integer array xpmaprec;         << external pmap record >>           18145000
   integer array ipmaprec;         << internal pmap record >>           18150000
   integer array pmapcb;                                                18155000
                                                                        18160000
   option internal;                                                     18165000
                                                                        18170000
   << this procedure unpacks an internal pmap record into the  >>       18175000
   << format of an external pmap record.  all fields in the    >>       18180000
   << external record that fall below the level of the inter-  >>       18185000
   << nal pmap record being unpacked will be reset to the null >>       18190000
   << (blank) state.                                           >>       18195000
   <<                                                          >>       18200000
   << input:                                                   >>       18205000
   <<    ipmaprec - this is the internal pmap record to be un- >>       18210000
   <<       packed.                                            >>       18215000
   <<                                                          >>       18220000
   << output:                                                  >>       18225000
   <<    xpmaprec - this is the external pmap record to re-    >>       18230000
   <<       ceive the data to be unpacked.                     >>       18235000
                                                                        18240000
   begin << unpackpmaprec >>                                            18245000
   pmapcbdec;                                                           18250000
                                                                        18255000
   << pointers used to access the pmap records: >>                      18260000
   integer pointer ipmapp;                                              18265000
   byte    pointer ipmapbp;                                             18270000
   integer pointer ipmapp1;                                             18275000
   double  pointer ipmapdp1 = ipmapp1;                                  18280000
   integer pointer xpmapp   = xpmaprec;                                 18285000
   byte    array   xpmapbp(*) = xpmaprec;                               18290000
   double  pointer xpmapdp  = xpmaprec;                                 18295000
   integer         len;                                                 18300000
$page                                                                   18305000
subroutine zerofill(iarray, len);                                       18310000
   value len;                                                           18315000
   integer array iarray;          << array to be zeroed >>              18320000
   integer len;                   << # of words to be zeroed >>         18325000
                                                                        18330000
   << this subroutine fills an array with binary zeroes. >>             18335000
                                                                        18340000
   begin << zerofill >>                                                 18345000
                                                                        18350000
      iarray := 0;                                                      18355000
      move iarray(1) := iarray, (len - 1);                              18360000
                                                                        18365000
   end; << zerofill >>                                                  18370000
                                                                        18375000
subroutine blankfill(string, len);                                      18380000
   value len;                                                           18385000
   byte array string;             << byte array to be blanked >>        18390000
   integer len;                   << # of chars to be blanked >>        18395000
                                                                        18400000
   << this subroutine fills a string with blanks. >>                    18405000
                                                                        18410000
   begin << blankstring >>                                              18415000
                                                                        18420000
      string := " ";                                                    18425000
      move string(1) := string, (len - 1);                              18430000
                                                                        18435000
   end; << blankstring >>                                               18440000
                                                                        18445000
subroutine unpackname(dest, source, len);                               18450000
   value len;                                                           18455000
   byte array dest;               << unpacked name >>                   18460000
   byte array source;             << name to unpack >>                  18465000
   integer len;                   << length of packed name >>           18470000
                                                                        18475000
   << this procedure unpacks a variable-length symbolic name   >>       18480000
   << into a fixed-length buffer, left-justified with blank    >>       18485000
   << fill.  the length of the destination buffer is assumed   >>       18490000
   << to be 'symnamemax' bytes.                                >>       18495000
                                                                        18500000
   begin << unpackname >>                                               18505000
                                                                        18510000
      blankfill(dest, symnamemax+1);                           <<06555>>18515000
      move dest := source, (len);                                       18520000
                                                                        18525000
   end; << unpackname >>                                                18530000
$page                                                                   18535000
<< unpackpmaprec >>                                                     18540000
                                                                        18545000
   mapipmaprec(ipmaprec,ipmapp,ipmapbp,ipmapp1,len,pmapcb);             18550000
                                                                        18555000
   << unpack the data. >>                                               18560000
   xpmap'type := ipmap'type;                                            18565000
   if ipmap'type = pmapsegtype then                                     18570000
      begin                                                             18575000
      unpackname(xpmap'segname,ipmap'name(1),ipmap'namenumch);          18580000
      xpmap'segnum := ipmap'segnum;                                     18585000
      xpmap'seglen := ipmap'seglen;                                     18590000
      xpmap'sttlen := ipmap'sttlen;                                     18595000
                                                                        18600000
      blankfill(xpmap'procname, (symnamemax + 1) * 2);                  18605000
      zerofill(xpmap'procstart, 8);                                     18610000
      end                                                               18615000
   else if ipmap'type = pmapproctype then                               18620000
      begin                                                             18625000
      unpackname(xpmap'procname,ipmap'name(1),ipmap'namenumch);         18630000
      xpmap'procstart := ipmap'procstart;                               18635000
      xpmap'proclen   := ipmap'proclen;                                 18640000
      xpmap'procentry := ipmap'procentry;                               18645000
      xpmap'tboxid    := ipmap'tboxid;                                  18650000
      xpmap'tboxlink  := ipmap'tboxlink;                                18655000
                                                                        18660000
      blankfill(xpmap'secname, symnamemax + 1);                         18665000
      zerofill(xpmap'secentry, 2);                                      18670000
      end                                                               18675000
   else                                                                 18680000
      begin                                                             18685000
      unpackname(xpmap'secname,ipmap'name(1),ipmap'namenumch);          18690000
      xpmap'secentry := ipmap'secentry;                                 18695000
      xpmap'secentnum := ipmap'secentnum;                               18700000
      end;                                                              18705000
                                                                        18710000
end; << unpackpmaprec >>                                                18715000
$page "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            18720000
$     "COPYXPMAPREC"                                                    18725000
procedure copyxpmaprec(dest, source, len);                              18730000
   value len;                                                           18735000
   integer array dest;       << destination record >>                   18740000
   integer array source;     << source pmap record >>                   18745000
   integer len;              << destination record length >>            18750000
                                                                        18755000
   option internal;                                                     18760000
                                                                        18765000
<< this procedure copies an external pmap record from one buf- >>       18770000
<< fer to another.  the source buffer is assumed to contain an >>       18775000
<< external pmap record of maximum length, while the length of >>       18780000
<< the destination buffer is specified by 'len'.  in no case   >>       18785000
<< will more than the number of words in the source buffer be  >>       18790000
<< moved.                                                      >>       18795000
                                                                        18800000
begin << copyxpmaprec >>                                                18805000
                                                                        18810000
   if len < 1 then                                                      18815000
      return;                                                           18820000
   move dest := source, (if len > xpmaprecmax then xpmaprecmax          18825000
                         else len);                                     18830000
                                                                        18835000
end; << copyxpmaprec >>                                                 18840000
$page "PROGRAM FILE PMAP INTRINSICS - FINDPMAPNAME"                     18845000
procedure findpmapname(progfile, segname, entname, xpmaprec,            18850000
                       xpmapreclen, status);                            18855000
   value progfile, xpmapreclen;                                         18860000
   integer progfile;              << program/sl file number >>          18865000
   byte array segname;            << segment name to be found >>        18870000
   byte array entname;            << entry point to be found >>         18875000
   integer array xpmaprec;        << extern. pmap rec returned >>       18880000
   integer xpmapreclen;           << # words to be returned >>          18885000
   integer status;                << status returned >>                 18890000
                                                                        18895000
option variable;                                                        18900000
                                                                        18905000
<< this procedure searches the pmap in a program or sl file    >>       18910000
<< for a segment and/or entry point name.  if found, an appro- >>       18915000
<< priate external pmap record will be returned.  otherwise,   >>       18920000
<< the status code will indicate why the search failed.        >>       18925000
<<                                                             >>       18930000
<< one or both of the parameters 'segname' and 'entname' must  >>       18935000
<< be included in the actual parameter list; the action taken  >>       18940000
<< according to their various combinations is as follows:      >>       18945000
<<                                                             >>       18950000
<< 'segname' only:  this calling sequence results in a search  >>       18955000
<< for a segment name only.  if found, a segment (type 0) ex-  >>       18960000
<< ternal pmap record will be returned.                        >>       18965000
<<                                                             >>       18970000
<< 'entname' only:  this calling sequence results in a search  >>       18975000
<< for a procedure or secondary entry point name.  in program  >>       18980000
<< files, all procedures and secondary entry points will be    >>       18985000
<< searched.  in sl files, only those procedures and secondary >>       18990000
<< entry points appearing in the file directory will be        >>       18995000
<< searched.  this implies that hidden procedures and secon-   >>       19000000
<< dary entry points will not be found.  a procedure (type 1   >>       19005000
<< or 3) or entry point (type 2 or 4) external pmap record     >>       19010000
<< will be returned.                                           >>       19015000
<<                                                             >>       19020000
<< both 'segname' and 'entname':  this calling sequence re-    >>       19025000
<< sults in a search for a procedure or secondary entry point  >>       19030000
<< name in a specified segment.  hidden procedures and secon-  >>       19035000
<< dary entry points will be included in the search since the  >>       19040000
<< segment name qualifies such names for uniqueness.           >>       19045000
<<                                                             >>       19050000
<< 'segname' and 'entname' may be excluded from a procedure    >>       19055000
<< call either by physical omission in the parameter list, or  >>       19060000
<< by the presence of a blank as the first character in their  >>       19065000
<< byte arrays.  all other parameters in the calling sequence  >>       19070000
<< must be present.                                            >>       19075000
$page                                                                   19080000
begin << findpmapname >>                                                19085000
                                                                        19090000
<< option variable data: >>                                             19095000
equate reqparms = %47;            << bits for required parms >>         19100000
define segname' = parmflags.(11:1)#;                                    19105000
define entname' = parmflags.(12:1)#;                                    19110000
                                                                        19115000
<< pmap control block allocations: >>                                   19120000
integer array pmapcb(0:pmapcblen - 1);                                  19125000
pmapcbdec;                                                              19130000
                                                                        19135000
<< internal pmap record buffer allocation: >>                           19140000
integer array   ipmapbuf(0:ipmaprecmax - 1);                            19145000
integer pointer ipmapp   = ipmapbuf;                                    19150000
byte    array   ipmapbp(*) = ipmapbuf;                                  19155000
integer pointer ipmapp1;                                                19160000
double  pointer ipmapdp1 = ipmapp1;                                     19165000
                                                                        19170000
<< external pmap record buffer allocation: >>                           19175000
integer array xpmapbuf(0:xpmaprecmax - 1);                              19180000
                                                                        19185000
<< miscellaneous declarations: >>                                       19190000
byte array reqseg(0:symnamemax);  << segment name to be found >>        19195000
byte array reqent(0:symnamemax);  << entry point to be found >>         19200000
integer reqentlen;                << length of entry pt. name >>        19205000
integer searchtype;               << type of search to be done >>       19210000
   equate searchseg = 1;          << search for segment name >>         19215000
   equate searchent = 2;          << search for directory entry>>       19220000
   equate searchhid = 3;          << search segment for entry >>        19225000
integer scancode;                 << pmap scan halt code >>             19230000
integer i;                        << miscellaneous counter >>           19235000
$page                                                                   19240000
subroutine formatsymname(dest, source);                                 19245000
   value source;                                                        19250000
   byte array dest;               << formatted name >>                  19255000
   byte pointer source;           << unformatted name >>                19260000
                                                                        19265000
   << this subroutine formats a symbolic name into a fixed-    >>       19270000
   << length buffer, left-justified with blank fill.  the      >>       19275000
   << buffer is assumed to be one character longer than the    >>       19280000
   << longest symbolic name ('symnamemax' characters) so that  >>       19285000
   << the name is guaranteed to be followed by at least one    >>       19290000
   << blank.                                                   >>       19295000
   <<                                                          >>       19300000
   << the source name is assumed to be terminated by a blank   >>       19305000
   << if it contains fewer than 'symnamemax' characters.       >>       19310000
   << longer names will be truncated without warning after the >>       19315000
   << 'symnamemax'th character to fit in the destination buf-  >>       19320000
   << fer.                                                     >>       19325000
                                                                        19330000
   begin << formatsymname >>                                            19335000
                                                                        19340000
      for i := 0 until symnamemax - 1 do                                19345000
         begin                                                          19350000
         dest(i) := source;                                             19355000
         if source <> " " then                                          19360000
            @source := @source + 1;                                     19365000
         end;                                                           19370000
      dest(symnamemax) := " ";                                          19375000
                                                                        19380000
   end; << formatsymname >>                                             19385000
$page                                                                   19390000
subroutine searchforsegname;                                            19395000
                                                                        19400000
   << this subroutine completes the search of the pmap for a   >>       19405000
   << segment name after the caller has performed preliminary  >>       19410000
   << validation of the procedure parameters and has initial-  >>       19415000
   << ized the pmap control block.                             >>       19420000
   <<                                                          >>       19425000
   << upon return, the status code indicates success or fail-  >>       19430000
   << ure and must be used to set the condition code prior to  >>       19435000
   << returning control to the caller of the pmap intrinsic.   >>       19440000
                                                                        19445000
   begin << searchforsegname >>                                         19450000
                                                                        19455000
      pmapfindsegname(reqseg, pmapcb, status);                          19460000
      if status <> stat'ok then                                         19465000
         return;                                                        19470000
      getipmaprec(ipmapbuf, ipmapp1, scancurseg,                        19475000
                      pmapcb, status);                                  19480000
      if status <> stat'ok then                                         19485000
         return;                                                        19490000
      unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb);                        19495000
      copyxpmaprec(xpmaprec, xpmapbuf, xpmapreclen);                    19500000
                                                                        19505000
   end; << searchforsegname >>                                          19510000
$page                                                                   19515000
subroutine searchforentname;                                            19520000
                                                                        19525000
   << this subroutine completes the search of the pmap for a   >>       19530000
   << procedure or entry point name after the caller has per-  >>       19535000
   << formed preliminary validation of the procedure parame-   >>       19540000
   << ters and has initialized the pmap control block.  hidden >>       19545000
   << entry points will not be detected by this subroutine.    >>       19550000
   <<                                                          >>       19555000
   << upon return, the status code indicates success or fail-  >>       19560000
   << ure and must be used to set the condition code prior to  >>       19565000
   << returning control to the caller of the pmap intrinsic.   >>       19570000
                                                                        19575000
   begin << searchforentname >>                                         19580000
                                                                        19585000
      scan reqent until "  ",1;                                         19590000
      reqentlen := tos - @reqent;                                       19595000
      if ipmapfilecode = slfilecode then                                19600000
         begin                                                          19605000
         pmapfindslentname(reqent, pmapcb,                              19610000
                           status);                                     19615000
         if status <> stat'ok then                                      19620000
            return;                                                     19625000
         scancode := scancurseg;                                        19630000
         end                                                            19635000
      else                                                              19640000
         begin                                                          19645000
         pmapfindsegnum(0, pmapcb, status);                             19650000
         if status <> stat'ok then                                      19655000
            return;                                                     19660000
         scancode := scanallsegs;                                       19665000
         end;                                                           19670000
      while getipmaprec(ipmapbuf, ipmapp1,                              19675000
                            scancode, pmapcb, status) do                19680000
         if ipmap'type = pmapsegtype then                               19685000
            unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb)                   19690000
         else if ipmap'hidden = false and                               19695000
                 ipmap'namenumch = reqentlen and                        19700000
                 ipmap'name(1) = reqent, (reqentlen) then               19705000
            begin                                                       19710000
            unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb);                  19715000
            copyxpmaprec(xpmaprec, xpmapbuf, xpmapreclen);              19720000
            return;                                                     19725000
            end                                                         19730000
         else if ipmap'type = pmapproctype then                         19735000
            unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb);                  19740000
      if status = stat'endofpmap then                                   19745000
         status := stat'entnamenotfound;                                19750000
                                                                        19755000
   end; << searchforentname >>                                          19760000
$page                                                                   19765000
subroutine searchforhidentry;                                           19770000
                                                                        19775000
   << this subroutine completes the search of the pmap for a   >>       19780000
   << procedure or entry point name in a specified segment     >>       19785000
   << after the caller has performed preliminary validation of >>       19790000
   << the procedure parameters and has initialized the pmap    >>       19795000
   << control block.  hidden entry points will be detected by  >>       19800000
   << this subroutine.  upon return, control may be passed     >>       19805000
   << directly to the caller of the procedure.                 >>       19810000
                                                                        19815000
   begin << searchforhidentry >>                                        19820000
                                                                        19825000
      scan reqent until "  ",1;                                         19830000
      reqentlen := tos - @reqent;                                       19835000
      pmapfindsegname(reqseg, pmapcb, status);                          19840000
      if status <> stat'ok then                                         19845000
         return;                                                        19850000
      while getipmaprec(ipmapbuf, ipmapp1,                              19855000
                            scancurseg, pmapcb, status) do              19860000
         if ipmap'type = pmapsegtype then                               19865000
            unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb)                   19870000
         else if ipmap'namenumch = reqentlen and                        19875000
                 ipmap'name(1) = reqent, (reqentlen) then               19880000
            begin                                                       19885000
            unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb);                  19890000
            copyxpmaprec(xpmaprec, xpmapbuf, xpmapreclen);              19895000
            return;                                                     19900000
            end                                                         19905000
         else if ipmap'type = pmapproctype then                         19910000
            unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb);                  19915000
      if status = stat'endofpmap then                                   19920000
         status := stat'entnamenotfound;                                19925000
                                                                        19930000
   end; << searchforhidentry >>                                         19935000
$page                                                                   19940000
<< findpmapname >>                                                      19945000
                                                                        19950000
   << validate parameters. >>                                           19955000
   searchtype := 0;                                                     19960000
   if segname' and segname <> " " then                                  19965000
      begin                                                             19970000
      searchtype := searchseg;                                          19975000
      formatsymname(reqseg, segname);                                   19980000
      end;                                                              19985000
   if entname' and entname <> " " then                                  19990000
      begin                                                             19995000
      searchtype := if searchtype = searchseg then searchhid            20000000
                                              else searchent;           20005000
      formatsymname(reqent, entname);                                   20010000
      end;                                                              20015000
   if searchtype = 0 or (parmflags land reqparms) <> reqparms           20020000
      then                                                              20025000
      begin                                                             20030000
      status := stat'missingparms;                                      20035000
      go exit;                                                          20040000
      end;                                                              20045000
   pmapcbinit(progfile, pmapcb, status);                                20050000
   if status <> stat'ok then                                            20055000
      go exit;                                                          20060000
                                                                        20065000
   if searchtype = searchseg then                                       20070000
      searchforsegname                                                  20075000
   else if searchtype = searchent then                                  20080000
      searchforentname                                                  20085000
   else << searchtype = searchhid >>                                    20090000
      searchforhident;                                                  20095000
                                                                        20100000
exit:                                                                   20105000
   condcode := if status = stat'ok then cce                             20110000
               else if status = stat'badsegid or                        20115000
                       status = stat'entnamenotfound then ccg           20120000
               else ccl;                                                20125000
                                                                        20130000
end; << findpmapname >>                                                 20135000
$page "PROGRAM FILE PMAP INTRINSICS - FINDPMAPADDR"                     20140000
procedure findpmapaddr(progfile, segnum, address, xpmaprec,             20145000
                       xpmapreclen, status);                            20150000
   value progfile, segnum, address, xpmapreclen;                        20155000
   integer progfile;              << program/sl <fopen> number >>       20160000
   integer segnum;                 << # of seg containing addr >>       20165000
   integer address;               << address to searhch for >>          20170000
   integer array xpmaprec;        << external pmap rec returned>>       20175000
   integer xpmapreclen;           << # words to return >>               20180000
   integer status;                << status returned >>                 20185000
                                                                        20190000
<< this procedure searches the pmap in a program or sl file    >>       20195000
<< for a specific address in a particular code segment.  an    >>       20200000
<< external pmap record corresponding to the nearest entry     >>       20205000
<< point preceding <address> will be returned.                 >>       20210000
                                                                        20215000
begin                                                                   20220000
                                                                        20225000
<< pmap control block allocations: >>                                   20230000
integer array pmapcb(0:pmapcblen - 1);                                  20235000
pmapcbdec;                                                              20240000
                                                                        20245000
<< internal pmap record buffer allocation: >>                           20250000
integer array   ipmapbuf(0:ipmaprecmax - 1);                            20255000
integer pointer ipmapp   = ipmapbuf;                                    20260000
byte    array   ipmapbp(*)  = ipmapbuf;                                 20265000
integer pointer ipmapp1;                                                20270000
double  pointer ipmapdp1 = ipmapp1;                                     20275000
                                                                        20280000
<< external pmap record buffer allocation: >>                           20285000
integer array xpmapbuf(0:xpmaprecmax - 1);                              20290000
                                                                        20295000
<< miscellaneous variables: >>                                          20300000
logical foundproc;                << true when procedure con-  >>       20305000
                                  <<   taining 'address' has   >>       20310000
                                  <<   been seen.              >>       20315000
integer saveaddress;                                           <<06555>>20320000
$page                                                                   20325000
<< findpmapaddr >>                                                      20330000
                                                                        20335000
   pmapcbinit(progfile, pmapcb, status);                                20340000
   if status <> stat'ok then                                            20345000
      go exit;                                                          20350000
   pmapfindsegnum(segnum, pmapcb, status);                              20355000
   if status <> stat'ok then                                            20360000
      go exit;                                                          20365000
                                                                        20370000
   foundproc := false;                                                  20375000
   while getipmaprec(ipmapbuf, ipmapp1, scancurseg,                     20380000
                     pmapcb, status) and not foundproc do               20385000
      if ipmap'type = pmapsegtype then                                  20390000
         unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb)                      20395000
      else if ipmap'type = pmapproctype then                            20400000
         if ipmap'procstart <= address <= ipmap'procstart+              20405000
                                         ipmap'proclen - 1 then         20410000
            begin                                                       20415000
            unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb);                  20420000
            foundproc := true;                                          20425000
            saveaddress := -1;                                 <<06555>>20430000
            while getipmaprec(ipmapbuf,ipmapp1,scancurseg,              20435000
                              pmapcb,status) and                        20440000
                  ipmap'type=pmapsectype do                             20445000
               if saveaddress < ipmap'secentry and             <<06555>>20450000
                  ipmap'secentry <= address then               <<06555>>20455000
                  begin                                        <<06555>>20460000
                    unpackpmaprec(xpmapbuf,ipmapbuf,pmapcb);   <<06555>>20465000
                    saveaddress := ipmap'secentry;             <<06555>>20470000
                  end;                                         <<06555>>20475000
            end;                                                        20480000
   if foundproc then                                                    20485000
      begin                                                             20490000
      copyxpmaprec(xpmaprec, xpmapbuf, xpmapreclen);                    20495000
      if status = stat'endofpmap then                                   20500000
         status := stat'ok;                                             20505000
      end                                                               20510000
   else                                                                 20515000
      if status = stat'ok or status = stat'endofpmap then               20520000
         status := stat'badaddress;                                     20525000
                                                                        20530000
exit:                                                                   20535000
   condcode := if status = stat'ok then cce                             20540000
               else if status = stat'badaddress then ccg                20545000
               else ccl;                                                20550000
                                                                        20555000
   end; << findpmapaddress >>                                           20560000
$page "PROGRAM FILE PMAP INTRINSICS - DUMPPMAP"                         20565000
procedure dumppmap(progfile, xpmapfile, xpmapreclen, reccount,          20570000
                   segnum, status);                                     20575000
   value progfile, xpmapfile, xpmapreclen, segnum;                      20580000
   integer progfile;              << program/sl file number >>          20585000
   integer xpmapfile;             << external pmap file # >>            20590000
   integer xpmapreclen;           << max length of xpmap recs >>        20595000
   integer segnum;                 << segment to be dumped >>           20600000
   integer reccount;              << record count returned >>           20605000
   integer status;                << status code returned >>            20610000
                                                                        20615000
<< this procedure copies the contents of an internal pmap in a >>       20620000
<< program or sl file into a seperate file containing external >>       20625000
<< pmap records.                                               >>       20630000
                                                                        20635000
begin << dumppmap >>                                                    20640000
                                                                        20645000
<< pmap control block allocations: >>                                   20650000
integer array pmapcb(0:pmapcblen - 1);                                  20655000
pmapcbdec;                                                              20660000
                                                                        20665000
<< internal pmap record buffer allocation: >>                           20670000
integer array   ipmapbuf(0:ipmaprecmax - 1);                            20675000
integer pointer ipmapp   = ipmapbuf;                                    20680000
byte    array   ipmapbp(*)  = ipmapbuf;                                 20685000
integer pointer ipmapp1;                                                20690000
double  pointer ipmapdp1 = ipmapp1;                                     20695000
                                                                        20700000
<< external pmap record buffer allocation: >>                           20705000
integer array xpmapbuf(0:xpmaprecmax - 1);                              20710000
logical array xpmapbufl(*) = xpmapbuf;                                  20715000
                                                                        20720000
<< miscellaneous declarations: >>                                       20725000
integer reclen;                   << actual xpmap record len >>         20730000
integer scancode;                 << pmap scan code used >>             20735000
$page                                                                   20740000
subroutine copyintoxpmapfile;                                           20745000
begin                                                                   20750000
   while getipmaprec(ipmapbuf, ipmapp1, scancode,                       20755000
                     pmapcb, status) do                                 20760000
      begin                                                             20765000
      unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb);                        20770000
      fwrite(xpmapfile, xpmapbufl, reclen, 0);                          20775000
      if > then                                                         20780000
         begin                                                          20785000
         status := stat'xpmapfilefull;                                  20790000
         go exit;                                                       20795000
         end                                                            20800000
      else if < then                                                    20805000
         begin                                                          20810000
         status := stat'xpmapioerr;                                     20815000
         go exit;                                                       20820000
         end;                                                           20825000
      reccount := reccount + 1;                                         20830000
      end;                                                              20835000
end;                                                                    20840000
$page                                                                   20845000
<< dumppmap >>                                                          20850000
                                                                        20855000
   pmapcbinit(progfile, pmapcb, status);                                20860000
   if status <> stat'ok then                                            20865000
      go exit;                                                          20870000
   reclen := if 1 <= xpmapreclen <= xpmaprecmax                         20875000
             then xpmapreclen else xpmaprecmax;                         20880000
   reccount := 0;                                                       20885000
   if ipmapfilecode = progfilecode then                                 20890000
      begin                                                             20895000
         scancode := if segnum = -1 then scanallsegs else scancurseg;   20900000
         if segnum=-1 then segnum:=0;                                   20905000
         pmapfindsegnum(segnum, pmapcb, status);                        20910000
         if status <> stat'ok then                                      20915000
            go exit;                                                    20920000
         copyintoxpmapfile;                                             20925000
      end                                                               20930000
   else                                                                 20935000
      if segnum = -1 then                                               20940000
         begin                                                          20945000
            segnum:=0;                                                  20950000
            scancode:=scancurseg;                                       20955000
            while segnum < sl0'numsegsalloc do                          20960000
               begin                                                    20965000
                  pmapfindsegnum(segnum, pmapcb, status);               20970000
                  if status <> stat'ok then                             20975000
                     if status<>stat'segdeleted and                     20980000
                        status<>stat'nopmap then                        20985000
                        go exit                                         20990000
                     else                                               20995000
                  else copyintoxpmapfile;                               21000000
                  segnum:=segnum+1;                                     21005000
               end;                                                     21010000
         end                                                            21015000
      else                                                              21020000
         begin                                                          21025000
            pmapfindsegnum(segnum,pmapcb,status);                       21030000
            if status <> stat'ok then go exit;                          21035000
            copyintoxpmapfile;                                          21040000
         end;                                                           21045000
   if status = stat'endofpmap then                                      21050000
      status := stat'ok;                                                21055000
                                                                        21060000
   if reccount=0 then status:=stat'nopmap;                              21065000
                                                                        21070000
exit:                                                                   21075000
   condcode := if status = stat'ok then cce                             21080000
               else if status = stat'xpmapioerr then ccg                21085000
               else ccl;                                                21090000
                                                                        21095000
   end; << dumppmap >>                                                  21100000
$page "PROGRAM FILE PMAP INTRINSICS - FINDTOOLBOXID"                    21105000
procedure findtoolboxid(progfile, toolboxid, xpmaprec,                  21110000
                                xpmapreclen, status);                   21115000
   value progfile, toolboxid, xpmapreclen;                              21120000
   integer progfile;              << program/sl file number >>          21125000
   integer toolboxid;             << toolbox id to be found >>          21130000
   integer array xpmaprec;        << extern. pmap rec returned >>       21135000
   integer xpmapreclen;           << # words to be returned >>          21140000
   integer status;                << status returned >>                 21145000
                                                                        21150000
<< this procedure searches the pmap in a program or sl file    >>       21155000
<< for a procedure entry associated with a specified toolbox   >>       21160000
<< id.  if found, a procedure (type 1 or 3) external pmap rec- >>       21165000
<< ord describing the code module associated with the id will  >>       21170000
<< be returned.  otherwise, the status code will indicate why  >>       21175000
<< the search failed.                                          >>       21180000
                                                                        21185000
begin << findtoolboxid >>                                               21190000
                                                                        21195000
<< pmap control block allocations: >>                                   21200000
integer array pmapcb(0:pmapcblen - 1);                                  21205000
pmapcbdec;                                                              21210000
                                                                        21215000
<< internal pmap record buffer allocation: >>                           21220000
integer array   ipmapbuf(0:ipmaprecmax - 1);                            21225000
integer pointer ipmapp   = ipmapbuf;                                    21230000
byte    array   ipmapbp(*)  = ipmapbuf;                                 21235000
integer pointer ipmapp1;                                                21240000
double  pointer ipmapdp1 = ipmapp1;                                     21245000
integer segnum;                                                         21250000
integer scancode;                                                       21255000
                                                                        21260000
<< external pmap record buffer allocation: >>                           21265000
integer array xpmapbuf(0:xpmaprecmax - 1);                              21270000
$page                                                                   21275000
subroutine gettoolboxid;                                                21280000
begin                                                                   21285000
   while getipmaprec(ipmapbuf, ipmapp1, scancode,                       21290000
                     pmapcb, status) do                                 21295000
      begin                                                             21300000
      if ipmap'type = pmapsegtype then                                  21305000
         unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb)                      21310000
      else if ipmap'type = pmapproctype and                             21315000
              ipmap'tboxid = toolboxid then                             21320000
         begin                                                          21325000
         unpackpmaprec(xpmapbuf, ipmapbuf, pmapcb);                     21330000
         copyxpmaprec(xpmaprec, xpmapbuf, xpmapreclen);                 21335000
         go exit;                                                       21340000
         end;                                                           21345000
      end;                                                              21350000
end;                                                                    21355000
$page                                                                   21360000
<< findtoolboxid >>                                                     21365000
                                                                        21370000
   pmapcbinit(progfile, pmapcb, status);                                21375000
   if status <> stat'ok then                                            21380000
      go exit;                                                          21385000
   if ipmapfilecode = progfilecode then                                 21390000
      begin                                                             21395000
         pmapfindsegnum(0, pmapcb, status);                             21400000
         if status <> stat'ok then                                      21405000
            go exit;                                                    21410000
         scancode := scanallsegs;                                       21415000
         gettoolboxid;                                                  21420000
      end                                                               21425000
   else                                                                 21430000
      begin                                                             21435000
         segnum:=0;                                                     21440000
         scancode:=scancurseg;                                          21445000
         while segnum < sl0'numsegsalloc do                             21450000
            begin                                                       21455000
               pmapfindsegnum(segnum,pmapcb,status);                    21460000
               if status <> stat'ok then                                21465000
                  if status <> stat'segdeleted and                      21470000
                     status <> stat'nopmap then                         21475000
                     go exit                                            21480000
                  else                                                  21485000
               else                                                     21490000
                  gettoolboxid;                                         21495000
               segnum:=segnum+1;                                        21500000
            end;                                                        21505000
      end;                                                              21510000
                                                                        21515000
   if status = stat'endofpmap then                                      21520000
      status := stat'tboxidnotfound;                                    21525000
                                                                        21530000
exit:                                                                   21535000
   condcode := if status = stat'ok then cce                             21540000
               else if status = stat'tboxidnotfound then ccg            21545000
               else ccl;                                                21550000
                                                                        21555000
end; << findtoolboxid >>                                                21560000
$page "PROGRAM FILE PMAP INTRINSICS - UPDATETOOLBOXID"                  21565000
procedure updatetoolboxid(progfile, toolboxid, toolboxidlink,           21570000
                          status);                                      21575000
   value progfile, toolboxid, toolboxidlink;                            21580000
   integer progfile;              << program/sl file number >>          21585000
   integer toolboxid;             << toolbox id to be found >>          21590000
   double  toolboxidlink;         << new toolbox id link >>             21595000
   integer status;                << status returned >>                 21600000
                                                                        21605000
<< this procedure searches the pmap in a program or sl file    >>       21610000
<< for a procedure entry associated with a specified toolbox   >>       21615000
<< id.  if found, the toolbox id link field in that entry will >>       21620000
<< be changed to the value supplied by the caller.  otherwise, >>       21625000
<< the status code will indicate why the search failed.        >>       21630000
                                                                        21635000
begin << updatetoolboxid >>                                             21640000
                                                                        21645000
<< pmap control block allocations: >>                                   21650000
integer array pmapcb(0:pmapcblen - 1);                                  21655000
pmapcbdec;                                                              21660000
                                                                        21665000
<< internal pmap record buffer allocation: >>                           21670000
integer array   ipmapbuf(0:ipmaprecmax - 1);                            21675000
integer pointer ipmapp   = ipmapbuf;                                    21680000
byte    array   ipmapbp(*)  = ipmapbuf;                                 21685000
integer pointer ipmapp1;                                                21690000
double  pointer ipmapdp1 = ipmapp1;                                     21695000
integer segnum;                                                         21700000
integer scancode;                                                       21705000
                                                                        21710000
<< external pmap record buffer allocation: >>                           21715000
integer array xpmapbuf(0:xpmaprecmax - 1);                              21720000
$page                                                                   21725000
subroutine updateiffoundid;                                             21730000
begin                                                                   21735000
   while getipmaprec(ipmapbuf, ipmapp1, scancode,                       21740000
                     pmapcb, status) do                                 21745000
      begin                                                             21750000
      if ipmap'type = pmapproctype and                                  21755000
         ipmap'tboxid = toolboxid then                                  21760000
         begin                                                          21765000
         ipmap'tboxid := toolboxid;                                     21770000
         ipmap'tboxlink := toolboxidlink;                               21775000
         updateipmaprec(ipmapbuf, pmapcb, status);                      21780000
         go exit;                                                       21785000
         end;                                                           21790000
      end;                                                              21795000
end;                                                                    21800000
$page                                                                   21805000
<< updatetoolboxid >>                                                   21810000
                                                                        21815000
   pmapcbinit(progfile, pmapcb, status);                                21820000
   if status <> stat'ok then                                            21825000
      go exit;                                                          21830000
   if ipmapfilecode = progfilecode then                                 21835000
      begin                                                             21840000
         pmapfindsegnum(0, pmapcb, status);                             21845000
         if status <> stat'ok then                                      21850000
            go exit;                                                    21855000
         scancode := scanallsegs;                                       21860000
         updateiffoundid;                                               21865000
      end                                                               21870000
   else                                                                 21875000
      begin                                                             21880000
         segnum:=0;                                                     21885000
         scancode:=scancurseg;                                          21890000
         while segnum < sl0'numsegsalloc do                             21895000
            begin                                                       21900000
               pmapfindsegnum(segnum,pmapcb,status);                    21905000
               if status <> stat'ok then                                21910000
                  if status <> stat'segdeleted and                      21915000
                     status <> stat'nopmap then                         21920000
                     go exit                                            21925000
                  else                                                  21930000
               else                                                     21935000
                  updateiffoundid;                                      21940000
               segnum:=segnum+1;                                        21945000
            end;                                                        21950000
      end;                                                              21955000
                                                                        21960000
   if status = stat'endofpmap then                                      21965000
      status := stat'tboxidnotfound;                                    21970000
                                                                        21975000
exit:                                                                   21980000
   condcode := if status = stat'ok then cce                             21985000
               else if status = stat'tboxidnotfound then ccg            21990000
               else ccl;                                                21995000
                                                                        22000000
   end; << updatetoolboxid >>                                           22005000
$page "CHECKSUM INTRINSIC PROCEDURES - MATCHNAME"                       22010000
logical procedure matchname(name1,name2);                               22015000
byte array name1,name2;                                                 22020000
                                                                        22025000
<< this procedure compare two names and    >>                           22030000
<< return true if two names are the same.  >>                           22035000
<< note : name1 and name2 are byte array   >>                           22040000
<<        containing only characters.      >>                           22045000
<<        they are not formated nameblock. >>                           22050000
<<        must be terminated by a blank.   >>                           22055000
                                                                        22060000
begin                                                                   22065000
   byte array nameblock1(0:16);                                         22070000
   byte array nameblock2(0:16);                                         22075000
   integer status;                                                      22080000
   buildnameblock(nameblock1,17,name1,,status);                         22085000
   buildnameblock(nameblock2,17,name2,,status);                         22090000
   matchname := namesmatch(nameblock1,nameblock2);                      22095000
end;                                                                    22100000
$page "CHECKSUM INTRINSIC"                                              22105000
procedure getchecksum(fnum,segname,segnum,checksum,status);             22110000
                                                                        22115000
value fnum,segnum;                                                      22120000
integer fnum,segnum,status;                                             22125000
byte array segname;                                                     22130000
logical checksum;                                                       22135000
option variable;                                                        22140000
                                                                        22145000
<<********************************************>>                        22150000
<< this procedure retrive the checksum stored >>                        22155000
<< in program or sl file.                     >>                        22160000
<<********************************************>>                        22165000
<< input:                                     >>                        22170000
<<  fnum   : program or sl file number.       >>                        22175000
<<  segname : segment name whose checksum is  >>                        22180000
<<            to be returned.(optional)       >>                        22185000
<<  segnum : segment number whose checksum is >>                        22190000
<<           to be returned.(optional)        >>                        22195000
<<           if segnum = -1 then total check  >>                        22200000
<<           sum is returned.                 >>                        22205000
<<  **note** 1. one or both of the parameters >>                        22210000
<<              'segname' and 'segnum'        >>                        22215000
<<              must be specified. if both    >>                        22220000
<<              specified then they must      >>                        22225000
<<              agree with each other.        >>                        22230000
<<           2. -1 for segnum is only good    >>                        22235000
<<              for program files.            >>                        22240000
<<********************************************>>                        22245000
<< output:                                    >>                        22250000
<<  checksum : check sum returned.            >>                        22255000
<<  status   :                                >>                        22260000
<<   = 0 : checksum returned.                 >>                        22265000
<<   = 1 : segname specified is not the       >>                        22270000
<<         specified segnum.                  >>                        22275000
<<   = 2 : illegal segnum.                    >>                        22280000
<<   = 3 : segname not found.                 >>                        22285000
<<   = 4 : illegal parm specification.        >>                        22290000
<<   = 5 : no checksum in prog/sl file.       >>                        22295000
<<   = 6 : file is not prog/sl file.          >>                        22300000
<<   =12 : i/o error.                         >>                        22305000
<<   = 8 : file opened without read access.   >>                        22310000
<<********************************************>>                        22315000
                                                                        22320000
begin                                                                   22325000
   logical parms = q-4;                                                 22330000
   integer s3=s-3;                                                      22335000
   define                                                               22340000
      segnumspecified = parms.(13:1)#,                                  22345000
      segnamespecified = parms.(12:1)#;                                 22350000
                                                                        22355000
   integer array cksumcb(0:255);                                        22360000
      integer array pf0p(*)         = cksumcb;                          22365000
      logical array pf0lp(*)        = cksumcb;                          22370000
                                                                        22375000
      integer array sl0p(*)         = cksumcb;                          22380000
      logical array sl0lp(*)        = cksumcb;                          22385000
      logical array slrefblockdrecnum(*) = cksumcb(20);                 22390000
      integer array slrefblock(*)   = cksumcb(84);                      22395000
                                                                        22400000
   integer pointer slrefp;                                              22405000
   logical pointer slreflp = slrefp;                                    22410000
   byte pointer slrefbp;                                                22415000
                                                                        22420000
   define                                                               22425000
      stat'unmatch   = 1#,                                              22430000
      stat'badsegnum = 2#,                                              22435000
      stat'segnotfound = 3#,                                            22440000
      stat'badparms  = 4#,                                              22445000
      stat'nocksum   = 5#,                                              22450000
      stat'badfile   = 6#,                                              22455000
      stat'ioerror   = 7#,                                              22460000
      stat'badfopen  = 8#;                                              22465000
                                                                        22470000
   integer pointer segdesc;                                             22475000
                                                                        22480000
   define                                                               22485000
      pf0'totalcksum  = pf0lp(19)#,                                     22490000
      pf0'cksumok     = pf0lp(18).(1:1)#;                               22495000
                                                                        22500000
   define                                                               22505000
      slref'cksumok = slreflp(6).(1:1)#;                                22510000
                                                                        22515000
   logical       pa'checksum;                                           22520000
   logical array pa'segnamela(0:8);                                     22525000
   byte array    pa'segname(*)=pa'segnamela;                            22530000
                                                                        22535000
   logical array buf(0:127);                                            22540000
                                                                        22545000
   integer       curseg'rec,                                            22550000
                 curseg'num,                                            22555000
                 curseg'len,                                            22560000
                 curseg'temprec,                                        22565000
                                                                        22570000
                 sttlen,                                                22575000
                 patchlen,                                              22580000
                 recdisp;                                               22585000
                                                                        22590000
   logical slrefloaded;                                                 22595000
   integer reqrefblock;                                                 22600000
   integer currefblock;                                                 22605000
                                                                        22610000
   logical aoption;                                                     22615000
   integer filecode;                                                    22620000
$page "GETSEGMENT"                                                      22625000
subroutine getsegment(segno);                                           22630000
value segno;                                                            22635000
integer segno;                                                          22640000
                                                                        22645000
   if filecode = progfilecode then                                      22650000
      while segno > curseg'num do                                       22655000
         begin                                                          22660000
            curseg'rec:=curseg'rec+(curseg'len+127)/128;                22665000
            curseg'num:=curseg'num+1;                                   22670000
            curseg'len:=segdesc(curseg'num).(2:14);                     22675000
         end                                                            22680000
   else  << sl file >>                                                  22685000
      begin                                                             22690000
         reqrefblock:=segno/slrefblockfact;                             22695000
         if not slrefloaded or reqrefblock <> currefblock               22700000
            then begin                                                  22705000
               freaddir(fnum,slrefblock,128,                            22710000
               double(slrefblockdrecnum(reqrefblock)));                 22715000
               checkipmapio;                                            22720000
               currefblock:=reqrefblock;                                22725000
               slrefloaded:=true;                                       22730000
            end;                                                        22735000
         mapslrefent(slrefblock((segno mod 4)*32),slrefp,               22740000
                     slrefbp);                                          22745000
         curseg'len:=slref'segnumwds;                                   22750000
         curseg'rec:=slref'codedrecnum;                                 22755000
      end;                                                              22760000
$page "ADJUSTRECDISP"                                                   22765000
subroutine adjustrecdisp(len);                                          22770000
value len;                                                              22775000
integer len;                                                            22780000
                                                                        22785000
begin                                                                   22790000
   curseg'temprec:=curseg'temprec-len/128;                              22795000
   len:=len mod 128;                                                    22800000
   if len > recdisp then                                                22805000
      begin                                                             22810000
         recdisp:=recdisp+128-len;                                      22815000
         curseg'temprec:=curseg'temprec-1;                              22820000
      end                                                               22825000
   else                                                                 22830000
      recdisp:=recdisp-len;                                             22835000
end;                                                                    22840000
$page "GETPATCHAREA"                                                    22845000
   subroutine getpatcharea;                                             22850000
                                                                        22855000
   begin                                                                22860000
      tos:=curseg'len;                                                  22865000
      tos:=128;                                                         22870000
      assemble(div);                                                    22875000
      recdisp:=tos;                                                     22880000
      curseg'temprec:=curseg'rec+tos;                                   22885000
      if recdisp=0 then                                                 22890000
         begin                                                          22895000
            recdisp:=127;                                               22900000
            curseg'temprec:=curseg'temprec-1;                           22905000
         end                                                            22910000
      else                                                              22915000
         recdisp:=recdisp-1;                                            22920000
                                                                        22925000
      << find stt length >>                                             22930000
                                                                        22935000
      freaddir(fnum,buf,128,double(curseg'temprec));                    22940000
      checkipmapio;                                                     22945000
      sttlen:=integer(buf(recdisp).(8:8))+1;                            22950000
                                                                        22955000
      << find patch size >>                                             22960000
                                                                        22965000
      adjustrecdisp(sttlen);                                            22970000
      freaddir(fnum,buf,128,double(curseg'temprec));                    22975000
      checkipmapio;                                                     22980000
      patchlen:=integer(buf(recdisp))+1;                                22985000
                                                                        22990000
      << find patch area >>                                             22995000
                                                                        23000000
      adjustrecdisp(patchlen);                                          23005000
      if recdisp < 127 then                                             23010000
         begin                                                          23015000
            freaddir(fnum,buf,128,double(curseg'temprec-1));            23020000
            checkipmapio;                                               23025000
            move buf:=buf(recdisp+1),(127-recdisp);                     23030000
         end;                                                           23035000
      freaddir(fnum,buf(127-recdisp),recdisp+1,                         23040000
               double(curseg'temprec));                                 23045000
      checkipmapio;                                                     23050000
      pa'checksum:=buf(123);                                            23055000
      move pa'segnamela:=buf(114),(8);                                  23060000
   end;                                                                 23065000
$page "GETCKSUMBYNAME"                                                  23070000
   subroutine getcksumbyname(numsegs);                                  23075000
                                                                        23080000
   value numsegs;                                                       23085000
   integer numsegs;                                                     23090000
                                                                        23095000
   begin                                                                23100000
      segnum := 0;                                                      23105000
      while segnum < numsegs do                                         23110000
         begin                                                          23115000
            getsegment(segnum);                                         23120000
            if filecode = slfilecode then                               23125000
               if matchname(slref'segname0,segname) and                 23130000
                  not slref'deleted then                                23135000
                  begin                                                 23140000
                     if not slref'cksumok then                          23145000
                        begin                                           23150000
                           status:=stat'nocksum;                        23155000
                           return;                                      23160000
                        end;                                            23165000
                     getpatcharea;                                      23170000
                     checksum:=pa'checksum;                             23175000
                     return;                                            23180000
                  end                                                   23185000
               else                                                     23190000
            else                                                        23195000
               begin                                                    23200000
                  getpatcharea;                                         23205000
                  if matchname(pa'segname,segname) then                 23210000
                     begin                                              23215000
                        checksum := pa'checksum;                        23220000
                        return;                                         23225000
                     end;                                               23230000
               end;                                                     23235000
            segnum := segnum + 1;                                       23240000
         end;                                                           23245000
      status:=stat'segnotfound;                                         23250000
   end;                                                                 23255000
$page "GETCKSUMBYNUM"                                                   23260000
   subroutine getcksumbynum(numsegs);                                   23265000
                                                                        23270000
   value numsegs;                                                       23275000
   integer numsegs;                                                     23280000
                                                                        23285000
   begin                                                                23290000
      if not ( 0 <= segnum <= numsegs-1 ) then                          23295000
         begin                                                          23300000
            status:=stat'badsegnum;                                     23305000
            return;                                                     23310000
         end;                                                           23315000
      getsegment(segnum);                                               23320000
      if filecode = slfilecode then                                     23325000
         begin                                                          23330000
            if slref'deleted then                                       23335000
               begin                                                    23340000
                  status:=stat'badsegnum;                               23345000
                  return;                                               23350000
               end;                                                     23355000
            if segnamespecified then                                    23360000
               if not matchname(slref'segname0,segname) then            23365000
                  begin                                                 23370000
                     status:=stat'unmatch;                              23375000
                     return;                                            23380000
                  end;                                                  23385000
            if not slref'cksumok then                                   23390000
               begin                                                    23395000
                  status:=stat'nocksum;                                 23400000
                  return;                                               23405000
               end;                                                     23410000
         end;                                                           23415000
      getpatcharea;                                                     23420000
      if segnamespecified and filecode = progfilecode then              23425000
         if not matchname(pa'segname,segname) then                      23430000
            begin                                                       23435000
               status:=stat'unmatch;                                    23440000
               return;                                                  23445000
            end;                                                        23450000
      checksum:=pa'checksum;                                            23455000
   end;                                                                 23460000
$page "CHECKSUM INTRINSIC - MAIN"                                       23465000
   status:=stat'ok;                                                     23470000
   if (parms <> %(2)11111) and                                          23475000
      (parms <> %(2)11011) and                                          23480000
      (parms <> %(2)10111) then                                         23485000
      begin                                                             23490000
         status := stat'badparms;                                       23495000
         return;                                                        23500000
      end;                                                              23505000
   fgetinfo(fnum,,,aoption,,,,,filecode);                               23510000
   if filecode <> progfilecode and                                      23515000
      filecode <> slfilecode then                                       23520000
      begin                                                             23525000
         status := stat'badfile;                                        23530000
         return;                                                        23535000
      end;                                                              23540000
   if 1 <= integer(aoption.(12:4)) <= 3 then                            23545000
      begin                                                             23550000
         status := stat'badfopen;                                       23555000
         return;                                                        23560000
      end;                                                              23565000
   slrefloaded:=false;                                                  23570000
   if filecode = progfilecode then                                      23575000
      begin                                                             23580000
         freaddir(fnum,pf0lp,128,0d);                                   23585000
         checkipmapio;                                                  23590000
         if not pf0'cksumok then                                        23595000
            begin                                                       23600000
               status:=stat'nocksum;                                    23605000
               return;                                                  23610000
            end;                                                        23615000
         freaddir(fnum,pf0lp(128),128,1d);                              23620000
         checkipmapio;                                                  23625000
         @segdesc:=@pf0p(28+(pf0'numsegs+1)/2);                         23630000
         curseg'rec:=pf0'firstsegdrecnum;                               23635000
         curseg'num:=0;                                                 23640000
         curseg'len:=segdesc(curseg'num).(2:14);                        23645000
                                                                        23650000
         if segnumspecified then                                        23655000
            if segnum=-1 then                                           23660000
               begin                                                    23665000
                  if segnamespecified then                              23670000
                     begin                                              23675000
                        status := stat'unmatch;                         23680000
                        return;                                         23685000
                     end;                                               23690000
                  checksum := pf0'totalcksum;                           23695000
               end                                                      23700000
            else                                                        23705000
               getcksumbynum(pf0'numsegs)                               23710000
         else  << segname specified >>                                  23715000
            getcksumbyname(pf0'numsegs);                                23720000
      end                                                               23725000
   else  << sl file >>                                                  23730000
      begin                                                             23735000
         freaddir(fnum,sl0p,12,0d);                                     23740000
         checkipmapio;                                                  23745000
         freaddir(fnum,slrefblockdrecnum,64,1d);                        23750000
         checkipmapio;                                                  23755000
         if segnumspecified then                                        23760000
            getcksumbynum(sl0'numsegsalloc)                             23765000
         else  << segname specified >>                                  23770000
            getcksumbyname(sl0'numsegsalloc);                           23775000
      end;                                                              23780000
end;                                                                    23785000
$control segment=main                                                   23790000
end.                                                                    23795000
