$CONTROL USLINIT, CODE, MAP                                             00010000
                                                                        00014000
<<------------------------------------------------------------->>       00016000
<<                                                             >>       00018000
<<                  MPE Segmenter Intrinsics                   >>       00020000
<<                    SEGUTIL  (Module 71)                     >>       00022000
<<                                                             >>       00024000
<<                      Version  A.01.07                       >>       00026000
<<                     January 30, 1982                        >>       00028000
<<                                                             >>       00030000
<<------------------------------------------------------------->>       00032000
                                                                        00034000
$COPYRIGHT "(C) COPYRIGHT HEWLETT-PACKARD COMPANY 1981.  ",  &          00036000
$          "THIS PROGRAM MAY BE USED WITH ONE COMPUTER ",    &          00038000
$          "SYSTEM AT A TIME AND SHALL NOT OTHERWISE BE ",   &          00040000
$          "RECORDED, TRANSMITTED OR STORED IN A RETRIEVAL ",&          00042000
$          "SYSTEM.  COPYING OR OTHER REPRODUCTION OF THIS ",&          00044000
$          "PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS ",       &          00046000
$          "PROHIBITED WITHOUT THE PRIOR WRITTEN CONSENT ",  &          00048000
$          "OF HEWLETT-PACKARD COMPANY."                                00050000
                                                                        00052000
$TITLE "       MPE SEGMENTER UTILITIES - JANUARY 30, 1982"              00054000
$CONTROL MAIN = SEGUTIL'3000                                            00056000
$CONTROL SEGMENT = SEGUTIL                                              00058000
                                                                        00060000
begin                                                                   00062000
$PAGE                                                                   00064000
<<------------------------------------------------------------->>       00066000
<<                                                             >>       00068000
<< Access to last stack marker.                                >>       00070000
<<                                                             >>       00072000
<<------------------------------------------------------------->>       00074000
                                                                        00076000
logical ParmFlags = Q - 4;        << Option variable bit map >>         00078000
integer StatusReg = Q - 1;        << Status register returned >>        00080000
                                                                        00082000
define                                                                  00084000
   CondCode = StatusReg.(6:2)#,   << Condition code returned >>         00086000
      CCE   = 2#,                                                       00088000
      CCG   = 0#,                                                       00090000
      CCL   = 1#;                                                       00092000
                                                                        00094000
INTEGER XREG = X;                                                       00096000
INTEGER S0 = S-0;                                                       00098000
INTEGER S1 = S-1;                                                       00100000
INTEGER S2 = S-2;                                                       00102000
INTEGER S5 = S-5;                                                       00104000
INTEGER S6 = S-6;                                                       00106000
INTEGER S7 = S-7;                                                       00108000
INTEGER S11 = S-11;                                                     00110000
INTEGER S12 = S-12;                                                     00112000
INTEGER S13 = S-13;                                                     00114000
LOGICAL LS0 = S-0;                                                      00116000
DOUBLE DS1 = S-1;                                                       00118000
DOUBLE DS2 = S-2;                                                       00120000
DOUBLE DS4 = S-4;                                                       00122000
   BYTE POINTER BPS0 = S-0;                                             00124000
BYTE POINTER BPS13 = S-13;                                              00126000
INTEGER POINTER PS0 = S-0;                                              00128000
                                                                        00130000
<<SYSTEM CONSTANTS>>                                                    00132000
                                                                        00134000
EQUATE CPCB = 4,                                                        00136000
       PCBSIZE = 16;                                                    00138000
                                                                        00140000
$PAGE "USL INTRINSIC ERROR NUMBER"                             <<00207>>00142000
                                                                        00144000
EQUATE ERR0 = 0,  <<UNEXPECTED EOF>>                                    00146000
       ERR1 = 1,  <<UNEXPECTED I/O ERROR>>                              00148000
       ERR2 = 2,  <<INVALID FILE CODE>>                                 00150000
       ERR3 = 3,  <<ILLEGAL FILE LENGTH>>                               00152000
       ERR4 = 4,  <<ATTEMPT TO EXCEED MAX. DIRECTORY SIZE (32K)>>       00154000
       ERR5 = 5,  <<INSUFFICIENT DIRECTORY SPACE>>                      00156000
       ERR6 = 6,  <<INSUFFICIENT INFO SPACE>>                           00158000
       ERR7 = 7,  <<UNABLE TO OPEN NEW USL FILE>>                       00160000
       ERR8 = 8,  <<UNABLE TO CLOSE (PURGE) OLD USL FILE>>              00162000
       ERR9 = 9,  <<UNABLE TO CLOSE (PURGE) NEW USL FILE>>              00164000
       ERR10 = 10,  <<UNABLE TO CLOSE $NEWPASS>>                        00166000
       ERR11 = 11,  <<UNABLE TO OPEN $OLDPASS>>                <<00207>>00168000
       ILLEGALUSL=12; <<ILLEGAL USL FORMAT>>                   <<00207>>00170000
                                                                        00172000
$PAGE "USL RECORD 0 PARAMETERS"                                <<00207>>00174000
                                                                        00176000
EQUATE USLFILECODE = 1024;  <<USL FILE CODE>>                           00178000
DEFINE USLLID = REC0#,  <<LOADER ID>>                                   00180000
       USLNE = REC0(1)#,  <<NR. DIRECTORY ENTRIES>>                     00182000
       USLDL = REC0(2)#,  <<DIRECTORY LENGTH>>                          00184000
       USLTDG = REC0(3)#,  <<TOTAL DIRECTORY GARBAGE>>                  00186000
       USLNDG = REC0(4)#,  <<NR. DIRECTORY GARBAGE ENTRIES>>            00188000
       USLBDL = REC0(5)#,  <<S.A. BLOCK DATA LIST>>                     00190000
       USLIPL = REC0(6)#,  <<S.A. INTERUPT PROCEDURE LIST>>             00192000
       USLSL = REC0(7)#,  <<S.A. SEGMENT LIST>>                         00194000
       USLFL = DREC0(4)#,  <<FILE LENGTH>>                              00196000
       USLSAAD = REC0(10)#,  <<S.A. DIRECTORY AVAILABLE BLOCK>>         00198000
       USLADL = REC0(11)#,  <<DIRECTORY AVAILABLE BLOCK LENGTH>>        00200000
       USLSAI = DREC0(6)#,  <<S.A. INFO BLOCK>>                         00202000
       USLIL = DREC0(7)#,  <<INFO BLOCK LENGTH>>                        00204000
       USLIL2 = REC0(15)#,  <<SECOND HALF>>                             00206000
       USLSAAI = DREC0(8)#,  <<S.A. INFO AVAILABLE BLOCK>>              00208000
       USLAIL = DREC0(9)#,  <<INFO AVAILABLE BLOCK LENGTH>>             00210000
       USLTIG = DREC0(10)#,  <<TOTAL INFO GARBAGE>>                     00212000
       USLNIG = REC0(22)#;  <<NR. INFO GARBAGE ENTRIES>>                00214000
$PAGE "PROGRAM FILE PMAP INTRINSICS - ",&                               00218000
$     "PARAMETERS AND DEFINITIONS"                                      00220000
<<------------------------------------------------------------->>       00222000
<<                                                             >>       00224000
<< System-tunable parameters.                                  >>       00226000
<<                                                             >>       00228000
<<------------------------------------------------------------->>       00230000
                                                                        00232000
equate                                                                  00234000
   IPMAPBUFNUMDRECS     = 2,      << Internal PMAP buffer      >>       00236000
                                  <<   length in disc records. >>       00238000
                                  <<   Must be at least 2.     >>       00240000
   NAMEBLOCKNUMWDS      = 8;                                            00242000
                                                                        00244000
<<------------------------------------------------------------->>       00246000
<<                                                             >>       00248000
<< System constants.                                           >>       00250000
<<                                                             >>       00252000
<<------------------------------------------------------------->>       00254000
                                                                        00256000
equate                                                                  00258000
   DRECNUMWDS           = 128,    << Disc rec length in words >>        00260000
   DRECNUMDBLS          = DRECNUMWDS / 2, << and doublewords >>         00262000
                                                                        00264000
   IPMAPBUFNUMWDS       = IPMAPBUFNUMDRECS * DRECNUMWDS;                00266000
                                                                        00268000
<<------------------------------------------------------------->>       00270000
<<                                                             >>       00272000
<< Miscellaneous constants.                                    >>       00274000
<<                                                             >>       00276000
<<------------------------------------------------------------->>       00278000
                                                                        00280000
equate                                                                  00282000
   MAXINT               = 32767,  << Maximum integer >>                 00284000
   SYMNAMEMAX           =    15;  << Max # chars in a name >>           00286000
$PAGE                                                                   00288000
<<------------------------------------------------------------->>       00290000
<<                                                             >>       00292000
<< Error status codes returned by the PMAP intrinsics.         >>       00294000
<<                                                             >>       00296000
<<------------------------------------------------------------->>       00298000
                                                                        00300000
equate                                                                  00302000
   STAT'OK                 =   0, << No errors were detected. >>        00304000
   STAT'ENTNAMENOTFOUND    =   1, << The entry point name      >>       00306000
                                  <<   couldn't be located.    >>       00308000
   STAT'BADADDRESS         =   2, << The address to be located >>       00310000
                                  <<   was outside the bounds  >>       00312000
                                  <<   of the specified seg.   >>       00314000
   STAT'BADSEGID           =   3, << The program/SL file did   >>       00316000
                                  <<   not contain the speci-  >>       00318000
                                  <<   fied segment.           >>       00320000
   STAT'SEGDELETED         =   3, << The requested SL segment  >>       00322000
                                  <<   was marked as deleted.  >>       00324000
   STAT'XPMAPFILEFULL      =   4, << The external PMAP file    >>       00326000
                                  <<   wasn't large enough.    >>       00328000
   STAT'TBOXIDNOTFOUND     =   5, << The TOOLBOX ID couldn't   >>       00330000
                                  <<   be located.             >>       00332000
   STAT'MISSINGPARMS       =   9, << The option variable pa-   >>       00334000
                                  <<   rameter list was ille-  >>       00336000
                                  <<   gal.                    >>       00338000
   STAT'NOPMAP             =  10, << The program/SL file did   >>       00340000
                                  <<   not contain a PMAP.     >>       00342000
   STAT'BADFILECODE        =  11, << The program/SL file code  >>       00344000
                                  <<   was not that of a pro-  >>       00346000
                                  <<   gram/SL file.           >>       00348000
   STAT'BADLOADERID        =  11, << The SL loader ID was not  >>       00350000
                                  <<   compatible with this    >>       00352000
                                  <<   version of the PMAP     >>       00354000
                                  <<   intrinsics.             >>       00356000
   STAT'IPMAPIOERR         =  12, << File system error on the  >>       00358000
                                  <<   program/SL file.        >>       00360000
   STAT'XPMAPIOERR         =  13, << File system error on the  >>       00362000
                                  <<   external PMAP file.     >>       00364000
   STAT'IPMAPBADFOPEN      =  14; << Internal PMAP file im-    >>       00366000
                                  <<   properly FOpened.       >>       00368000
$PAGE                                                                   00370000
<<------------------------------------------------------------->>       00372000
<<                                                             >>       00374000
<< Status codes returned by internal PMAP support procedures.  >>       00376000
<<                                                             >>       00378000
<<------------------------------------------------------------->>       00380000
                                                                        00382000
equate                                                                  00384000
   STAT'ENDOFPMAP          = 100; << End of PMAP sensed. >>             00386000
                                                                        00388000
<<------------------------------------------------------------->>       00390000
<<                                                             >>       00392000
<< Scan codes used by GetNextIPmapRec.                         >>       00394000
<<                                                             >>       00396000
<<------------------------------------------------------------->>       00398000
                                                                        00400000
equate                                                                  00402000
   SCANALLSEGS     = 0,           << Scan all PMAP segments >>          00404000
   SCANCURSEG      = 1;           << Scan current PMAP segment >>       00406000
$PAGE "GENERAL-PURPOSE CODE FILE FIELD DEFINITIONS"                     00408000
<<------------------------------------------------------------->>       00410000
<<                                                             >>       00412000
<< Name block field definitions.                               >>       00414000
<<                                                             >>       00416000
<<------------------------------------------------------------->>       00418000
<<                                                             >>       00420000
<< A name block is a variable-length structure used to store   >>       00422000
<< the symbolic name of an entity in a code file, and is usu-  >>       00424000
<< ally found embedded within a larger structure representing  >>       00426000
<< the entity being named.                                     >>       00428000
<<                                                             >>       00430000
<< Always interpreted as a byte array on the lowest level,     >>       00432000
<< name blocks are sometimes declared as integer arrays when   >>       00434000
<< they are aligned on word boundaries.  Since name blocks     >>       00436000
<< should only be manipulated by special name block utility    >>       00438000
<< routines, this inconsistency should not prove to be incon-  >>       00440000
<< venient.                                                    >>       00442000
<<                                                             >>       00444000
<< The length of a name in a name block is indicated by a      >>       00446000
<< length field stored in the block's first byte.  If the val- >>       00448000
<< ue is non-zero, it represents the length of the name in     >>       00450000
<< bytes.  Otherwise, the name must be scanned for the first   >>       00452000
<< blank or null character, which terminates the name.         >>       00454000
<<                                                             >>       00456000
<<------------------------------------------------------------->>       00458000
                                                                        00460000
define                                                                  00462000
   NB'Flags     = 0).(8:4#,       << Misc. control flags >>             00464000
   NB'NumCh = 0).(12:4#,          << Name length >>                     00466000
   NB'Name0     = 1#;             << 1st char of symbolic name >>       00468000
$PAGE                                                                   00470000
<<------------------------------------------------------------->>       00472000
<<                                                             >>       00474000
<< Data descriptor field definitions.                          >>       00476000
<<                                                             >>       00478000
<<------------------------------------------------------------->>       00480000
<<                                                             >>       00482000
<< Data descriptors are single-word structures which describe  >>       00484000
<< data passed to procedures and data returned as procedure    >>       00486000
<< values.                                                     >>       00488000
<<                                                             >>       00490000
<< The leftmost bit of a data descriptor is called the "user-  >>       00492000
<< defined type bit" (or U bit for short) and determines the   >>       00494000
<< interpretation of the remaining bits.  If the U bit is 1,   >>       00496000
<< the remaining bits represent a user-defined data type de-   >>       00498000
<< clared in a PASCAL program.  If the U bit is 0, the data    >>       00500000
<< type is not user-defined, and the remaining bits are inter- >>       00502000
<< preted as follows:                                          >>       00504000
<<                                                             >>       00506000
<< Mode (bits 1 through 3):                                    >>       00508000
<<   0 - Undefined mode.                                       >>       00510000
<<   1 - Call by value.                                        >>       00512000
<<   2 - Call by reference.                                    >>       00514000
<<   3 - Call by name.                                         >>       00516000
<<                                                             >>       00518000
<< Structure (bits 4 through 9):                               >>       00520000
<<   0 - Simple variable.                                      >>       00522000
<<   1 - Pointer Variable.                                     >>       00524000
<<   2 - Array.                                                >>       00526000
<<   3 - Procedure.                                            >>       00528000
<<                                                             >>       00530000
<< Type (bits 10 through 15):                                  >>       00532000
<<   0 - Undefined type.   6 - Long.                           >>       00534000
<<   1 - Logical.          7 - Complex.                        >>       00536000
<<   2 - Integer.          8 - SPL label.                      >>       00538000
<<   3 - Byte.             9 - FORTRAN character array.        >>       00540000
<<   4 - Real.            10 - FORTRAN label.                  >>       00542000
<<   5 - Double.          11 - Wild card (matches any type).   >>       00544000
<<                                                             >>       00546000
<< A data descriptor of all zeroes is treated as a wild card   >>       00548000
<< and is compatible with (i.e., will match) any other data    >>       00550000
<< descriptor.                                                 >>       00552000
<<                                                             >>       00554000
<<------------------------------------------------------------->>       00556000
                                                                        00558000
define                                                                  00560000
   DD'UserType     = (0:1)#,                                            00562000
   DD'UserTypeCode = (1:15)#,                                           00564000
                                                                        00566000
   DD'Mode         = (1:3)#,                                            00568000
   DD'Structure    = (4:6)#,                                            00570000
   DD'Type         = (10:6)#;                                           00572000
$PAGE                                                                   00574000
<<------------------------------------------------------------->>       00576000
<<                                                             >>       00578000
<< Parameter descriptor array field definitions.               >>       00580000
<<                                                             >>       00582000
<<------------------------------------------------------------->>       00584000
<<                                                             >>       00586000
<< Parameter descriptor arrays (PDAs) describe formal and      >>       00588000
<< actual calling sequences to procedures.  They are used by   >>       00590000
<< the Segmenter and Loader to check actual vs. formal calling >>       00592000
<< sequences when RBMs are bound to one another at PREP and    >>       00594000
<< RUN time.                                                   >>       00596000
<<                                                             >>       00598000
<< The structure of a complete PDA is as follows:              >>       00600000
<<                                                             >>       00602000
<<   0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15            >>       00604000
<< +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+           >>       00606000
<< |Level| Number of parms |   FORTRAN char count  | 0 1 2 3   >>       00608000
<< +-----------------------------------------------+           >>       00610000
<< |        Procedure value data descriptor        |   1 2 3   >>       00612000
<< +-----------------------------------------------+           >>       00614000
<< |      Data descriptor for first parameter      |       3   >>       00616000
<< +-----------------------------------------------+           >>       00618000
<< ~                                               ~           >>       00620000
<< +-----------------------------------------------+           >>       00622000
<< |      Data descriptor for last parameter       |       3   >>       00624000
<< +-----------------------------------------------+           >>       00626000
<<                                                             >>       00628000
<< PDAs are variable in length, depending on the Level (of     >>       00630000
<< checking) field in the first word.  The numbers to the      >>       00632000
<< right of each word in the diagram indicate the level of     >>       00634000
<< checking required for the word to be present.               >>       00636000
<<                                                             >>       00638000
<< In the first word, if Level = 0 (no checking) then none of  >>       00640000
<< the remaining fields contain meaningful data.  If Level > 0 >>       00642000
<< and the procedure value is a FORTRAN character array (as    >>       00644000
<< determined by the second word of the PDA), then the number  >>       00646000
<< of characters in the array are stored as shown in the first >>       00648000
<< word.  If Level > 1 then the number-of-parameters field in  >>       00650000
<< the first word is valid.                                    >>       00652000
<<                                                             >>       00654000
<<------------------------------------------------------------->>       00656000
                                                                        00658000
define                                                                  00660000
   PDA'CheckLevel = 0).(0:2#,     << Level of checking >>               00662000
   PDA'NumParms   = 0).(2:6#,     << Level =    2 or 3 >>               00664000
   PDA'NumChars   = 0).(8:8#,     << Level = 1, 2 or 3 >>               00666000
   PDA'ProcDesc   = 1#,           << Level = 1, 2 or 3 >>               00668000
   PDA'ParmDesc0  = 2#;           << Level =         3 >>               00670000
$PAGE "PROGRAM FILE FIELD DEFINITIONS"                                  00672000
<<------------------------------------------------------------->>       00674000
<<                                                             >>       00676000
<< Miscellaneous program file constants.                       >>       00678000
<<                                                             >>       00680000
<<------------------------------------------------------------->>       00682000
                                                                        00684000
equate                                                                  00686000
   PROGFILECODE    = 1029,        << File system file code >>           00688000
   PF'MAXNUMSEGS   = 255;         << Max # of segments >>               00690000
                                                                        00692000
<<------------------------------------------------------------->>       00694000
<<                                                             >>       00696000
<< Program File Header (Record 0).                             >>       00698000
<<                                                             >>       00700000
<<------------------------------------------------------------->>       00702000
<<                                                             >>       00704000
<< The program file header is found in the first few records   >>       00706000
<< of the program file and contains information which locates  >>       00708000
<< major areas in the remainder of the file, as well as con-   >>       00710000
<< taining miscellaneous data required for loading of the pro- >>       00712000
<< gram.                                                       >>       00714000
<<                                                             >>       00716000
<< In most cases, the program file header will be placed en-   >>       00718000
<< tirely within record 0.  However, the larger number of code >>       00720000
<< segments made possible by the CST expansion project may     >>       00722000
<< cause the header to overflow into records 1 and 2, due to   >>       00724000
<< the CST Remapping Array and the Segment Descriptor Array,   >>       00726000
<< both of whose lengths are determined by the number of seg-  >>       00728000
<< ments present.  More than 66 segments will cause overflow   >>       00730000
<< into record 1, and more than 151 segments will cause over-  >>       00732000
<< flow into record 2.                                         >>       00734000
<<                                                             >>       00736000
<< Each time a program is loaded, the loader places the logon  >>       00738000
<< group and account names from the job or session requesting  >>       00740000
<< the load in the last 16 words of the last record used by    >>       00742000
<< the program file header.                                    >>       00744000
<<                                                             >>       00746000
<<------------------------------------------------------------->>       00748000
<<                                                             >>       00750000
<< Pointers referenced:                                        >>       00752000
<<                                                             >>       00754000
<<    PF0P  - Integer pointer to 1st word of program file      >>       00756000
<<    PF0LP - Logical pointer to 1st word of program file      >>       00758000
<<            header.                                          >>       00760000
<<            header.                                          >>       00762000
<<    PF0BP - Byte pointer to 1st byte of program file header. >>       00764000
<<                                                             >>       00766000
<<------------------------------------------------------------->>       00768000
                                                                        00770000
$PAGE                                                                   00772000
equate                                                                  00774000
   PF0'INFONUMWDS     = 28;         << Length of info block >>          00776000
define                                                                  00778000
   PF0'Flags           = PF0LP#,    << Misc flags >>                    00780000
      PF0'FatalErr     = PF0LP.(0:1)#,                                  00782000
                                    << True if fatal error was >>       00784000
                                    <<  detected by the com-   >>       00786000
                                    <<  piler for at least one >>       00788000
                                    <<  procedure in the file. >>       00790000
      PF0'Warning      = PF0LP.(1:1)#,                                  00792000
                                    << True if warning was     >>       00794000
                                    <<  was generated by com-  >>       00796000
                                    <<  piler for at least one >>       00798000
                                    <<  procedure in the file. >>       00800000
      PF0'ZeroDb       = PF0LP.(2:1)#,                                  00802000
                                    << True if initial DL area >>       00804000
                                    <<  should be initialized  >>       00806000
                                    <<  with zeroes by Loader  >>       00808000
                                    <<  (ZERODB).              >>       00810000
      PF0'PrivSegs     = PF0LP.(3:1)#,                                  00812000
                                    << True if one or more     >>       00814000
                                    <<  segments in the file   >>       00816000
                                    <<  are privileged.        >>       00818000
      PF0'Zeroed       = PF0LP.(4:1)#,                                  00820000
                                    << True means *'d fields   >>       00822000
                                    <<  below are valid; false >>       00824000
                                    <<  means they're not.     >>       00826000
      PF0'Caps         = PF0LP.(7:9)#,                                  00828000
                                    << Capabilities required   >>       00830000
                                    <<  to execute the program >>       00832000
                                    <<  (CAP = caplist).       >>       00834000
   PF0'NumSegs         = PF0P(1)#,  << # segments in file >>            00836000
   PF0'DbToQiNumWds    = PF0P(2)#,  << Size of global stack >>          00838000
   PF0'DbToQiDRecNum   = PF0P(3)#,  << Initial global image >>          00840000
   PF0'FirstSegDRecNum = PF0P(4)#,  << First code segment >>            00842000
   PF0'QiToZiNumWds    = PF0P(5)#,  << Initial stack size >>            00844000
                                    <<   (STACK   = stacksize) >>       00846000
   PF0'DlToDbNumWds    = PF0P(6)#,  << Initial DL area size    >>       00848000
                                    <<   (DL   = dlsize).      >>       00850000
   PF0'DlToZmaxNumWds  = PF0P(7)#,  << Maximum stack size      >>       00852000
                                    <<   (MAXDATA  = segsize). >>       00854000
   PF0'EntListDRecNum  = PF0P(8)#,  << Entry point list >>              00856000
   PF0'StartSegNum     = PF0P(9)#,  << Starting segment # >>            00858000
   PF0'MainEntAddr     = PF0P(10)#, << Main entry point addr >>         00860000
   PF0'StltAddr        = PF0P(11)#, << DB-rel addr of STLT >>           00862000
   PF0'FlutAddr        = PF0P(12)#, << DB-rel addr of FLUT >>           00864000
   PF0'ExtListDRecNum  = PF0P(13)#, << External list >>                 00866000
   PF0'MainEntSttNum   = PF0P(14)#, << STT # of main entry >>           00868000
   PF0'TrapComAddr     = PF0P(15)#, << ? >>                             00870000
   PF0'PmapDRecNum     = PF0P(16)#, << *PMAP area >>                    00872000
   PF0'SymDbugDRecNum  = PF0P(17)#, << *TOOLBOX sym debug info >>       00874000
   PF0'CstRemap0       = PF0BP(56)#,                                    00876000
                                    << CST remapping array;    >>       00878000
                                    <<   gives last CST # as-  >>       00880000
                                    <<   signed to each logi-  >>       00882000
                                    <<   cal segment.          >>       00884000
   PF0'SegDescrip0     = PF0P(28 + (PF0'NumSegs + 1) / 2)#,             00886000
                                    << Segment descriptor array>>       00888000
      PF0'PrivSeg      = (0:1)#,    << True if privileged seg >>        00890000
      PF0'NewStt       = (1:1)#,    << True if segment's STT   >>       00892000
                                    <<   is in new format for  >>       00894000
                                    <<   CST expansion project.>>       00896000
      PF0'SegNumWds    = (2:14)#;   << Segment length, includ- >>       00898000
                                    <<   ing the STT.          >>       00900000
$PAGE                                                                   00902000
<<------------------------------------------------------------->>       00904000
<<                                                             >>       00906000
<< Program File External List Entries.                         >>       00908000
<<                                                             >>       00910000
<<------------------------------------------------------------->>       00912000
<<                                                             >>       00914000
<< Pointers referenced:                                        >>       00916000
<<                                                             >>       00918000
<<    PFEBP - Byte pointer to 1st byte of entry.               >>       00920000
<<    PFEP1 - Integer pointer to 1st word after name in entry. >>       00922000
<<                                                             >>       00924000
<<------------------------------------------------------------->>       00926000
                                                                        00928000
define                                                                  00930000
   PFExt'PTRDECS =                                                      00932000
      byte    pointer PFEBP;                                            00934000
      integer pointer PFEP1#,                                           00936000
   PFEXT'PTRS = PFEBP, PFEP1#;                                          00938000
                                                                        00940000
define                                                                  00942000
   PFExt'NameBlock     = PFEBP#,    << Name block length byte >>        00944000
   PFExt'NameNumCh     = PFEBP.(12:4)#,                                 00946000
   PFExt'NameCh0       = PFEBP(1)#,                                     00948000
   PFExt'NumRefs       = PFEP1#,    << # references to external>>       00950000
   PFExt'RefId0        = PFEP1(1)#, << Segment reference list >>        00952000
      PFExt'RefSttNum  = (0:8)#,    << STT entry containing ref>>       00954000
      PFExt'RefSegNum  = (8:8)#;    << Segment containing ref >>        00956000
$PAGE "SL FILE FIELD DEFINITIONS"                                       00958000
<<------------------------------------------------------------->>       00960000
<<                                                             >>       00962000
<< Miscellaneous SL file constants.                            >>       00964000
<<                                                             >>       00966000
<<------------------------------------------------------------->>       00968000
                                                                        00970000
equate                                                                  00972000
   SLFILECODE       = 1031,       << File system file code >>           00974000
   LASTSLFORMATID   =    3,       << Last valid SL format ID >>         00976000
   MAXNUMSLSEGS     =  256;       << Max # segments in SL files>>       00978000
                                                                        00980000
<<------------------------------------------------------------->>       00982000
<<                                                             >>       00984000
<< SL File Record 0.                                           >>       00986000
<<                                                             >>       00988000
<<------------------------------------------------------------->>       00990000
<<                                                             >>       00992000
<< Record 0 in all SL files contains general header and space  >>       00994000
<< allocation information for the rest of the file, and is di- >>       00996000
<< vided into two basic pieces.  The first 33 words contain    >>       00998000
<< miscellaneous counters and other information, while the     >>       01000000
<< last 95 words contain the list heads for the entry point    >>       01002000
<< directory hash buckets, each bucket being a linked list of  >>       01004000
<< disc records containing directory entries whese symbolic    >>       01006000
<< names have identical hash function values.                  >>       01008000
<<                                                             >>       01010000
<<------------------------------------------------------------->>       01012000
<<                                                             >>       01014000
<< Pointers referenced:                                        >>       01016000
<<                                                             >>       01018000
<<    SL0P  - Integer pointer to 1st word of SL file record 0. >>       01020000
<<    SL0LP - Logical pointer to 1st word of SL file record 0. >>       01022000
<<                                                             >>       01024000
<<------------------------------------------------------------->>       01026000
equate                                                                  01028000
   NUMSLDIRHASHBUCKETS = 95;      << # words in hash list >>            01030000
                                                                        01032000
define                                                                  01034000
   SL0'FormatId        = SL0P#,                                         01036000
   SL0'NumDRecsInFile  = SL0LP(1)#,                                     01038000
   SL0'NumDRecsPerExt  = SL0LP(2)#,                                     01040000
   SL0'LastToolboxId   = SL0LP(3)#,                                     01042000
   SL0'NumActiveSegs   = SL0P(4)#,                                      01044000
   SL0'NextFreeSegNum  = SL0P(7)#,                                      01046000
   SL0'NumSegsAlloc    = SL0P(9)#,                                      01048000
   SL0'NumSections     = SL0P(11)#; << 1 sect = 2K disc recs >>         01050000
                                                                        01052000
$PAGE                                                                   01054000
<<------------------------------------------------------------->>       01056000
<<                                                             >>       01058000
<< SL file entry point directory records.                      >>       01060000
<<                                                             >>       01062000
<<------------------------------------------------------------->>       01064000
<<                                                             >>       01066000
<< Each entry point directory record contains one or more      >>       01068000
<< variable-length entries, all of which share the same value  >>       01070000
<< of a hash function applied to their symbolic names.  A link >>       01072000
<< field in each record points to the next record containing   >>       01074000
<< entries for the same hash value, thus producing a linked    >>       01076000
<< list of directory entry records.  Each such linked list     >>       01078000
<< forms a hash bucket for a given hash function value, with   >>       01080000
<< the header links for the buckets stored in record 0.  A     >>       01082000
<< null link is represented by the value 0.                    >>       01084000
<<                                                             >>       01086000
<< When the number of entries in a record goes to zero, the    >>       01088000
<< record is removed from the list and is marked as available  >>       01090000
<< in the free space map which begins in record 2.             >>       01092000
<<                                                             >>       01094000
<<------------------------------------------------------------->>       01096000
<<                                                             >>       01098000
<< Pointers referenced:                                        >>       01100000
<<                                                             >>       01102000
<<   SLDirRecP  - Integer pointer to 1st word of an entry      >>       01104000
<<                point directory record.                      >>       01106000
<<   SLDirRecLP - Logical pointer to 1st word of an entry      >>       01108000
<<                point directory record.                      >>       01110000
<<                                                             >>       01112000
<<------------------------------------------------------------->>       01114000
                                                                        01116000
define                                                                  01118000
   SLDirRec'Link       = SLDirRecLP#,                                   01120000
   SLDirRec'NumWdsUsed = SLDirRecP(1)#; << Includes words 0, 1 >>       01122000
$PAGE                                                                   01124000
<<------------------------------------------------------------->>       01126000
<<                                                             >>       01128000
<< SL file entry point directory entries.                      >>       01130000
<<                                                             >>       01132000
<<------------------------------------------------------------->>       01134000
<<                                                             >>       01136000
<< Each entry in the entry point directory is used to describe >>       01138000
<< the attributes of a procedure entry point, as well as to    >>       01140000
<< locate the code for the procedure within the SL.  Once an   >>       01142000
<< entry in the directory is reached, the segment number       >>       01144000
<< stored in the entry may be used to access the segment ref-  >>       01146000
<< erence table entry for that segment, which contains all the >>       01148000
<< information needed to access the segment in the SL.         >>       01150000
<<                                                             >>       01152000
<<------------------------------------------------------------->>       01154000
<<                                                             >>       01156000
<< Pointers referenced:                                        >>       01158000
<<                                                             >>       01160000
<<   SLDirEntP   - Integer pointer to 1st word of an entry     >>       01162000
<<                 point directory entry.                      >>       01164000
<<   SLDirEntLP - Logical pointer to 1st word of an entry      >>       01166000
<<                point directory entry.                       >>       01168000
<<   SLDirEntP1  - Integer pointer to 1st word after the name  >>       01170000
<<                 in an entry point directory entry.          >>       01172000
<<                                                             >>       01174000
<<------------------------------------------------------------->>       01176000
                                                                        01178000
define                                                                  01180000
   SLDIRENT'PTRDECS =                                                   01182000
      integer pointer SLDirEntP;                                        01184000
      integer pointer SLDirEntP1#,                                      01186000
   SLDIRENT'PTRS = SLDirEntP, SLDirEntP1#;                              01188000
                                                                        01190000
define                                                                  01192000
   SLDirEnt'Flags         = SLDirEntLP.(0:4)#,                          01194000
      SLDirEnt'Uncallable = SLDirEntLP.(2:1)#,                          01196000
      SLDirEnt'PermAlloc  = SLDirEntLP.(3:1)#,                          01198000
   SLDirEnt'NameBlock     = SLDirEntBP#,                                01200000
   SLDirEnt'SttNum        = SLDirEntP1.(0:8)#,                          01202000
   SLDirEnt'SegNum        = SLDirEntP1.(8:8)#,                          01204000
   SLDirEnt'ParmDesc      = SLDirEntP1(1)#;                             01206000
$PAGE                                                                   01208000
<<------------------------------------------------------------->>       01210000
<<                                                             >>       01212000
<< SL file segment reference table entries.                    >>       01214000
<<                                                             >>       01216000
<<------------------------------------------------------------->>       01218000
<<                                                             >>       01220000
<< A segment reference table entry is used to specify proper-  >>       01222000
<< ties of each segment in the SL and identifies other areas   >>       01224000
<< of the file containing data pertinent to the segment.       >>       01226000
<< These include the segment's code image, its programmatic    >>       01228000
<< PMAP, and the TOOLBOX symbolic debug information.           >>       01230000
<<                                                             >>       01232000
<< Included at the end of each entry is a bit map (RefSegsMap) >>       01234000
<< which is used to quickly tell the loader which SL segments  >>       01236000
<< are referenced by the one associated with the entry and     >>       01238000
<< must also be loaded.  Each set bit indicates the corre-     >>       01240000
<< sponding segment must be loaded.                            >>       01242000
<<                                                             >>       01244000
<< The segment's code image has two additional structures ap-  >>       01246000
<< appended to it.  The first is a 256-byte STT map array      >>       01248000
<< which, for each STT entry corresponding to an external ref- >>       01250000
<< erence satisfied by the SL, gives the number of the satis-  >>       01252000
<< fying segment.  If the corresponding STT is not that of a   >>       01254000
<< satisfied external, the value in the array is 255.  The STT >>       01256000
<< map array is followed by an external list, which is termi-  >>       01258000
<< nated by a zero word.                                       >>       01260000
<<                                                             >>       01262000
<< Segment reference table entries are blocked 4 per disc rec- >>       01264000
<< record, and a list of disc record numbers of all such       >>       01266000
<< blocks, ordered sequentially by the numbers of the segments >>       01268000
<< contained in the blocks, is maintained in record 1.         >>       01270000
<<                                                             >>       01272000
<< Once a segment reference table block is created, it is      >>       01274000
<< never deleted and added to the free list which starts in    >>       01276000
<< record 2.  Instead, when SL segments are deleted by the     >>       01278000
<< -PURGESL command, their reference table entries are added   >>       01280000
<< to a special free list chain whose header is placed in rec- >>       01282000
<< ord 0 (NextFreeSegNum).  The first word of each reference   >>       01284000
<< table entry on the free list becomes a link field, giving   >>       01286000
<< the number of the next free segment.  The null link in this >>       01288000
<< chain is represented by -1.                                 >>       01290000
<<                                                             >>       01292000
<<------------------------------------------------------------->>       01294000
<<                                                             >>       01296000
<< Pointers referenced:                                        >>       01298000
<<                                                             >>       01300000
<<   SLRefP  - Integer pointer to 1st word of a reference      >>       01302000
<<             table entry.                                    >>       01304000
<<   SLRefLP - Logical pointer to 1st word of a reference     >>        01306000
<<             table entry.                                   >>        01308000
<<   SLRefBP - Byte pointer to 1st byte of a reference table   >>       01310000
<<             entry.                                          >>       01312000
<<                                                             >>       01314000
<<------------------------------------------------------------->>       01316000
$PAGE                                                                   01318000
equate                                                                  01320000
   SLREFBLOCKNUMWDS     =   128,                                        01322000
   SLREFBLOCKFACT       =     4,                                        01324000
   SLREFENTNUMWDS       =    32,                                        01326000
                                                                        01328000
   MAXNUMSLREFBLOCKS = (MAXNUMSLSEGS + SLREFBLOCKFACT - 1) /            01330000
                       SLREFBLOCKFACT;                                  01332000
                                                                        01334000
define                                                                  01336000
   SLRef'SegLenDesc     = SLRefLP#,                                     01338000
      SLRef'PrivSeg     = SLRefLP.(0:1)#,                               01340000
      SLRef'NewStt      = SLRefLP.(1:1)#,                               01342000
      SLRef'SegNumWds   = SLRefP.(2:14)#,                               01344000
   SLRef'CodeDRecNum    = SLRefLP(1)#,                                  01346000
   SLRef'CodeNumDRecs   = SLRefP(2)#, << Code, map, ext list >>         01348000
   SLRef'Flags          = SLRefLP(3)#,                                  01350000
      SLRef'Deleted     = SLRefLP(3).(0:1)#,                            01352000
      SLRef'ExtSat      = SLRefLP(3).(1:1)#,                            01354000
      SLRef'PermAlloc   = SLRefLP(3).(4:1)#,                            01356000
      SLRef'Resident    = SLRefLP(3).(5:1)#,                            01358000
      SLRef'MpeSeg      = SLRefLP(3).(6:1)#,                            01360000
      SLRef'NumEntPts   = SLRefP(3).(9:7)#,                             01362000
   SLRef'PmapDRecNum    = SLRefLP(4)#,                                  01364000
   SLRef'ToolboxDRecNum = SLRefLP(5)#,                                  01366000
   SLRef'SegName0       = SLRefBP(16)#, << 16-byte name >>              01368000
   SLRef'RefSegsMap     = SLRefP(20)#;                                  01370000
$PAGE                                                                   01372000
<<------------------------------------------------------------->>       01374000
<<                                                             >>       01376000
<< SL file segment external list entries.                      >>       01378000
<<                                                             >>       01380000
<<------------------------------------------------------------->>       01382000
<<                                                             >>       01384000
<< The segment external list is found at the end of the code   >>       01386000
<< segment image section of the SL as described in the segment >>       01388000
<< reference table entry declarations.  The list contains the  >>       01390000
<< symbolic names and parameter descriptor arrays for all ex-  >>       01392000
<< ternal routines referenced by the associated segment.  If   >>       01394000
<< the external resides within the SL file, its segment and    >>       01396000
<< STT numbers are also given.                                 >>       01398000
<<                                                             >>       01400000
<<------------------------------------------------------------->>       01402000
<<                                                             >>       01404000
<< Pointers referenced:                                        >>       01406000
<<                                                             >>       01408000
<<   SLExtP  - Integer pointer to 1st word of an external list >>       01410000
<<             entry.                                          >>       01412000
<<   SLExtLP - Logical pointer to 1st word of an external list >>       01414000
<<             entry.                                          >>       01416000
<<   SLExtP1 - Integer pointer to 1st word after the name      >>       01418000
<<             field of an external list entry.                >>       01420000
<<                                                             >>       01422000
<<------------------------------------------------------------->>       01424000
                                                                        01426000
define                                                                  01428000
   SLEXT'PTRDECS =                                                      01430000
      integer pointer SLExtP;                                           01432000
      logical pointer SLExtLP = SLExtP;                                 01434000
      integer pointer SLExtP1#,                                         01436000
   SLEXT'PTRS = SLExtP, SLExtP1#;                                       01438000
                                                                        01440000
define                                                                  01442000
   SLExt'Flags        = SLExtLP.(0:4)#,                                 01444000
      SLExt'Satisfied = SLExtLP.(0:1)#,                                 01446000
   SLExt'NameBlock    = SLExtP#,                                        01448000
   SLExt'Stt          = SLExtP1.(0:8)#,                                 01450000
   SLExt'Seg          = SLExtP1.(8:8)#,                                 01452000
   SLExt'ParmDesc     = SLExtP1(1)#;                                    01454000
$PAGE                                                                   01456000
<<------------------------------------------------------------->>       01458000
<<                                                             >>       01460000
<< Internal PMAP Records.                                      >>       01462000
<<                                                             >>       01464000
<<------------------------------------------------------------->>       01466000
<<                                                             >>       01468000
<< Pointers referenced:                                        >>       01470000
<<                                                             >>       01472000
<<    IPmapP   - Integer pointer to 1st word of an internal    >>       01474000
<<               record.                                       >>       01476000
<<    IPmapBP  - Byte pointer to 1st byte of an internal PMAP  >>       01478000
<<               record.                                       >>       01480000
<<    IPmapP1  - Integer pointer to 1st word after name in an  >>       01482000
<<               internal PMAP record.                         >>       01484000
<<    IPmapDP1 - Double pointer to 1st word after name in an   >>       01486000
<<               internal PMAP record.                         >>       01488000
<<                                                             >>       01490000
<<------------------------------------------------------------->>       01492000
                                                                        01494000
equate IPMAPRECMAX = 15;          << Internal PMAP rec size >>          01496000
equate MAXTYPETABLELEN = 5; << This constant is the >>                  01498000
                            << only one needs to be >>                  01500000
                            << changed if add types >>                  01502000
                                                                        01504000
<< Field definitions common to all record types: >>                     01506000
                                                                        01508000
define                                                                  01510000
   IPmap'Type      = IPmapP.(0:4)#;                                     01512000
   equate                                                               01514000
      PMAPSEGTYPE     = 0,        << PMAP segment >>                    01516000
      PMAPPROCTYPE    = 1,        << PMAP procedure >>                  01518000
      PMAPSECTYPE     = 2;        << PMAP secondary entry>>             01520000
define                                                                  01522000
   IPmap'NameNumCh = IPmapP.(4:4)#, << # chars in ent name >>           01524000
   IPmap'Name      = IPmapBP#,                                          01526000
                                                                        01528000
<< Segment record field definitions: >>                                 01530000
                                                                        01532000
   IPmap'SttLen    = IPmapP1.(0:8)#,                                    01534000
   IPmap'SegNum    = IPmapP1.(8:8)#,                                    01536000
   IPmap'SegLen    = IPmapP1(1)#, << Segment length, including >>       01538000
                                  <<   the STT.                >>       01540000
                                                                        01542000
<< Procedure record field definitions: >>                               01544000
                                                                        01546000
   IPmap'Flags     = IPmapP1#,                                          01548000
      IPmap'Hidden = IPmapP1.(0:1)#,                                    01550000
                                                                        01552000
   IPmap'ProcStart = IPmapP1(1)#,                                       01554000
   IPmap'ProcLen   = IPmapP1(2)#,                                       01556000
   IPmap'ProcEntry = IPmapP1(3)#,                                       01558000
   IPmap'TboxLink  = IPmapDP1(2)#,                                      01560000
   IPmap'TboxId    = IPmapP1(6)#,                                       01562000
                                                                        01564000
<< Secondary entry point record definitions: >>                         01566000
                                                                        01568000
   IPmap'SecEntry  = IPmapP1(1)#,                                       01570000
   IPmap'SecEntNum = IPmapP1(2)#;                                       01572000
$PAGE                                                                   01574000
<<------------------------------------------------------------->>       01576000
<<                                                             >>       01578000
<< External PMAP records.                                      >>       01580000
<<                                                             >>       01582000
<<------------------------------------------------------------->>       01584000
<< Pointers referenced:                                        >>       01586000
<<                                                             >>       01588000
<<    XPmapP  - Integer pointer to 1st word of external PMAP   >>       01590000
<<              record.                                        >>       01592000
<<    XPmapBP - Byte pointer to 1st byte of external PMAP rec- >>       01594000
<<              ord.                                           >>       01596000
<<    XPmapDP - Double pointer to 1st word of external PMAP    >>       01598000
<<              record.                                        >>       01600000
<<                                                             >>       01602000
<<------------------------------------------------------------->>       01604000
                                                                        01606000
equate XPMAPRECMAX = 36;          << External PMAP rec size >>          01608000
                                                                        01610000
define                                                                  01612000
   XPmap'Type      = XPmapP#,      << PMAP record type >>               01614000
   XPmap'SegName   = XPmapBP(2)#,  << Segment name >>                   01616000
   XPmap'ProcName  = XPmapBP(18)#, << Procedure name >>                 01618000
   XPmap'SecName   = XPmapBP(34)#, << Sec entry point name >>           01620000
   XPmap'SegNum    = XPmapP(25)#,  << Segment number >>                 01622000
   XPmap'SegLen    = XPmapP(26)#,  << Seg len, incl STT >>              01624000
   XPmap'SttLen    = XPmapP(27)#,  << STT length >>                     01626000
   XPmap'ProcStart = XPmapP(28)#,  << Code starting addr >>             01628000
   XPmap'ProcLen   = XPmapP(29)#,  << Procedure length >>               01630000
   XPmap'ProcEntry = XPmapP(30)#,  << Primary entry point >>            01632000
   XPmap'SecEntry  = XPmapP(31)#,  << Secondary entry pt >>             01634000
   XPmap'SecEntNum = XPmapP(32)#,  << Sec entry point # >>              01636000
   XPmap'TboxId    = XPmapP(33)#,  << TOOLBOX ID >>                     01638000
   XPmap'TboxLink  = XPmapDP(17)#; << TOOLBOX ID link >>                01640000
$PAGE                                                                   01642000
<<------------------------------------------------------------->>       01644000
<<                                                             >>       01646000
<< PMAP Control Block.                                         >>       01648000
<<                                                             >>       01650000
<<------------------------------------------------------------->>       01652000
<<                                                             >>       01654000
<< The PMAP Control Block is used to save all data required to >>       01656000
<< access the PMAP data stored in program and SL files.  It    >>       01658000
<< serves as a replacement for GLOBAL and OWN variables, which >>       01660000
<< are not allowed in SL procedures.  The control block is     >>       01662000
<< allocated in each of the externally-callable PMAP intrin-   >>       01664000
<< sics and is passed as a parameter to each of the internal   >>       01666000
<< procedures which manage the PMAP data stored in program and >>       01668000
<< SL files.                                                   >>       01670000
<<                                                             >>       01672000
<< The structure of the data in the control block varies       >>       01674000
<< slightly, depending on whether or not the file containing   >>       01676000
<< the PMAP is a program or SL file.  The first part of the    >>       01678000
<< block contains data required in reading both program and SL >>       01680000
<< files.  After this area, two variants in the Pascal sense   >>       01682000
<< follow, one for use in reading program files, the other for >>       01684000
<< SL files.                                                   >>       01686000
<<                                                             >>       01688000
<<------------------------------------------------------------->>       01690000
                                                                        01692000
<< Declarations for the static control information: >>                  01694000
                                                                        01696000
define                                                                  01698000
   PmapFlags      = PmapCB#,      << Control flags >>                   01700000
      PmapPreset  = PmapCBL.(0:1)#,                                     01702000
                                  << true if PmapBufX is set   >>       01704000
                                  << at next PMAP record to be >>       01706000
                                  << returned, instead of last >>       01708000
                                  << one returned.             >>       01710000
      PmapEnd     = PmapCBL.(1:1)#,                                     01712000
                                  << True if end-of-PMAP con-  >>       01714000
                                  << dition should be returned >>       01716000
                                  << on next PMAP read.        >>       01718000
      SLRefBlockLoaded = PmapCBL.(2:1)#,                                01720000
                                  << True if an SL reference   >>       01722000
                                  << table block has beed read.>>       01724000
      FirstHalfSegPtrLoaded = PmapCBL.(3:1)#,                           01726000
                              << True if the first 128 segment >>       01728000
                              << pointers has been loaded onto >>       01730000
                              << PmapCB, otherwise the rest of >>       01732000
                              << the pointers were loaded.     >>       01734000
      SegPmapMaped= PmapCBL.(4:1)#,                                     01736000
                                  << true if segment Pmap was  >>       01738000
                                  << previously maped. Use for >>       01740000
                                  << stopping the scanning as  >>       01742000
                                  << SCANCODE = SCANCURSEG     >>       01744000
   IPmapFNum      = PmapCB(1)#,   << # of prog/SL file >>               01746000
   IPmapFileCode  = PmapCB(2)#,   << Prog/SL file code >>               01748000
   PmapCurSegNum  = PmapCB(3)#,   << # current Pmap seg >>              01750000
   PmapCurDRecNum = PmapCB(4)#,   << 1st rec in Pmap buf  >>            01752000
   PmapBufX       = PmapCB(5)#;   << Index to last pmap record >>       01754000
                                  << processed.                >>       01756000
                                                                        01758000
<< Constant offsets for variant declarations: >>                        01760000
                                                                        01762000
equate                                                                  01764000
   INFOLEN        = 6,                                                  01766000
   SAPMAPBUF      = INFOLEN  + MAXTYPETABLELEN,                         01768000
   VARBASE        = SAPMAPBUF + IPMAPBUFNUMWDS,                         01770000
   PROGOFF1       = VARBASE  + PF0'INFONUMWDS,                          01772000
   SLOFF1         = VARBASE  + DRECNUMWDS,                              01774000
   SLOFF2         = SLOFF1   + MAXNUMSLREFBLOCKS,                       01776000
   PMAPCBLEN      = SLOFF2   + SLREFBLOCKNUMWDS;                        01778000
                                                                        01780000
define                                                                  01782000
   TypeTableLen = TypeTable(0)#,                                        01784000
   SegPmapLen   = TypeTable(1)#,                                        01786000
   PriTypeLen   = TypeTable(2)#,                                        01788000
   SecTypeLen   = TypeTable(3)#;                                        01790000
                                                                        01792000
define IA = integer array#;                                             01794000
                                                                        01796000
define PMAPCBDEC =                                                      01798000
   logical array PmapCBL(*)           = PmapCB;                         01800000
   IA            TypeTable(*)         = PmapCB(INFOLEN);                01802000
   IA            PmapBuf(*)           = PmapCB(SAPMAPBUF);              01804000
   double  array PmapBufD(*)          = PmapCB(SAPMAPBUF);              01806000
   IA            PF0P(*)              = PmapCB(VARBASE);                01808000
   logical array PF0LP(*)             = PF0P;                           01810000
   double  array ProgPmapPtrs(*)      = PmapCB(PROGOFF1);               01812000
   IA            ProgPmapPtrsI(*)     = PmapCB(PROGOFF1);               01814000
   IA            SL0P(*)              = PmapCB(VARBASE);                01816000
   logical array SL0LP(*)             = SL0P;                           01818000
   IA            SL0'DirHashPtrs(*)   = SL0P(33);                       01820000
   logical array SLRefBlockDRecNum(*) = PmapCB(SLOFF1);                 01822000
   IA            SLRefBlock(*)        = PmapCB(SLOFF2)                  01824000
#;                                                                      01826000
$PAGE                                                                   01828000
<<------------------------------------------------------------->>       01830000
<<                                                             >>       01832000
<< Macro to test the condition code returned by file system    >>       01834000
<< intrinsics.                                                 >>       01836000
<<                                                             >>       01838000
<<------------------------------------------------------------->>       01840000
                                                                        01842000
define CHECKIPMAPIO =                                                   01844000
   if <> then                                                           01846000
      begin                                                             01848000
      Status := STAT'IPMAPIOERR;                                        01850000
      return;                                                           01852000
      end                                                               01854000
#;                                                                      01856000
                                                                        01858000
<<------------------------------------------------------------->>       01860000
<<                                                             >>       01862000
<< Macro to turn off user traps.                               >>       01864000
<<                                                             >>       01866000
<<------------------------------------------------------------->>       01868000
                                                                        01870000
define TURNOFFTRAPS =                                                   01872000
   push(status);                  << Get status register >>             01874000
   tos.(2:1) := 0;                << Turn off user traps >>             01876000
   set(status)                    << Replace status register >>         01878000
#;                                                                      01880000
$PAGE "INTRINSICS REFERENCED"                                           01882000
<<------------------------------------------------------------->>       01884000
<<                                                             >>       01886000
<< Intrinsics referenced.                                      >>       01888000
<<                                                             >>       01890000
<<------------------------------------------------------------->>       01892000
                                                                        01894000
intrinsic Activate;                                                     01896000
                                                                        01898000
procedure Awake(PCBIndex, OldWait, NewWait);                            01900000
   value   PCBIndex, OldWait, NewWait;                                  01902000
   integer PCBIndex, OldWait, NewWait;                                  01904000
   option  external;                                                    01906000
                                                                        01908000
procedure Chek(Intrinsic, Flags, Parms, CapMask, OptVMask);             01910000
   value   Intrinsic, Flags, Parms, CapMask, OptVMask;                  01912000
   logical Intrinsic, Flags, OptVMask;                                  01914000
   double  Parms, CapMask;                                              01916000
   option  variable, external;                                          01918000
                                                                        01920000
intrinsic Create;                                                       01922000
intrinsic FClose;                                                       01924000
intrinsic FGetInfo;                                                     01926000
intrinsic FOpen;                                                        01928000
intrinsic FPoint;                                                       01930000
intrinsic FRead;                                                        01932000
intrinsic FReadDir;                                                     01934000
intrinsic FWrite;                                                       01936000
intrinsic FWriteDir;                                                    01938000
intrinsic FCheck;                                                       01940000
intrinsic GetProcId;                                                    01942000
intrinsic Kill;                                                         01944000
intrinsic Print;                                                        01946000
intrinsic ReceiveMail;                                                  01948000
intrinsic SendMail;                                                     01950000
$PAGE "INITUSLF"                                               <<00207>>01952000
INTEGER PROCEDURE INITUSLF (USLFNUM,REC0);                              01954000
   <<THIS PROCEDURE INITIALIZES THE RECORD 0 BUFFER OF A USL FILE.      01956000
                                                                        01958000
     CONDITION CODE CONVENTIONS:                                        01960000
                                                                        01962000
         CCE   REQUEST GRANTED                                          01964000
         CCL   REQUEST DENIED - ERROR NR. RETURNED AS RESULT            01966000
                                                                        01968000
     NOTE THAT THIS PROCEDURE ALWAYS RETURNS TO THE CALLER>>            01970000
   VALUE USLFNUM;                                                       01972000
   INTEGER ARRAY REC0;                                                  01974000
   INTEGER USLFNUM;                                                     01976000
   OPTION PRIVILEGED;                                                   01978000
   BEGIN                                                                01980000
   DOUBLE ARRAY DREC0 (*) = REC0;                                       01982000
   DOUBLE DRECORDS;                                                     01984000
   INTEGER RECORDS = DRECORDS+1;                                        01986000
                                                                        01988000
   <<* * * CHECK FOR LEGAL REQUEST * * *>>                              01990000
                                                                        01992000
   CHEK([10/82,6/2],[8/0,2/1,1/0,5/2],[2/2,2/0]D);                      01994000
   FGETINFO(USLFNUM,,,,,,,,,,,DRECORDS);                                01996000
   IF NOT (DRECORDS > 4D) OR NOT (DRECORDS < 32768D) THEN               01998000
      BEGIN                                                             02000000
      TOS _ ERR3; GO NFG                                                02002000
      END;                                                              02004000
                                                                        02006000
   <<* * * INITIALIZE RECORD 0 BUFFER * * *>>                           02008000
                                                                        02010000
   TOS _ @REC0; PS0 _ 0;                                                02012000
   ASSEMBLE(DUP,INCB); TOS _ 127; ASSEMBLE(MOVE 3);                     02014000
   USLLID _ 1;                                                          02016000
   USLFL _ DRECORDS&DLSL(7);                                            02018000
   USLSAAD _ 128;                                                       02020000
   TOS _ (LOGICAL(RECORDS)+3)&LSR(3);                                   02022000
   IF S0 > 255 THEN TOS _ 255;                                          02024000
   USLADL _ TOS&LSL(7);                                                 02026000
   USLSAI _ DOUBLE(USLADL)+128D;                                        02028000
   USLSAAI _ USLSAI;                                                    02030000
   USLAIL _ USLFL-USLSAI;                                               02032000
   TOS _ CCE;                                                           02034000
   GO GETOUT;                                                           02036000
                                                                        02038000
   NFG:                                                                 02040000
   INITUSLF _ TOS;  <<ERROR NR.>>                                       02042000
   TOS _ CCL;                                                           02044000
                                                                        02046000
   GETOUT:                                                              02048000
   CONDCODE _ TOS                                                       02050000
   END;                                                                 02052000
$PAGE "ADJUSTUSLF"                                             <<00207>>02054000
INTEGER PROCEDURE ADJUSTUSLF (USLFNUM,RECORDS);                         02056000
   <<THIS PROCEDURE MOVES THE INFO BLOCK:                               02058000
         IF RECORDS > 0 THE INFO BLOCK IS MOVED DOWN, THEREBY INCREASING02060000
            THE AVAILABLE DIRECTORY BLOCK AND DECREASING THE AVAILABLE  02062000
            INFO BLOCK                                                  02064000
         IF RECORDS < 0 THE INFO BLOCK IS MOVED UP, THEREBY DECREASING  02066000
            THE AVAILABLE DIRECTORY BLOCK AND INCREASING THE AVAILABLE  02068000
            INFO BLOCK                                                  02070000
                                                                        02072000
     CONDITION CODE CONVENTIONS:                                        02074000
                                                                        02076000
         CCE   REQUEST GRANTED                                          02078000
         CCL   REQUEST DENIED - ERROR NR. RETURNED AS RESULT            02080000
                                                                        02082000
     NOTE THAT THIS PROCEDURE MUST BE CALLED WITH DB SET TO THE STACK>> 02084000
   VALUE USLFNUM,RECORDS;                                               02086000
   INTEGER USLFNUM,RECORDS;                                             02088000
   OPTION PRIVILEGED;                                                   02090000
   BEGIN                                                                02092000
   INTEGER ARRAY REC0 (0:127);  <<USL RECORD 0 BUFFER>>                 02094000
   DOUBLE ARRAY DREC0 (*) = REC0;                                       02096000
   DOUBLE DSRECD;                                                       02098000
   INTEGER SRECD = DSRECD+1;                                            02100000
   DOUBLE DTRECD;                                                       02102000
   INTEGER TRECD = DTRECD+1;                                            02104000
   DOUBLE DNRWORDS;                                                     02106000
   INTEGER NRWORDS = DNRWORDS+1;                                        02108000
                                                                        02110000
   <<* * * CHECK FOR LEGAL REQUEST * * *>>                              02112000
                                                                        02114000
   CHEK([10/83,6/2],[8/0,2/1,1/0,5/2]);                                 02116000
   IF RECORDS = 0 THEN GO FINISHED;  <<NULL REQUEST?>>                  02118000
   FREADDIR(USLFNUM,REC0,128,0D);  <<READ RECORD 0>>                    02120000
   IF <> THEN  <<ERROR?>>                                               02122000
      BEGIN                                                             02124000
      FILEERROR:                                                        02126000
      TOS _ IF > THEN ERR0 ELSE ERR1;                                   02128000
      GO NFG                                                            02130000
      END;                                                              02132000
   DNRWORDS _ DOUBLE(RECORDS)&DASL(7);                                  02134000
   USLADL _ USLADL+NRWORDS;                                             02136000
   IF < THEN  <<DIRECTORY TOO SMALL?>>                                  02138000
      BEGIN                                                             02140000
      TOS _ ERR5; GO NFG                                                02142000
      END;                                                              02144000
   USLSAI _ USLSAI+DNRWORDS;                                            02146000
   IF USLSAI > 32768D THEN                                              02148000
      BEGIN                                                             02150000
      TOS _ ERR4; GO NFG                                                02152000
      END;                                                              02154000
   USLSAAI _ USLSAAI+DNRWORDS;                                          02156000
   USLAIL _ USLAIL-DNRWORDS;                                            02158000
   IF < THEN  <<INFO TOO SMALL?>>                                       02160000
      BEGIN                                                             02162000
      TOS _ ERR6; GO NFG                                                02164000
      END;                                                              02166000
   FWRITEDIR(USLFNUM,REC0,128,0D);  <<SAVE RECORD 0>>                   02168000
   IF <> THEN GO FILEERROR;  <<ERROR?>>                                 02170000
                                                                        02172000
   <<* * * MOVE RECORDS * * *>>                                         02174000
                                                                        02176000
   XREG _ RECORDS;                                                      02178000
   IF < THEN TOS _ USLSAI ELSE TOS _ USLSAAI;                           02180000
   DTRECD _ DS1&DLSR(7);  <<TARGET REC. NR.>>                           02182000
   DSRECD _ (TOS-DNRWORDS)&DLSR(7);  <<SOURCE REC. NR.>>                02184000
   TOS _ (USLIL+127D)&DLSR(7);  <<RECORD COUNTER>>                      02186000
   WHILE <> DO                                                          02188000
      BEGIN                                                             02190000
      FREADDIR(USLFNUM,REC0,128,DSRECD);                                02192000
      IF <> THEN GO FILEERROR;  <<ERROR?>>                              02194000
      FWRITEDIR(USLFNUM,REC0,128,DTRECD);                               02196000
      IF <> THEN GO FILEERROR;  <<ERROR?>>                              02198000
      XREG _ RECORDS;                                                   02200000
      IF < THEN                                                         02202000
         BEGIN                                                          02204000
         SRECD _ SRECD+1;                                               02206000
         TRECD _ TRECD+1                                                02208000
         END                                                            02210000
      ELSE                                                              02212000
         BEGIN                                                          02214000
         SRECD _ SRECD-1;                                               02216000
         TRECD _ TRECD-1                                                02218000
         END;                                                           02220000
      TOS _ TOS-1                                                       02222000
      END;                                                              02224000
                                                                        02226000
   FINISHED:                                                            02228000
   TOS _ CCE;                                                           02230000
   GO GETOUT;                                                           02232000
                                                                        02234000
   NFG:                                                                 02236000
   ADJUSTUSLF _ TOS;  <<ERROR NR.>>                                     02238000
   TOS _ CCL;                                                           02240000
                                                                        02242000
   GETOUT:                                                              02244000
   CONDCODE _ TOS                                                       02246000
   END;                                                                 02248000
$PAGE "EXPANDUSLF"                                             <<00207>>02250000
INTEGER PROCEDURE EXPANDUSLF (USLFNUM,RECORDS);                         02252000
   <<THIS PROCEDURE ALTERS THE FILE SIZE OF THE SPECIFIED USL FILE BY   02254000
     CREATING A NEW USL FILE AND COPYING THE OLD USL FILE INTO THE      02256000
     NEW USL FILE:                                                      02258000
         IF RECORDS < 0 THEN THE NEW USL FILE IS THAT MANY RECORDS      02260000
            SHORTER THAN THE OLD USL FILE                               02262000
         IF RECORDS > 0 THEN THE NEW USL FILE IS THAT MANY RECORDS      02264000
            LONGER THAN THE OLD USL FILE                                02266000
                                                                        02268000
     CONDITION CODE CONVENTIONS:                                        02270000
                                                                        02272000
         CCE   REQUEST GRANTED                                          02274000
         CCL   REQUEST DENIED - ERROR NR. RETURNED AS RESULT            02276000
                                                                        02278000
     NOTE THAT THIS PROCEDURE MUST BE CALLED WITH DB SET TO THE STACK>> 02280000
   VALUE USLFNUM,RECORDS;                                               02282000
   INTEGER USLFNUM,RECORDS;                                             02284000
   OPTION PRIVILEGED;                                                   02286000
   BEGIN                                                                02288000
   INTEGER ARRAY REC0 (0:127);  <<RECORD 0 BUFFER>>                     02290000
   DOUBLE ARRAY DREC0 (*) = REC0;                                       02292000
   BYTE ARRAY NEWUSLFNAME (0:35);  <<NEW USL FILE NAME>>                02294000
   INTEGER NEWUSLFNUM _ 0;  <<NEW USL FILE NR.>>                        02296000
   INTEGER                                                     <<00.02>>02298000
       FOPT,       <<FOPTION OF SOURCE (INPUT) USL>>           <<00.02>>02300000
       AOPT;       <<AOPTION "   "       "     "  >>           <<00.02>>02302000
                                                               <<00.02>>02304000
   DEFINE                                                      <<00.02>>02306000
       OLDPASS = FOPT.(10:3) = 3 #,                            <<00.02>>02308000
       DOMAIN  = FOPT.(14:2) #,                                <<00.02>>02310000
       NEWFILE = DOMAIN = 0 #;                                 <<00.02>>02312000
                                                                        02314000
   <<* * * CHECK FOR LEGAL REQUEST * * *>>                              02316000
                                                                        02318000
   CHEK([10/84,6/2],[8/0,2/1,1/0,5/2]);                                 02320000
   FREADDIR(USLFNUM,REC0,128,0D);  <<READ RECORD 0>>                    02322000
   IF <> THEN  <<ERROR?>>                                               02324000
      BEGIN                                                             02326000
      FILEERROR:                                                        02328000
      TOS _ IF > THEN ERR0 ELSE ERR1;                                   02330000
      GO NFG                                                            02332000
      END;                                                              02334000
   USLFL _ USLFL+DOUBLE(RECORDS)&DASL(7);                               02336000
   IF USLFL > 4194304D THEN  <<TOO BIG?>>                               02338000
      BEGIN                                                             02340000
      TOS _ ERR3; GO NFG                                                02342000
      END;                                                              02344000
   USLAIL _ USLAIL+DOUBLE(RECORDS)&DASL(7);                             02346000
   IF < THEN  <<TOO SMALL?>>                                            02348000
      BEGIN                                                             02350000
      TOS _ ERR6; GO NFG                                                02352000
      END;                                                              02354000
                                                                        02356000
   <<* * * OPEN NEW USL FILE * * *>>                                    02358000
                                                                        02360000
   ASSEMBLE(ADDS 15);                                                   02362000
   FGETINFO(USLFNUM,NEWUSLFNAME,S12,S11,,,,,S0,,,DS4,,,S6,,S2,S7);      02364000
   FOPT := S12;                                                <<00.02>>02366000
   AOPT := S11;                                                <<00.02>>02368000
   @BPS13 _ @NEWUSLFNAME;                                               02370000
   S12.(14:2) _ 0;  <<"NEW" DOMAIN>>                                    02372000
   S11.(12:4) := 4; <<INSURE READ/WRITE ACCESS>>               <<00.06>>02374000
   S6 _ S6&LSR(7);  <<BLOCKING FACTOR>>                                 02376000
   S5 _ 1;  <<NR. BUFFERS>>                                             02378000
   DS4 _ DS4+DOUBLE(RECORDS);  <<FILE SIZE>>                            02380000
   TOS _ %(2)1110001111101;  <<OPTION VARIABLE LIST>>                   02382000
   IF S13.(10:3) = 2 THEN  <<$NEWPASS?>>                                02384000
      BEGIN                                                             02386000
      FCLOSE(USLFNUM,0,0);  <<CLOSE $NEWPASS MAKING IT $OLDPASS>>       02388000
      IF < THEN  <<ERROR?>>                                             02390000
         BEGIN                                                          02392000
         TOS _ ERR10; GO NFG                                            02394000
         END;                                                           02396000
      USLFNUM _ FOPEN(,%(2)10000011010,%(2)001000100);  <<$OLDPASS>>    02398000
      IF < THEN  <<ERROR?>>                                             02400000
         BEGIN                                                          02402000
         TOS _ ERR11; GO NFG                                            02404000
         END;                                                           02406000
      TOS.(3:1) _ 0; <<NO FILE DESIGNATOR>>                    <<00.06>>02408000
      FPOINT (USLFNUM,1D);  <<REPOSITION>>                     <<00.06>>02410000
      END                                                               02412000
   ELSE IF S13.(10:3) = 3 THEN  <<$OLDPASS?>>                           02414000
      BEGIN                                                             02416000
      S13.(10:3) _ 2;  <<$NEWPASS>>                                     02418000
      TOS.(3:1) _ 0  <<NO FILE DESIGNATOR>>                             02420000
      END;                                                              02422000
   ASSEMBLE(PCAL FOPEN);                                                02424000
   NEWUSLFNUM _ TOS;  <<NEW USL FILE NR.>>                              02426000
   IF < THEN  <<ERROR?>>                                                02428000
      BEGIN                                                             02430000
      TOS _ ERR7; GO NFG                                                02432000
      END;                                                              02434000
                                                                        02436000
   <<* * * COPY OLD USL INTO NEW USL * * *>>                            02438000
                                                                        02440000
   TOS _ (USLIL+127D)&DLSR(7);  <<INFO RECORD COUNTER>>                 02442000
   TOS _ USLSAI&DLSR(7);  <<INFO REC. NR.>>                             02444000
   TOS _ (USLDL+255)&LSR(7);  <<DIRECTORY RECORD COUNTER>>              02446000
   GO FIRSTTIME;                                                        02448000
   DO BEGIN  <<COPY RECORD 0 AND DIRECTORY>>                            02450000
      FREAD(USLFNUM,REC0,128);                                          02452000
      IF <> THEN GO FILEERROR;  <<ERROR?>>                              02454000
      FIRSTTIME:                                                        02456000
      FWRITE(NEWUSLFNUM,REC0,128,0);                                    02458000
      IF <> THEN GO FILEERROR;  <<ERROR?>>                              02460000
      TOS _ TOS-1                                                       02462000
      END UNTIL =;                                                      02464000
   FPOINT(USLFNUM,DS2);                                                 02466000
   FPOINT(NEWUSLFNUM,DS2);                                              02468000
   ASSEMBLE(DEL,DDEL; DELB,TEST);                                       02470000
   WHILE <> DO  <<COPY INFO>>                                           02472000
      BEGIN                                                             02474000
      FREAD(USLFNUM,REC0,128);                                          02476000
      IF <> THEN GO FILEERROR;  <<ERROR?>>                              02478000
      FWRITE(NEWUSLFNUM,REC0,128,0);                                    02480000
      IF <> THEN GO FILEERROR;  <<ERROR?>>                              02482000
      TOS _ TOS-1                                                       02484000
      END;                                                              02486000
                                                                        02488000
   <<* * * PURGE OLD USL FILE * * *>>                                   02490000
                                                                        02492000
   EXPANDUSLF _ NEWUSLFNUM;  <<NEW USL FILE NR.>>                       02494000
   IF NOT LOGICAL (NEWFILE) OR OLDPASS THEN                    <<00.02>>02498000
   BEGIN           <<MAKE IT OLDPASS,OLDTEMP,OR PERM>>         <<00.02>>02500000
      TRYAGAIN:                                                <<04815>>02502000
       FCLOSE (NEWUSLFNUM,DOMAIN,0);                           <<00.02>>02504000
       IF < THEN                                               <<00.02>>02506000
       BEGIN                                                   <<00.02>>02508000
           TOS:=0;                                             <<04815>>02510000
           FCHECK(NEWUSLFNUM,S0);                              <<04815>>02512000
           IF TOS = 100 THEN                                   <<04815>>02514000
              BEGIN                                            <<04815>>02516000
                 FCLOSE(USLFNUM,4,0);                          <<04815>>02518000
                 IF < THEN                                     <<04815>>02520000
                    BEGIN                                      <<04815>>02522000
                       TOS:=ERR8;                              <<04815>>02524000
                       GO NFG;                                 <<04815>>02526000
                    END;                                       <<04815>>02528000
                 GO TRYAGAIN;                                  <<04815>>02530000
              END                                              <<04815>>02532000
           ELSE                                                <<04815>>02534000
              BEGIN                                            <<04815>>02536000
                 TOS:=ERR9;                                    <<04815>>02538000
                 GO NFG';                                      <<04815>>02540000
              END;                                             <<04815>>02542000
       END                                                     <<04815>>02546000
       ELSE                                                    <<04815>>02548000
          BEGIN                                                <<04815>>02550000
             FCLOSE(USLFNUM,4,0);                              <<04815>>02552000
             IF < THEN                                         <<04815>>02554000
                BEGIN                                          <<04815>>02556000
                   TOS:=ERR8;                                  <<04815>>02558000
                   GO NFG;                                     <<04815>>02560000
                END;                                           <<04815>>02562000
          END;                                                 <<04815>>02564000
       EXPANDUSLF := FOPEN (NEWUSLFNAME,FOPT,AOPT);            <<00.02>>02566000
       IF < THEN                                               <<00.02>>02568000
       BEGIN                                                   <<00.02>>02570000
           TOS := ERR7;                                        <<00.02>>02572000
           GO NFG';                                            <<00.02>>02574000
       END;                                                    <<00.02>>02576000
   END                                                         <<04815>>02578000
   ELSE                                                        <<04815>>02580000
      FCLOSE(USLFNUM,4,0);                                     <<04815>>02582000
   TOS _ CCE;  <<OK CONDITION CODE>>                                    02584000
   GO GETOUT;                                                           02586000
                                                                        02588000
   NFG:                                                                 02590000
   IF NEWUSLFNUM <> 0 THEN  <<PURGE NEW USL FILE?>>                     02592000
      BEGIN                                                             02594000
      FCLOSE(NEWUSLFNUM,4,0);                                           02596000
      IF < THEN TOS _ ERR9  <<ERROR?>>                                  02598000
      END;                                                              02600000
   NFG':                                                       <<00.02>>02602000
   EXPANDUSLF _ TOS;  <<ERROR NR.>>                                     02604000
   TOS _ CCL;  <<ERROR CONDITION CODE>>                                 02606000
                                                                        02608000
   GETOUT:                                                              02610000
   CONDCODE _ TOS  <<STORE CONDITION CODE>>                             02612000
   END;                                                                 02614000
$PAGE "MOVESTRING"                                             <<00207>>02616000
PROCEDURE MOVESTRING (SOURCE,TARGET);                                   02618000
   <<MOVES A STRING (TERMINATED BY A BLANK) FROM SOURCE TO TARGET.      02620000
     THE NUMBER OF CHAR'S IS INSERTED IN THE FIRST BYTE OF TARGET       02622000
     AND THE STRING IS TRUNCATED TO 15 CHAR'S IF NECESSARY>>            02624000
   BYTE ARRAY SOURCE,TARGET;                                            02626000
   OPTION INTERNAL,UNCALLABLE;                                          02628000
   BEGIN                                                                02630000
   BYTE ARRAY SOURCE' (0:15);                                           02632000
   MOVE SOURCE' := SOURCE,(15),2;  <<FIRST 15 CHAR'S OF STRING>>        02634000
   BPS0 := " ";  <<ADD BLANK TERMINATOR>>                               02636000
   TOS := @TARGET; ASSEMBLE(DELB,INCA); TOS := @SOURCE';                02638000
   L1: MOVE * := * WHILE ANS,0;  <<MOVE AND UPSHIFT STRING>>            02640000
   IF BPS0 <> " " THEN  <<NON-BLANK SPECIAL?>>                          02642000
      BEGIN                                                             02644000
      MOVE * := *,(1),1;                                                02646000
      GO L1                                                             02648000
      END;                                                              02650000
   TARGET := TOS-@SOURCE'  <<STRING LENGTH>>                            02652000
   END;                                                                 02654000
$PAGE "SEGMENTER"                                              <<00207>>02656000
PROCEDURE SEGMENTER (PIN,COMMAND,ERROR,NUM1,NUM2,NUM3,NUM4,NUM5,        02658000
                     NUM6,STRING1,STRING2,FNAME1,FNAME2);      <<00629>>02660000
   <<SEGMENTER SUBSYSTEM PROCESS COMMUNICATION PROCEDURE.  THE          02662000
     FIRST CALL MUST HAVE PIN = 0 TO INITIATE THE PROCESS; AFTER        02664000
     THAT, PIN MUST NOT BE CHANGED.                                     02666000
                                                                        02668000
     CONDITION CODE CONVENTIONS:                                        02670000
                                                                        02672000
         CCE   COMMAND ACCEPTED                                         02674000
         CCG   COMMAND REJECTED - SEGMENTER PROCESS INTACT              02676000
         CCL   COMMAND REJECTED - SEGMENTER PROCESS TERMINATED          02678000
                                                                        02680000
     IF CCG OR CCL THEN ERROR CONTAINS ONE OF THE FOLLOWING ERROR       02682000
     NUMBERS:                                                           02684000
                                                                        02686000
         0  COMMAND REJECTED - ERROR(S) PRINTED ON LIST DEVICE          02688000
         1  COMMAND CONDITIONALLY ACCEPTED - WARNING(S) PRINTED ON      02690000
            LIST DEVICE                                                 02692000
         2  ILLEGAL CALLING SEQUENCE                                    02694000
         3  UNABLE TO CREATE SEGMENTER PROCESS                          02696000
         4  UNABLE TO ACTIVATE SEGMENTER PROCESS                        02698000
         5  UNABLE TO SENDMAIL TO SEGMENTER PROCESS                     02700000
         6  UNABLE TO RECEIVEMAIL FROM SEGMENTER PROCESS                02702000
         7  SEGMENTER PROCESS ABORTED                                   02704000
                                                                        02706000
     NOTE THAT ERROR 0,1 INDICATES THAT THE SEGMENTER PROCESS RECEIVED  02708000
     AND ACTED ON THE COMMAND, WHEREAS THE REMAINING ERRORS INDICATE    02710000
     THAT THE SEGMENTER PROCESS NEVER RECEIVED THE COMMAND.             02712000
                                                                        02714000
       COMMAND         PARAMETERS                                       02716000
       -------         ----------                                       02718000
                                                                        02720000
      0 ADDRL          STRING1     - RBM NAME                           02722000
                       NUM1        - INDEX                              02724000
                                                                        02726000
      1 ADDSL          STRING2                                          02728000
                       NUM3.(15:1) - PMAP                               02730000
                                                                        02732000
      2 AUXUSL         FNAME1      - AUXUSL FILE NAME                   02734000
                                                                        02736000
      3 BUILDRL        FNAME1      - NAME OF RL FILE                    02738000
                       NUM1        - SIZE OF RL FILE                    02740000
                       NUM2        - # EXTENTS IN RL FILE               02742000
                                                                        02744000
      4 BUILDSL        FNAME1      - NAME OF SL FILE                    02746000
                       NUM1        - SIZE OF SL FILE                    02748000
                       NUM2        - # EXTENTS IN SL FILE               02750000
                                                                        02752000
      5 BUILDUSL       FNAME1      - NAME OF USL FILE                   02754000
                       NUM1        - SIZE OF USL FILE                   02756000
                       NUM2        - # EXTENTS IN USL FILE              02758000
                                                                        02760000
      6 CEASE          STRING1     - NAME                               02762000
                       NUM1        - INDEX                              02764000
                       NUM3.(12:2) - CLASS                              02766000
                                                                        02768000
      7 COPY           STRING1     - NAME                               02770000
                       NUM1        - INDEX                              02772000
                       NUM3.(12:2) - CLASS                              02774000
                                                                        02776000
      8 EXIT           (NONE)                                           02778000
                                                                        02780000
      9 HIDE           STRING1     - NAME                               02782000
                       NUM1        - INDEX                              02784000
                                                                        02786000
     10 LISTRL         NUM3.(15:1) - LIST                               02788000
                                                                        02790000
     11 LISTSL         FNAME1      - SEGMENT NAME                       02792000
                       NUM3.(15:1) - LIST                               02794000
                                                                        02796000
     12 LISTUSL        STRING2     - SEGMENT NAME                       02798000
                       NUM3.(15:1) - LIST                               02800000
                                                                        02802000
     13 NEWSEG         STRING2     - NEW SEGMENT NAME                   02804000
                       STRING1     - RBM NAME                           02806000
                       NUM1        - INDEX                              02808000
                                                                        02810000
     14 PREPARE        FNAME1      - PROGRAM FILE NAME                  02812000
                       FNAME2      - RL FILE NAME                       02814000
                       NUM3.(14:1) - ZERODB                             02816000
                       NUM3.(15:1) - PMAP                               02818000
                       NUM1        - STACK SIZE (-1 DEFAULT)            02820000
                       NUM2        - DL SIZE (-1 DEFAULT)               02822000
                       NUM4        - MAXDATA SIZE (-1 DEFAULT)          02824000
                       NUM5        - CAP                                02826000
                  BIT -    6  7  8  9 10 11 12 13 14 15                 02828000
                          NS BA IA PM CR RT MR CD DS PH                 02830000
                       NUM6        - PATCH SIZE (-1 NO PATCH)           02832000
                                                                        02834000
     15 PURGERBM       STRING1     - NAME                               02836000
                       NUM1        - INDEX                              02838000
                       NUM3.(12:2) - CLASS                              02840000
                                                                        02842000
     16 PURGERL        STRING1     - NAME                               02844000
                       NUM3.(12:2) - CLASS                              02846000
                                                                        02848000
     17 PURGESL        STRING1     - NAME                               02850000
                       NUM3.(12:2) - CLASS                              02852000
                                                                        02854000
     18 REVEAL         STRING1     - NAME                               02856000
                       NUM1        - INDEX                              02858000
                                                                        02860000
     19 RL             FNAME1      - RL FILE NAME                       02862000
                                                                        02864000
     20 SL             FNAME1      - SL FILE NAME                       02866000
                                                                        02868000
     21 USE            STRING1     - NAME                               02870000
                       NUM1        - INDEX                              02872000
                       NUM3.(12:2) - CLASS                              02874000
                                                                        02876000
     22 USL            FNAME1      - USL FILE NAME                      02878000
                                                                        02880000
     23 DEBUG          (NONE)                                           02882000
                                                                        02884000
     24 COPYSL         NUM1        - PERCENT                            02886000
                       FNAME1      - NEW SL FILE NAME                   02888000
                                                                        02890000
     25 COPYUSL        NUM1        - PERCENT                            02892000
                       FNAME1      - NEW USL FILE NAME                  02894000
                                                                        02896000
     26 CLEANSL        FNAME1      - NEW SL FILE NAME                   02898000
                                                                        02900000
     27 CLEANUSL       FNAME1      - NEW USL FILE NAME                  02902000
                                                                        02904000
      29 LISTAUX        STRING2     - SEGMENT NAME                      02906000
                        NUM3.(15:1) - LIST                              02908000
                                                                        02910000
     NOTE:                                                              02912000
                   0 - SEGMENT                                          02914000
         CLASS =   1 - UNIT                                             02916000
                   2 - ENTRY                                            02918000
                                                                        02920000
     THE LAST COMMAND MUST BE THE EXIT COMMAND (COMMAND = 8).  THIS     02922000
     WILL TERMINATE THE SEGMENTER PROCESS>>                             02924000
   VALUE COMMAND,NUM1,NUM2,NUM3,NUM4,NUM5,NUM6;                <<00629>>02926000
   INTEGER PIN,COMMAND,ERROR,NUM1,NUM2,NUM3,NUM4,NUM5,NUM6;    <<00629>>02928000
   BYTE ARRAY STRING1,STRING2,FNAME1,FNAME2;                            02930000
   OPTION VARIABLE;                                            <<00.02>>02932000
   BEGIN                                                                02934000
   INTEGER PARMWORD = Q-4;  <<PARAMETER BITS>>                          02936000
   EQUATE MAILLENGTH = 59,                                     <<00629>>02938000
          MAILBND = MAILLENGTH-1;                                       02940000
   byte array Segmenter(0:27);    << Name of SEGPROC program >><<04102>>02942000
   INTEGER ARRAY COMBUF (0:MAILBND);  <<COMMAND BUFFER>>                02944000
   BYTE ARRAY BCOMBUF (*) = COMBUF;                                     02946000
                                                                        02948000
   <<* * * CHECK PARAMETERS * * *>>                                     02950000
                                                                        02952000
   TOS _ PARMWORD;  <<OPTION VARIABLE BITS>>                            02954000
   IF S0.(0:6) <> %(2)111 THEN  <<MISSING REQUIRED PARM'S?>>   <<00629>>02956000
      BEGIN                                                             02958000
      TOS _ 2; GO SOFT                                                  02960000
      END;                                                              02962000
   TOS _ @COMBUF; PS0 _ 0;                                              02964000
   ASSEMBLE(DUP,INCB); TOS _ 22; ASSEMBLE(MOVE 3);             <<00629>>02966000
   TOS _ @COMBUF(23); PS0 _ "  ";                              <<00629>>02968000
   ASSEMBLE(DUP,INCB); TOS _ 35; ASSEMBLE(MOVE 3);                      02970000
   COMBUF _ COMMAND;                                                    02972000
   IF LS0.(6:1) THEN COMBUF(1) := NUM1;                        <<00629>>02974000
   IF LS0.(7:1) THEN COMBUF(2) := NUM2;                        <<00629>>02976000
   IF LS0.(8:1) THEN COMBUF(3) := NUM3;                        <<00629>>02978000
   IF LS0.(9:1) THEN COMBUF(4) := NUM4;                        <<00629>>02980000
   IF LS0.(10:1) THEN COMBUF(5) := NUM5;                       <<00629>>02982000
   IF LS0.(11:1) THEN COMBUF(6) := NUM6;                       <<00629>>02984000
   IF LS0.(12:1) THEN MOVESTRING(STRING1,BCOMBUF(14));         <<00629>>02986000
   IF LS0.(13:1) THEN MOVESTRING(STRING2,BCOMBUF(30));         <<00629>>02988000
   IF LS0.(14:1) THEN MOVE BCOMBUF(46) _ FNAME1,(36);          <<00629>>02990000
   IF TOS THEN MOVE BCOMBUF(82) _ FNAME2,(36);                 <<00629>>02992000
                                                                        02994000
   <<* * * FIRE-UP SEGMENTER SUBSYSTEM * * *>>                          02996000
                                                                        02998000
   IF PIN = 0 THEN  <<CREATE SEGMENTER PROCESS?>>                       03000000
      BEGIN                                                             03002000
      IF COMMAND = 8 THEN GO AOK;  <<EXIT COMMAND?>>                    03004000
      MOVE SEGMENTER _ "SEGPROC.PUB.SYS ";                              03006000
      CREATE(SEGMENTER,,PIN,,1);                               <<00.02>>03008000
      IF < THEN  <<FAILURE TO CREATE?>>                                 03010000
         BEGIN                                                          03012000
         TOS _ 3; GO HARD                                               03014000
         END;                                                           03016000
      ACTIVATE(PIN,2);  <<WAKE SON & WAIT>>                    <<00.02>>03018000
      IF <> THEN  <<ERROR?>>                                            03020000
         BEGIN                                                          03022000
         SICK:                                                          03024000
         TOS _ 4; GO HARD                                               03026000
         END                                                            03028000
      END;                                                              03030000
                                                                        03032000
   <<* * * SEND COMMAND THRU THE MAIL * * *>>                           03034000
                                                                        03036000
   SENDMAIL(PIN,MAILLENGTH,COMBUF,FALSE);                               03038000
   IF <> THEN  <<UNABLE TO SEND MAIL?>>                                 03040000
      BEGIN                                                             03042000
      TOS _ 5; GO HARD                                                  03044000
      END;                                                              03046000
   ACTIVATE(PIN,2);  <<WAKE SON & WAIT>>                       <<00.02>>03048000
   IF <> THEN GO SICK;  <<FAILURE TO RE-ACTIVATE?>>                     03050000
   IF COMMAND = 8 THEN GO AOK;  <<EXIT COMMAND?>>                       03052000
   IF GETPROCID(1) = 0 THEN <<SON DIED>>                       <<00.02>>03054000
      BEGIN                                                             03056000
      TOS _ 7; GO HARD                                                  03058000
      END;                                                              03060000
                                                                        03062000
   <<* * * RETURN ERROR CONDITION TO CALLER * * *>>                     03064000
                                                                        03066000
   RECEIVEMAIL(PIN,COMBUF,FALSE);                                       03068000
   IF <> THEN  <<UNABLE TO RECEIVE MAIL?>>                              03070000
      BEGIN                                                             03072000
      TOS _ 6; GO HARD                                                  03074000
      END;                                                              03076000
   TOS _ COMBUF;  <<ERROR NR.>>                                         03078000
   IF >= THEN GO SOFT;  <<ERROR?>>                                      03080000
                                                                        03082000
   <<* * * RETURN TO CALLER * * *>>                                     03084000
                                                                        03086000
   AOK:                                                                 03088000
   TOS _ CCE;  <<OK CONDITION CODE>>                                    03090000
   GO GETOUT;                                                           03092000
                                                                        03094000
   HARD:                                                                03096000
   KILL(PIN);  <<KILL SUBSYSTEM>>                                       03098000
   ERROR _ TOS;  <<ERROR NR.>>                                          03100000
   TOS _ CCL;  <<HARD ERROR CONDITION CODE>>                            03102000
   GO GETOUT;                                                           03104000
                                                                        03106000
   SOFT:                                                                03108000
   ERROR _ TOS;  <<ERROR NR.>>                                          03110000
   TOS _ CCG;  <<SOFT ERROR CONDITION CODE>>                            03112000
                                                                        03114000
   GETOUT:                                                              03116000
   CONDCODE _ TOS  <<STORE CONDITION CODE>>                             03118000
   END;                                                                 03120000
$PAGE "CLEANUSL"                                               <<00207>>03122000
INTEGER PROCEDURE CLEANUSL(USLFILE,FILENAME);                  <<00207>>03124000
   VALUE USLFILE;                                              <<00207>>03126000
   INTEGER USLFILE;                                            <<00207>>03128000
   BYTE ARRAY FILENAME;                                        <<00207>>03130000
                                                               <<00207>>03132000
BEGIN                                                          <<00207>>03134000
                                                               <<00207>>03136000
INTRINSIC FREADDIR,FOPEN,FCLOSE,DEBUG,PRINT'FILE'INFO;         <<00207>>03138000
INTRINSIC FCONTROL,FGETINFO,FWRITEDIR,QUIT;                    <<00207>>03140000
INTEGER         NEWUSL=CLEANUSL;                               <<00660>>03142000
INTEGER         RECSIZE;                                       <<00207>>03144000
DOUBLE POINTER  DBL;                                           <<00207>>03146000
INTEGER         LENGTH;                                        <<00207>>03148000
INTEGER         NC;                                            <<00207>>03150000
INTEGER         SUBL;                                          <<00207>>03152000
INTEGER         NWC;                                           <<00207>>03154000
INTEGER         INX;                                           <<00207>>03156000
INTEGER         INX'PRC;                                       <<00207>>03158000
INTEGER         SECL;                                          <<00207>>03160000
INTEGER         OLDSEGL:=0;                                    <<00207>>03162000
INTEGER         OLDIPL:=0;                                     <<00207>>03164000
INTEGER         OLDBDL:=0;                                     <<00207>>03166000
INTEGER         OLDSUBL;                                       <<00207>>03168000
INTEGER         OLDSECL;                                       <<00207>>03170000
INTEGER         NH;                                            <<00207>>03172000
INTEGER         JINX;                                          <<00207>>03174000
DOUBLE          SAC;                                           <<00207>>03176000
DOUBLE          SAH;                                           <<00207>>03178000
LOGICAL         CODE'NOT'SEEN;                                 <<00207>>03180000
ARRAY           DRT'BUF (0: 127);                              <<00207>>03182000
ARRAY           INFO'BUF (0: 127);                             <<00207>>03184000
ARRAY           DRT'INBUF(0:1151);                             <<00207>>03186000
ARRAY           INFO'INBUF(0:1151);                            <<00207>>03188000
INTEGER         OFFSET:=0;                                     <<00207>>03190000
INTEGER         OFFSET1:=0;                                    <<00207>>03192000
INTEGER         OFFSETI:=0;                                    <<00207>>03194000
INTEGER         OFFSET2:=0;                                    <<00207>>03196000
EQUATE SEC'ENTS = %(2)0000000100101000;                        <<00649>>03198000
EQUATE     BROTHER = 0,                                        <<01026>>03200000
           SON     = 1;                                        <<01026>>03202000
LOGICAL ARRAY   DIRECTORY(0:127);                              <<00207>>03204000
DOUBLE ARRAY    DDIRECTORY(*)=DIRECTORY;                       <<00207>>03206000
DEFINE          LID  =  DIRECTORY#,                            <<00207>>03208000
                NE   =  DIRECTORY(1)#,                         <<00207>>03210000
                DL   =  DIRECTORY(2)#,                         <<00207>>03212000
                TDG  =  DIRECTORY(3)#,                         <<00207>>03214000
                NDG  =  DIRECTORY(4)#,                         <<00207>>03216000
                BDL  =  DIRECTORY(5)#,                         <<00207>>03218000
                IPL  =  DIRECTORY(6)#,                         <<00207>>03220000
                SEGL =  DIRECTORY(7)#,                         <<00207>>03222000
                FL   = DDIRECTORY(4)#,                         <<00207>>03224000
                SAAD =  DIRECTORY(10)#,                        <<00207>>03226000
                ADL  =  DIRECTORY(11)#,                        <<00207>>03228000
                SAI  = DDIRECTORY(6)#,                         <<00207>>03230000
                IL   = DDIRECTORY(7)#,                         <<00207>>03232000
                IL2  =  DIRECTORY(15)#,                        <<00207>>03234000
                SAAI = DDIRECTORY(8)#,                         <<00207>>03236000
                AIL  = DDIRECTORY(9)#,                         <<00207>>03238000
                TIG  = DDIRECTORY(10)#,                        <<00207>>03240000
                NIG  =  DIRECTORY(22)#;                        <<00207>>03242000
                                                               <<00207>>03244000
LOGICAL ARRAY DIRECTORYN(0:127);                               <<00207>>03246000
DOUBLE ARRAY  DDIRECTORYN(*)=DIRECTORYN;                       <<00207>>03248000
DEFINE        N'LID  =  DIRECTORYN#,                           <<00207>>03250000
              N'NE   =  DIRECTORYN(1)#,                        <<00207>>03252000
              N'DL   =  DIRECTORYN(2)#,                        <<00207>>03254000
              N'TDG  =  DIRECTORYN(3)#,                        <<00207>>03256000
              N'NDG  =  DIRECTORYN(4)#,                        <<00207>>03258000
              N'BDL  =  DIRECTORYN(5)#,                        <<00207>>03260000
              N'IPL  =  DIRECTORYN(6)#,                        <<00207>>03262000
              N'SEGL =  DIRECTORYN(7)#,                        <<00207>>03264000
              N'FL   = DDIRECTORYN(4)#,                        <<00207>>03266000
              N'SAAD =  DIRECTORYN(10)#,                       <<00207>>03268000
              N'ADL  =  DIRECTORYN(11)#,                       <<00207>>03270000
              N'SAI  = DDIRECTORYN(6)#,                        <<00207>>03272000
              N'IL   = DDIRECTORYN(7)#,                        <<00207>>03274000
              N'IL2  =  DIRECTORYN(15)#,                       <<00207>>03276000
              N'SAAI = DDIRECTORYN(8)#,                        <<00207>>03278000
              N'AIL  = DDIRECTORYN(9)#,                        <<00207>>03280000
              N'TIG  = DDIRECTORYN(10)#,                       <<00207>>03282000
              N'NIG  =  DIRECTORYN(22)#;                       <<00207>>03284000
ARRAY           HL(*)=DIRECTORYN(33);                          <<00207>>03286000
                                                               <<00207>>03288000
BYTE POINTER    NAME;                                          <<00207>>03290000
DOUBLE          DKEY;                                          <<00207>>03292000
BYTE ARRAY      KEY(*)=DKEY;                                   <<00207>>03294000
INTEGER         XREG=X;                                        <<00207>>03296000
INTEGER         I;                                             <<00207>>03298000
INTEGER         J;                                             <<00207>>03300000
INTEGER         P;                                             <<00207>>03302000
DOUBLE          RECNUM;  <<CURRENT RECORD NUMBER>>             <<00207>>03304000
INTEGER         INDEX;  <<WORD POSITION IN RECORD>>            <<00207>>03306000
DOUBLE          RECORDNUM;                                     <<00207>>03308000
INTEGER         SIZE;                                          <<00207>>03310000
DOUBLE          CODEINX;                                       <<00207>>03312000
DOUBLE          OLDRECNUM;                                     <<00207>>03314000
DOUBLE          HEDNUM;  <<VARIABLE HEADER NUMBER IN FILE>>    <<00207>>03316000
INTEGER         NUMEXTENTS;                                    <<00207>>03320000
INTEGER         FOPT;                                          <<00660>>03322000
DEFINE  NEWPASS  = FOPT.(10:3) = 2 #,                          <<00660>>03324000
        OLDPASS  = FOPT.(10:3) = 3 #;                          <<00660>>03326000
BYTE ARRAY      NEWNAME(0:9);                                  <<00660>>03328000
$PAGE "USLCLEAN  -  ERROR"                                     <<00207>>03330000
SUBROUTINE ERROR(ERRNUM);                                      <<00207>>03332000
  VALUE ERRNUM;                                                <<00207>>03334000
  INTEGER ERRNUM;                                              <<00207>>03336000
BEGIN                                                          <<00207>>03338000
                                                               <<00207>>03340000
  CLEANUSL:=ERRNUM;   <<return error number to caller>>        <<00207>>03342000
  CONDCODE:=CCL;      <<set condition code>>                   <<00207>>03344000
  ASSEMBLE (EXIT 2);  <<exit from procedure>>                  <<00207>>03346000
END;                                                           <<00207>>03348000
$PAGE  "USLCLEAN  -  FETCH'ENTRY"                              <<00207>>03350000
SUBROUTINE FETCH'ENTRY(RECNUM,BUF);                            <<00207>>03352000
  VALUE RECNUM;                                                <<00207>>03354000
  DOUBLE RECNUM;                                               <<00207>>03356000
  LOGICAL ARRAY BUF;                                           <<00207>>03358000
                                                               <<00207>>03360000
BEGIN                                                          <<00207>>03362000
                                                               <<00207>>03364000
                                                               <<00207>>03366000
                                                               <<00207>>03368000
  RECORDNUM:=RECNUM&DASR(7);                                   <<00207>>03370000
  I:=INTEGER(RECNUM - RECORDNUM&DASL(7));                      <<00207>>03372000
                                                               <<00207>>03374000
  FREADDIR(USLFILE,BUF,128,RECORDNUM);  <<GET A RECORD>>       <<00207>>03376000
  IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);                  <<00207>>03378000
  LENGTH:=BUF(I).(1:10);  <<NUMBER OF WORDS IN IT>>            <<00207>>03380000
                                                               <<00207>>03382000
  IF I>0 THEN                                                  <<00207>>03384000
  BEGIN                                                        <<00207>>03386000
    J:=(IF LENGTH < 128-I THEN LENGTH ELSE 128-I);             <<00207>>03388000
    MOVE BUF:=BUF(I),(J);                                      <<00207>>03390000
    IF LENGTH>J THEN                                           <<00207>>03392000
     BEGIN      <<GET THE REST>>                               <<00207>>03394000
       FREADDIR(USLFILE,BUF(J),LENGTH-J,RECORDNUM+1D);         <<00207>>03396000
       IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);             <<00207>>03398000
     END;                                                      <<00207>>03400000
  END                                                          <<00207>>03402000
 ELSE                                                          <<00207>>03404000
   IF LENGTH>128 THEN                                          <<00207>>03406000
     BEGIN                                                     <<00207>>03408000
       FREADDIR(USLFILE,BUF(128),LENGTH-128,RECORDNUM+1D);     <<00207>>03410000
       IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);             <<00207>>03412000
     END;                                                      <<00207>>03414000
END;                                                           <<00207>>03416000
$PAGE "USLCLEAN  -  DUMP'DRT"                                  <<00207>>03418000
SUBROUTINE DUMP'DRT;                                           <<00207>>03420000
                                                               <<00207>>03422000
BEGIN     <<copy directory entry from old usl to new usl>>     <<00207>>03424000
  N'NE:=N'NE+1;                                                <<00207>>03426000
  LENGTH:=DRT'INBUF.(1:10);                                    <<00207>>03428000
  OFFSET1:=0;                                                  <<00207>>03430000
LOOP:                                                          <<00207>>03432000
  IF (128-OFFSET)>LENGTH THEN                                  <<00207>>03434000
    BEGIN                                                      <<00207>>03436000
      MOVE DRT'BUF(OFFSET):=DRT'INBUF(OFFSET1),(LENGTH);       <<00207>>03438000
      OFFSET:=OFFSET+LENGTH;                                   <<00207>>03440000
      N'SAAD:=INTEGER(N'SAAD)+LENGTH;                          <<00207>>03442000
    END                                                        <<00207>>03444000
  ELSE                                                         <<00207>>03446000
    BEGIN                                                      <<00207>>03448000
    MOVE DRT'BUF(OFFSET):=DRT'INBUF(OFFSET1),                  <<00207>>03450000
    (I:=IF (128-OFFSET)>LENGTH THEN LENGTH ELSE (128-OFFSET)); <<00207>>03452000
      LENGTH:=LENGTH-I;                                        <<00207>>03454000
      OFFSET1:=OFFSET1+I;                                      <<00207>>03456000
      FWRITEDIR(NEWUSL,DRT'BUF,128,DOUBLE(N'SAAD&ASR(7)));     <<00207>>03458000
      IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);              <<00207>>03460000
      N'SAAD:=INTEGER(N'SAAD)+I;                               <<00207>>03462000
      OFFSET:=0;                                               <<00207>>03464000
      IF LENGTH>0 THEN GO TO LOOP;                             <<00207>>03466000
    END;                                                       <<00207>>03468000
END;                                                           <<00207>>03470000
$PAGE "USLCLEAN  -  DUMP'INFO"                                 <<00207>>03472000
SUBROUTINE DUMP'INFO(LEN);                                     <<00207>>03474000
  VALUE LEN;                                                   <<00207>>03476000
  INTEGER LEN;                                                 <<00207>>03478000
BEGIN     <<copy information form new usl to old usl>>         <<00207>>03480000
  OFFSET2:=0;                                                  <<00207>>03482000
LOOP:                                                          <<00207>>03484000
  IF (128-OFFSETI)>LEN THEN                                    <<00207>>03486000
    BEGIN                                                      <<00207>>03488000
      MOVE INFO'BUF(OFFSETI):=INFO'INBUF(OFFSET2),(LEN);       <<00207>>03490000
      OFFSETI:=OFFSETI+LEN;                                    <<00207>>03492000
      N'SAAI:=N'SAAI+DOUBLE(LEN);                              <<00207>>03494000
    END                                                        <<00207>>03496000
  ELSE                                                         <<00207>>03498000
    BEGIN                                                      <<00207>>03500000
      MOVE INFO'BUF(OFFSETI):=INFO'INBUF(OFFSET2),             <<00207>>03502000
       (I:=IF (128-OFFSETI)>LEN THEN LEN ELSE (128-OFFSETI));  <<00207>>03504000
      LEN:=LEN-I;                                              <<00207>>03506000
      OFFSET2:=OFFSET2+I;                                      <<00207>>03508000
      FWRITEDIR(NEWUSL,INFO'BUF,128,(N'SAAI&DASR(7)));         <<00207>>03510000
      IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);              <<00207>>03512000
      N'SAAI:=N'SAAI+DOUBLE(I);                                <<00207>>03514000
      OFFSETI:=0;                                              <<00207>>03516000
      IF LEN>0 THEN GO TO LOOP;                                <<00207>>03518000
    END;                                                       <<00207>>03520000
END;                                                           <<00207>>03522000
$PAGE "USLCLEAN  -  FIXUP"                                     <<00207>>03524000
SUBROUTINE FIXUP(OLD,FAMILY);                                  <<01026>>03526000
  VALUE OLD,FAMILY;                                            <<01026>>03528000
  INTEGER OLD,FAMILY;                                          <<01026>>03530000
    BEGIN<<NOT FIRST SEGMENT, PROCEDURE OR SECONDARY ENTRY>>   <<00207>>03532000
      IF OLD.(0:9)=INTEGER(N'SAAD.(0:9)) THEN                  <<00207>>03534000
        BEGIN                                                  <<00207>>03536000
          I:=OLD.(9:7);                                        <<00207>>03538000
          I:=I+INTEGER(DRT'BUF(I+2).(4:4))/2+3;                <<00207>>03540000
          IF FAMILY = BROTHER THEN                             <<01026>>03542000
             DRT'BUF(I) := N'SAAD                              <<01026>>03544000
          ELSE                                                 <<01026>>03546000
             DRT'BUF(I+1) := LOGICAL(OLD) LOR %100000;         <<01026>>03548000
        END                                                    <<00207>>03550000
      ELSE                                                     <<00207>>03552000
        BEGIN                                                  <<00207>>03554000
          FWRITEDIR(NEWUSL,DRT'BUF,128,DOUBLE(N'SAAD&ASR(7))); <<00207>>03556000
          IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);          <<00207>>03558000
          FREADDIR(NEWUSL,INFO'INBUF,256,DOUBLE(OLD&ASR(7)));  <<00207>>03560000
          IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);          <<00207>>03562000
          I:=OLD.(9:7);                                        <<00207>>03564000
          I:=I+INTEGER(INFO'INBUF(I+2).(4:4))/2+3;             <<00207>>03566000
          IF FAMILY = BROTHER THEN                             <<01026>>03568000
             INFO'INBUF(I) := N'SAAD                           <<01026>>03570000
          ELSE                                                 <<01026>>03572000
             INFO'INBUF(I+1) := LOGICAL(OLD) LOR %100000;      <<01026>>03574000
          FWRITEDIR(NEWUSL,INFO'INBUF,256,DOUBLE(OLD&ASR(7))); <<00207>>03576000
          IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);          <<00207>>03578000
          <<REFRESH THE DRT'BUF>>                              <<00207>>03580000
          FREADDIR(NEWUSL,DRT'BUF,128,DOUBLE(N'SAAD&ASR(7)));  <<00207>>03582000
          IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);          <<00207>>03584000
        END;                                                   <<00207>>03586000
    END;                                                       <<00207>>03588000
$PAGE "USLCLEAN  -  DUMP'CODE"                                 <<00207>>03590000
SUBROUTINE DUMP'CODE(START,LENGTH);                            <<00207>>03592000
  VALUE START,LENGTH;                                          <<00207>>03594000
  DOUBLE START;                                                <<00207>>03596000
  INTEGER LENGTH;                                              <<00207>>03598000
                                                               <<00207>>03600000
BEGIN     <<copy code form old usl to new usl>>                <<00207>>03602000
                                                               <<00207>>03604000
                                                               <<00207>>03606000
                                                               <<00207>>03608000
                                                               <<00207>>03610000
  RECNUM:=START&DASR(7);    <<RECORD NUMBER>>                  <<00207>>03612000
  INDEX:=INTEGER(START - RECNUM&DASL(7));  <<WORD INDEX>>      <<00207>>03614000
                                                               <<00207>>03616000
  FREADDIR(USLFILE,INFO'INBUF,128,RECNUM);                     <<00207>>03618000
  IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);                  <<00207>>03620000
  IF LENGTH<=128-INDEX THEN                                    <<00207>>03622000
    BEGIN                                                      <<00207>>03624000
      MOVE INFO'INBUF:=INFO'INBUF(INDEX),(128-INDEX);          <<00207>>03626000
      DUMP'INFO(LENGTH);                                       <<00207>>03628000
    END                                                        <<00207>>03630000
  ELSE   <<HAVE TO GET MORE>>                                  <<00207>>03632000
    BEGIN                                                      <<00207>>03634000
    J:=0;                                                      <<00207>>03636000
L:                                                             <<00207>>03638000
      J:=IF LENGTH<128 THEN LENGTH ELSE 128;                   <<00207>>03640000
      LENGTH:=LENGTH-(128-INDEX);                              <<00207>>03642000
      MOVE INFO'INBUF:=INFO'INBUF(INDEX),(128-INDEX);          <<00207>>03644000
      IF LENGTH>0 THEN                                         <<00207>>03646000
        BEGIN                                                  <<00207>>03648000
          FREADDIR(USLFILE,INFO'INBUF(128-INDEX),INDEX,        <<00207>>03650000
                  (RECNUM:=RECNUM+1D));                        <<00207>>03652000
          IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);          <<00207>>03654000
          LENGTH:=LENGTH-INDEX;                                <<00207>>03656000
        END;                                                   <<00207>>03658000
      DUMP'INFO(J);                                            <<00207>>03660000
      IF LENGTH>0 THEN                                         <<00207>>03662000
        BEGIN                                                  <<00207>>03664000
          FREADDIR(USLFILE,INFO'INBUF,128,RECNUM);             <<00207>>03666000
          IF <> THEN ERROR(IF > THEN ERR0 ELSE ERR1);          <<00207>>03668000
          GO TO L;                                             <<00207>>03670000
        END;                                                   <<00207>>03672000
    END;                                                       <<00207>>03674000
END;  <<SUBROUTINE DUMP'CODE>>                                 <<00207>>03676000
$PAGE "USLCLEAN  -  SET'HL"                                    <<00207>>03678000
SUBROUTINE SET'HL;                                             <<00207>>03680000
BEGIN     <<calculate hask link>>                              <<00207>>03682000
                                                               <<00207>>03684000
  @NAME:=@DRT'INBUF(2)&LSL(1);                                 <<00207>>03686000
  LENGTH:=NAME.(12:4);                                         <<00207>>03688000
  KEY:=LENGTH;                                                 <<00207>>03690000
  KEY(1):=NAME(1);                                             <<00207>>03692000
  KEY(2):=IF LENGTH>1 THEN NAME(LENGTH-1) ELSE LENGTH;         <<00207>>03694000
  KEY(3):=NAME(LENGTH);                                        <<00207>>03696000
  I:=INTEGER(DKEY-95D*(DKEY/95D));                             <<00207>>03698000
                                                               <<00207>>03700000
  IF HL(I)=0 THEN                                              <<00207>>03702000
    BEGIN                                                      <<00207>>03704000
      DRT'INBUF(1):=0;                                         <<00207>>03706000
      HL(I):=N'SAAD;                                           <<00207>>03708000
    END                                                        <<00207>>03710000
  ELSE                                                         <<00207>>03712000
    BEGIN                                                      <<00207>>03714000
      DRT'INBUF(1):=HL(I);                                     <<00207>>03716000
      HL(I):=N'SAAD;                                           <<00207>>03718000
    END;                                                       <<00207>>03720000
                                                               <<00207>>03722000
END;                                                           <<00207>>03724000
$PAGE "USLCLEAN  -  DO'HEADER"                                 <<00207>>03726000
SUBROUTINE DO'HEADER(HEADER);                                  <<00207>>03728000
ARRAY HEADER;                                                  <<00207>>03730000
BEGIN                                                          <<00207>>03732000
                                                               <<00207>>03734000
  NH:=HEADER.(1:15);                                           <<00207>>03736000
  @DBL:=@HEADER(1);                                            <<00207>>03738000
  SAH:=DBL;                                                    <<00207>>03740000
  DBL:=N'SAAI-N'SAI;                                           <<00207>>03742000
                                                               <<00207>>03744000
  WHILE NH>0 DO                                                <<00207>>03746000
  BEGIN                                                        <<00207>>03748000
    IF SAH=SAC AND CODE'NOT'SEEN THEN                          <<00207>>03750000
      BEGIN                                                    <<00207>>03752000
        SAH:=SAH+DOUBLE(NWC);  <<SKIP OVER CODE>>              <<00207>>03754000
        CODE'NOT'SEEN:=FALSE;                                  <<00207>>03756000
      END                                                      <<00207>>03758000
    ELSE                                                       <<00207>>03760000
      BEGIN                                                    <<00207>>03762000
        FETCH'ENTRY((SAH+SAI),INFO'INBUF);                     <<00207>>03764000
        J:=INFO'INBUF.(1:10);                                  <<00207>>03766000
        DUMP'INFO(J);                                          <<00207>>03768000
        SAH:=SAH+DOUBLE(J);                                    <<00207>>03770000
        NH:=NH-1;                                              <<00207>>03772000
      END;                                                     <<00207>>03774000
  END;                                                         <<00207>>03776000
END;                                                           <<00207>>03778000
$PAGE  "USLCLEAN  -  DO'SEC'ENTRY"                             <<00207>>03780000
SUBROUTINE DO'SEC'ENTRY;                                       <<00207>>03782000
                                                               <<00207>>03784000
BEGIN                                                          <<00207>>03786000
  OLDSECL:=0;                                                  <<00207>>03788000
                                                               <<00207>>03790000
L:                                                             <<00207>>03792000
                                                               <<00207>>03794000
  IF LOGICAL(SECL.(0:1)) THEN RETURN;                          <<00207>>03796000
  FETCH'ENTRY(DOUBLE(SECL),DRT'INBUF);  <<GET IT>>             <<00207>>03798000
  NC:=DRT'INBUF(2).(4:4);                                      <<00207>>03800000
  INX:=NC/2+3;                                                 <<00207>>03802000
                                                               <<00207>>03804000
  IF DRT'INBUF(2).(0:1)=1 THEN                                 <<00207>>03806000
    BEGIN <<INACTIVE>>                                         <<00207>>03808000
      SECL:=DRT'INBUF(INX);                                    <<00207>>03810000
      GO TO L;                                                 <<00207>>03812000
    END;                                                       <<00207>>03814000
                                                               <<00207>>03816000
  SET'HL;                                                      <<00207>>03818000
                                                               <<00207>>03820000
  SECL:=DRT'INBUF(INX);                                        <<00207>>03822000
  DRT'INBUF(INX):=%100000 LOR LOGICAL(OLDSUBL);                <<00207>>03824000
  IF NOT SEC'ENTS&CSR(DRT'INBUF.(11:5)) THEN ERROR(ILLEGALUSL);<<00649>>03826000
                                                               <<00207>>03830000
  IF OLDSECL<>0 THEN                                           <<00207>>03832000
    FIXUP(OLDSECL,BROTHER);                                    <<01026>>03834000
                                                               <<00207>>03836000
  OLDSECL:=N'SAAD;                                             <<00207>>03838000
                                                               <<00207>>03840000
  DUMP'DRT;                                                    <<00207>>03842000
                                                               <<00207>>03844000
                                                               <<00207>>03846000
  GO TO L;                                                     <<00207>>03848000
END;  <<SUBROUTINE DO'SEC'ENTRY>>                              <<00207>>03850000
$PAGE  "USLCLEAN  -  DO'PROC'ENTRY"                            <<00207>>03852000
SUBROUTINE DO'PROC'ENTRY;                                      <<00207>>03854000
BEGIN                                                          <<00207>>03856000
                                                               <<00207>>03858000
  OLDSUBL:=0;                                                  <<00207>>03860000
                                                               <<00207>>03864000
L:                                                             <<00207>>03866000
  CODE'NOT'SEEN := TRUE;                                       <<01015>>03868000
                                                               <<00207>>03870000
  IF LOGICAL(SUBL.(0:1)) THEN RETURN;                          <<00207>>03872000
  FETCH'ENTRY(DOUBLE(SUBL),DRT'INBUF);                         <<00207>>03874000
                                                               <<00207>>03876000
  NC:=DRT'INBUF(2).(4:4);  <<IDENTIFIER LENGTH>>               <<00207>>03878000
  INX:=NC/2+3;  <<INDEX OF SUBL THING>>                        <<00207>>03880000
                                                               <<00207>>03882000
  IF DRT'INBUF(2).(0:1)=1 THEN                                 <<00207>>03884000
  BEGIN   <<INACTIVE>>                                         <<00207>>03886000
    SUBL:=DRT'INBUF(INX);                                      <<00207>>03888000
    GO TO L;                                                   <<00207>>03890000
  END;                                                         <<00207>>03892000
                                                               <<00207>>03894000
  SET'HL;                                                      <<00207>>03896000
                                                               <<00207>>03898000
  IF DRT'INBUF.(11:5)<>2 AND DRT'INBUF.(11:5)<>4 THEN          <<00207>>03900000
     ERROR(ILLEGALUSL);                                        <<00207>>03902000
                                                               <<00207>>03904000
                                                               <<00207>>03906000
  SUBL:=DRT'INBUF(INX);                                        <<00207>>03908000
  SECL:=DRT'INBUF(INX+1);                                      <<00207>>03910000
  DRT'INBUF(INX):=%100000 LOR LOGICAL(OLDSEGL); <<NEW SUBL>>   <<00207>>03912000
  DRT'INBUF(INX+1):=IF DRT'INBUF(INX+1).(0:1) THEN             <<00207>>03914000
            N'SAAD LOR %100000  <<POINTS TO ITSELF>>           <<00207>>03916000
          ELSE                                                 <<00207>>03918000
            N'SAAD+DRT'INBUF.(1:10);  <<POINTS TO FIRST SON>>  <<00207>>03920000
  @DBL:=@DRT'INBUF(INX+3);      <<DOUBLE SAC>>                 <<00207>>03922000
  SAC:=DBL;                                                    <<00207>>03924000
  NWC:=DRT'INBUF(INX+5).(2:14);  <<NUMBER OF WORDS OF CODE>>   <<00207>>03926000
  IF DRT'INBUF.(11:5)=4 THEN                                   <<00207>>03928000
  <<SUBROUTINE  BLOCK.  HAVE TO  SQUEEZE AROUND >>             <<00207>>03930000
      <<THE PARAMETER CHECKING CRAP>>                          <<00207>>03932000
  CASE DRT'INBUF(INX+11).(0:2) OF                              <<00207>>03934000
  BEGIN                                                        <<00207>>03936000
       JINX:=INX+12; <<NO CHECKING - NO PARM WORD>>            <<00207>>03938000
       JINX:=INX+13; <<TN PRESENT, NO PARM WORD>>              <<00207>>03940000
       JINX:=INX+13; <<TN PRESENT, NO PARM WORD>>              <<00207>>03942000
       JINX:=INX+13+INTEGER(DRT'INBUF(INX+11).(2:6));          <<00207>>03944000
  END                                                          <<00207>>03946000
 ELSE                                                          <<00207>>03948000
  JINX:=INX+11;  <<OUTER BLOCK>>                               <<00207>>03950000
                                                               <<00207>>03952000
<<NOW JINX IS INDEX OF FIRST HEADER SECTION>>                  <<00207>>03954000
                                                               <<00207>>03956000
  IF INTEGER(DRT'INBUF.(1:10)) > JINX THEN                     <<00207>>03958000
  BEGIN  <<SOME HEADER BLOCKS EXIST>>                          <<00207>>03960000
P1:  <<START A LOOP>>                                          <<00207>>03962000
    DO'HEADER(DRT'INBUF(JINX));                                <<00207>>03964000
    IF DRT'INBUF(JINX).(0:1)=0 THEN     <<NH>>                 <<00207>>03966000
    BEGIN  <<NOT THE LAST ONE>>                                <<00207>>03968000
      JINX:=JINX+INTEGER(DRT'INBUF(JINX).(1:15))+3;            <<00207>>03970000
      GO TO P1;  <<REPEAT THE THING>>                          <<00207>>03972000
    END                                                        <<00207>>03974000
  END;                                                         <<00207>>03976000
                                                               <<00207>>03978000
  @DBL:=@DRT'INBUF(INX+3);                                     <<00207>>03980000
  DBL:=N'SAAI-N'SAI;  <<NEW SAC>>                              <<00207>>03982000
  DUMP'CODE((SAI+SAC),NWC);   <<COPY THE CODE>>                <<00207>>03984000
  IF OLDSUBL<>0 THEN                                           <<00207>>03986000
    FIXUP(OLDSUBL,BROTHER);                                    <<01026>>03988000
                                                               <<00207>>03990000
  OLDSUBL:=N'SAAD;                                             <<00207>>03992000
                                                               <<00207>>03994000
  DUMP'DRT;                                                    <<00207>>03996000
                                                               <<00207>>03998000
  IF NOT(LOGICAL(SECL).(0:1)) THEN << COULD BE SONS >>         <<01026>>04000000
     BEGIN                                                     <<01026>>04002000
     TOS := N'SAAD;                                            <<01026>>04004000
     DO'SEC'ENTRY;                                             <<01026>>04006000
     IF TOS = N'SAAD THEN  << ALL SONS WERE INACTIVE >>        <<01026>>04008000
        FIXUP(OLDSUBL,SON);                                    <<01026>>04010000
     END;                                                      <<01026>>04012000
                                                               <<01026>>04014000
  GO L;                                                        <<01026>>04016000
  GO TO L;                                                     <<00207>>04018000
END;  <<SUBROUTINE DO'PROC'ENTRY>>                             <<00207>>04020000
$PAGE  "USLCLEAN  -  DO'SEGMENT"                               <<00207>>04022000
SUBROUTINE DO'SEGMENT;                                         <<00207>>04024000
BEGIN                                                          <<00207>>04026000
                                                               <<00207>>04028000
  IF SEGL=0 THEN RETURN;  <<NO SEGMENTS>>                      <<00438>>04030000
  N'SEGL:=N'SAAD;                                              <<00207>>04032000
  OLDSEGL:=0;                                                  <<00207>>04034000
L:                                                             <<00207>>04036000
                                                               <<00207>>04038000
  IF SEGL = 0 THEN   <<NO MORE SEGMENTS>>                      <<01026>>04040000
     BEGIN                                                     <<01026>>04042000
     IF N'SAAD = 128 THEN N'SEGL := 0; <<NO SEGMENTS COPIED>>  <<01026>>04044000
     RETURN;                                                   <<01026>>04046000
     END;                                                      <<01026>>04048000
  FETCH'ENTRY(DOUBLE(SEGL),DRT'INBUF); <<GET SEGMENT IN CORE>> <<00207>>04050000
  IF DRT'INBUF.(11:5)<>1 THEN ERROR(ILLEGALUSL);<<NOT SEGMNT>> <<00207>>04052000
  NC:=DRT'INBUF(2).(4:4);   <<# OF CHARACTERS>>                <<00207>>04054000
  INX:=NC/2+3;    <<INDEX TO SEGL>>                            <<00207>>04056000
  IF LOGICAL(DRT'INBUF(2).(0:1)) THEN                          <<00207>>04058000
    BEGIN     <<INACTIVE>>                                     <<00207>>04060000
      SEGL:=DRT'INBUF(INX);                                    <<00207>>04062000
      GO TO L;  <<GO GET NEXT SEGMENT>>                        <<00207>>04064000
    END;                                                       <<00207>>04066000
                                                               <<00207>>04068000
  SET'HL;                                                      <<00207>>04070000
                                                               <<00207>>04072000
  SUBL:=DRT'INBUF(INX+1);  <<FIRST PROCEDURE ENTRY>>           <<00207>>04074000
  SEGL:=DRT'INBUF(INX);    <<NEXT SEGMENT>>                    <<00207>>04076000
  DRT'INBUF(INX):=0;  <<NEW SEGL>>                             <<00207>>04078000
  DRT'INBUF(INX+1):=IF DRT'INBUF(INX+1).(0:1) THEN             <<00207>>04080000
             N'SAAD LOR %100000<<NO SON; POINTS TO ITSELF>>    <<00207>>04082000
           ELSE                                                <<00207>>04084000
             N'SAAD+DRT'INBUF.(1:10);  <<POINTS TO FIRST SON>> <<00207>>04086000
  IF OLDSEGL<>0 THEN                                           <<00207>>04088000
    FIXUP(OLDSEGL,BROTHER);                                    <<01026>>04090000
                                                               <<00207>>04092000
  OLDSEGL:=N'SAAD;                                             <<00207>>04094000
  DUMP'DRT;                                                    <<00207>>04096000
                                                               <<00207>>04098000
  TOS := N'SAAD;                                               <<01026>>04100000
  DO'PROC'ENTRY;                                               <<00207>>04102000
  IF TOS = N'SAAD THEN << NO SONS EXIST >>                     <<01026>>04104000
     FIXUP(OLDSEGL,SON);                                       <<01026>>04106000
  GO TO L;                                                     <<00207>>04108000
END;  <<SUBROUTINE DO'SEGMENT>>                                <<00207>>04110000
$PAGE  "USLCLEAN  -  DO'INTERRUPT"                             <<00207>>04112000
SUBROUTINE DO'INTERRUPT;                                       <<00207>>04114000
BEGIN                                                          <<00207>>04116000
                                                               <<00438>>04118000
  IF IPL=0 THEN RETURN;  <<NO INTERRUPT PROCS>>                <<00438>>04120000
  N'IPL := N'SAAD;                                             <<00438>>04122000
  OLDIPL:=0;                                                   <<00207>>04126000
L:                                                             <<00207>>04128000
  CODE'NOT'SEEN := TRUE;                                       <<01015>>04130000
  IF IPL=0 THEN RETURN;  <<NO MORE INTERRUPT PROC>>            <<00207>>04132000
  FETCH'ENTRY(DOUBLE(IPL),DRT'INBUF); <<GET INTERRUPT PROC>>   <<00207>>04134000
  IF DRT'INBUF.(11:5)<>6 THEN ERROR(ILLEGALUSL);               <<00438>>04136000
  NC:=DRT'INBUF(2).(4:4);   <<# OF CHARACTERS>>                <<00207>>04138000
  INX:=NC/2+3;    <<INDEX TO IPL>>                             <<00207>>04140000
  IF LOGICAL(DRT'INBUF(2).(0:1)) THEN                          <<00207>>04142000
    BEGIN     <<INACTIVE>>                                     <<00207>>04144000
      IPL:=DRT'INBUF(INX);                                     <<00207>>04146000
      GO TO L;  <<GO GET NEXT INTERRUPT PROC>>                 <<00207>>04148000
    END;                                                       <<00207>>04150000
                                                               <<00207>>04152000
  SET'HL;                                                      <<00207>>04154000
                                                               <<00207>>04156000
  IPL:=DRT'INBUF(INX);    <<NEXT INTERRUPT PROC>>              <<00207>>04158000
  DRT'INBUF(INX):=0;  <<NEW IPL>>                              <<00207>>04160000
  @DBL:=@DRT'INBUF(INX+3);      <<DOUBLE SAC>>                 <<00438>>04162000
  SAC:=DBL;                                                    <<00438>>04164000
  NWC:=DRT'INBUF(INX+5).(2:14);  <<NUMBER OF WORDS OF CODE>>   <<00438>>04166000
  JINX:=INX+6;                                                 <<00438>>04168000
                                                               <<00438>>04170000
<<NOW JINX IS INDEX OF FIRST HEADER SECTION>>                  <<00438>>04172000
                                                               <<00438>>04174000
  IF INTEGER(DRT'INBUF.(1:10)) > JINX THEN                     <<00438>>04176000
  BEGIN  <<SOME HEADER BLOCKS EXIST>>                          <<00438>>04178000
P1:  <<START A LOOP>>                                          <<00438>>04180000
    DO'HEADER(DRT'INBUF(JINX));                                <<00438>>04182000
    IF DRT'INBUF(JINX).(0:1)=0 THEN     <<NH>>                 <<00438>>04184000
    BEGIN  <<NOT THE LAST ONE>>                                <<00438>>04186000
      JINX:=JINX+INTEGER(DRT'INBUF(JINX).(1:15))+3;            <<00438>>04188000
      GO TO P1;  <<REPEAT THE THING>>                          <<00438>>04190000
    END                                                        <<00438>>04192000
  END;                                                         <<00438>>04194000
                                                               <<00438>>04196000
  @DBL:=@DRT'INBUF(INX+3);                                     <<00438>>04198000
  DBL:=N'SAAI-N'SAI;  <<NEW SAC>>                              <<00438>>04200000
  DUMP'CODE((SAI+SAC),NWC);   <<COPY THE CODE>>                <<00438>>04202000
  IF OLDIPL<>0 THEN                                            <<00207>>04204000
    FIXUP(OLDIPL,BROTHER);                                     <<01026>>04206000
                                                               <<00207>>04208000
  OLDIPL:=N'SAAD;                                              <<00207>>04210000
  DUMP'DRT;                                                    <<00207>>04212000
                                                               <<00207>>04214000
  GO TO L;                                                     <<00207>>04216000
END;  <<SUBROUTINE DO'INTERRUPT PROC>>                         <<00207>>04218000
$PAGE  "USLCLEAN  -  DO'BLOCKDATA"                             <<00207>>04220000
SUBROUTINE DO'BLOCKDATA;                                       <<00207>>04222000
BEGIN                                                          <<00207>>04224000
                                                               <<00438>>04226000
  IF BDL=0 THEN RETURN;  <<NO BLOCKDATA'S>>                    <<00438>>04228000
  N'BDL := N'SAAD;                                             <<00438>>04230000
  OLDBDL:=0;                                                   <<00207>>04234000
L:                                                             <<00207>>04236000
  CODE'NOT'SEEN := TRUE;                                       <<01015>>04238000
  IF BDL=0 THEN RETURN;  <<NO MORE BLOCKDATA>>                 <<00207>>04240000
  FETCH'ENTRY(DOUBLE(BDL),DRT'INBUF); <<GET BLOCKDATA IN CORE>><<00207>>04242000
  IF DRT'INBUF.(11:5)<>7 THEN ERROR(ILLEGALUSL);               <<00438>>04244000
  NC:=DRT'INBUF(2).(4:4);   <<# OF CHARACTERS>>                <<00207>>04246000
  INX:=NC/2+3;    <<INDEX TO BDL>>                             <<00207>>04248000
  IF LOGICAL(DRT'INBUF(2).(0:1)) THEN                          <<00207>>04250000
    BEGIN     <<INACTIVE>>                                     <<00207>>04252000
      BDL:=DRT'INBUF(INX);                                     <<00207>>04254000
      GO TO L;  <<GO GET NEXT BLOCKDATA>>                      <<00207>>04256000
    END;                                                       <<00207>>04258000
                                                               <<00207>>04260000
  SET'HL;                                                      <<00207>>04262000
                                                               <<00207>>04264000
  BDL:=DRT'INBUF(INX);    <<NEXT BLOCKDATA>>                   <<00207>>04266000
  DRT'INBUF(INX):=0;  <<NEW BDL>>                              <<00207>>04268000
                                                               <<00438>>04270000
  JINX:=INX+2;                                                 <<00438>>04272000
  WHILE INTEGER(DRT'INBUF.(1:10)) > JINX DO                    <<00438>>04274000
     BEGIN                                                     <<00438>>04276000
     JINX := JINX+INTEGER(DRT'INBUF(JINX).(4:3))+1;            <<00438>>04278000
P1:                                                            <<00438>>04280000
     DO'HEADER(DRT'INBUF(JINX));                               <<00438>>04282000
     IF DRT'INBUF(JINX).(0:1) = 0 THEN                         <<00438>>04284000
        BEGIN                                                  <<00438>>04286000
        JINX := JINX+INTEGER(DRT'INBUF(JINX).(1:15))+3;        <<00438>>04288000
        GO P1;                                                 <<00438>>04290000
        END;                                                   <<00438>>04292000
     JINX := JINX+INTEGER(DRT'INBUF(JINX).(1:15))+4;           <<00438>>04294000
     END;                                                      <<00438>>04296000
                                                               <<00438>>04298000
  IF OLDBDL<>0 THEN                                            <<00207>>04300000
    FIXUP(OLDBDL,BROTHER);                                     <<01026>>04302000
                                                               <<00207>>04304000
  OLDBDL:=N'SAAD;                                              <<00207>>04306000
  DUMP'DRT;                                                    <<00207>>04308000
                                                               <<00207>>04310000
  GO TO L;                                                     <<00207>>04312000
END;  <<SUBROUTINE DO'BLOCKDATA>>                              <<00207>>04314000
$PAGE   "USLCLEAN"                                             <<00207>>04316000
CHEK([10/85,6/2],[8/0,2/1,1/0,5/2],[2/3,2/0]D);                <<00207>>04318000
FREADDIR(USLFILE,DIRECTORY,128,0D);  <<GET DIRECTORY>>         <<00207>>04320000
IF <> THEN ERROR((IF < THEN ERR1 ELSE ERR0));                  <<00207>>04322000
FGETINFO(USLFILE,,FOPT,,,,,,,,,,,,,,,NUMEXTENTS);              <<00660>>04324000
IF <> THEN ERROR((IF < THEN ERR1 ELSE ERR0));                  <<00207>>04326000
ASSEMBLE( ZERO ); <<ROOM FOR RESULT OF FOPEN>>                 <<00660>>04328000
IF OLDPASS AND FILENAME = " " OR                               <<00660>>04330000
   FILENAME = "$OLDPASS" THEN                                  <<00660>>04332000
   BEGIN                                                       <<00660>>04334000
   MOVE NEWNAME := "$NEWPASS ";                                <<00660>>04336000
   TOS := @NEWNAME;                                            <<00660>>04338000
   END                                                         <<00660>>04340000
ELSE                                                           <<00660>>04342000
   TOS := @FILENAME;                                           <<00660>>04344000
                                                               <<00207>>04346000
NEWUSL:=FOPEN(*,0,%424,128,,,,,,FL&DLSR(7),NUMEXTENTS,,        <<00660>>04350000
      USLFILECODE);                                            <<00438>>04352000
IF < THEN ERROR(ERR7);                                         <<00207>>04354000
                                                               <<00207>>04356000
I:=INITUSLF(NEWUSL,DIRECTORYN);                                <<00207>>04360000
IF <> THEN ERROR(I);                                           <<00207>>04362000
                                                               <<00207>>04364000
N'SAAI:=N'SAI:=SAI;                                            <<00207>>04366000
                                                               <<00207>>04368000
FWRITEDIR(NEWUSL,INFO'BUF,128,(N'SAI&DASR(7)));                <<00207>>04370000
IF <> THEN ERROR((IF < THEN ERR1 ELSE ERR0));                  <<00207>>04372000
                                                               <<00207>>04374000
<<NOW GO DOWN THE SEGMENTS>>                                   <<00207>>04376000
                                                               <<00207>>04378000
DO'SEGMENT;                                                    <<00207>>04380000
DO'BLOCKDATA;                                                  <<00438>>04382000
DO'INTERRUPT;                                                  <<00438>>04384000
                                                               <<00207>>04386000
                                                               <<00207>>04388000
N'DL:=N'SAAD-%200;                                             <<00207>>04390000
N'ADL:=LOGICAL(N'SAI)-N'SAAD;                                  <<00207>>04392000
N'IL:=N'SAAI-N'SAI;                                            <<00207>>04394000
N'AIL:=N'FL-N'SAAI;                                            <<00207>>04396000
                                                               <<00207>>04398000
<<WRITE OUT NEW RECORD ZERO>>                                  <<00207>>04400000
FWRITEDIR(NEWUSL,DIRECTORYN,128,0D);                           <<00207>>04402000
IF <> THEN ERROR((IF < THEN ERR1 ELSE ERR0));                  <<00207>>04404000
                                                               <<00207>>04406000
<<FLUSH DIRECTORY BUFFER>>                                     <<00207>>04408000
FWRITEDIR(NEWUSL,DRT'BUF,128,DOUBLE(N'SAAD&ASR(7)));           <<00207>>04410000
IF <> THEN ERROR((IF < THEN ERR1 ELSE ERR0));                  <<00207>>04412000
                                                               <<00207>>04414000
<<FLUSH INFORMATION BUFFER>>                                   <<00207>>04416000
FWRITEDIR(NEWUSL,INFO'BUF,128,(N'SAAI&DASR(7)));               <<00207>>04418000
IF <> THEN ERROR((IF < THEN ERR1 ELSE ERR0));                  <<00207>>04420000
                                                               <<00207>>04422000
                                                               <<00207>>04424000
CONDCODE:=CCE;                                                 <<00207>>04426000
END;  <<PROCEDURE CLEANUSL>>                                   <<00207>>04428000
$PAGE "GENERAL-PURPOSE UTILITY PROCEDURES - NAMENUMCH"                  04430000
integer procedure NameNumCh(NameBlock);                                 04432000
                                                                        04434000
   byte array NameBlock;                                                04436000
                                                                        04438000
<<------------------------------------------------------------->>       04440000
<<                                                             >>       04442000
<< This procedure returns the number of characters in a name   >>       04444000
<< stored in a name block.                                     >>       04446000
<<                                                             >>       04448000
<<------------------------------------------------------------->>       04450000
<<                                                             >>       04452000
<< INPUT:                                                      >>       04454000
<<                                                             >>       04456000
<<    NameBlock - This is the name block containing the sym-   >>       04458000
<<       bolic name whose length is to be returned.            >>       04460000
<<                                                             >>       04462000
<< PROCEDURE VALUE:                                            >>       04464000
<<                                                             >>       04466000
<<    The number of characters in the symbolic name in the     >>       04468000
<<    name block is returned.                                  >>       04470000
<<                                                             >>       04472000
<<------------------------------------------------------------->>       04474000
                                                                        04476000
begin << NameNumCh >>                                                   04478000
                                                                        04480000
equate NULL'BLANK = %40;                                                04482000
                                                                        04484000
<< NameNumCh >>                                                         04486000
                                                                        04488000
   if NameBlock.(12:4) <> 0 then                                        04490000
      NameNumCh := NameBlock.(12:4)                                     04492000
   else                                                                 04494000
      begin                                                             04496000
      scan NameBlock(1) until NULL'BLANK, 1;                            04498000
      NameNumCh := tos - @NameBlock(1);                                 04500000
      end;                                                              04502000
                                                                        04504000
end; << NameNumCh >>                                                    04506000
$PAGE "GENERAL-PURPOSE UTILITY PROCEDURES - NAMESMATCH"                 04508000
logical procedure NamesMatch(NameBlock1, NameBlock2);                   04510000
                                                                        04512000
   byte array NameBlock1;                                               04514000
   byte array NameBlock2;                                               04516000
                                                                        04518000
<<------------------------------------------------------------->>       04520000
<<                                                             >>       04522000
<< This procedure compares the strings in two name blocks for  >>       04524000
<< equality.                                                   >>       04526000
<<                                                             >>       04528000
<<------------------------------------------------------------->>       04530000
<<                                                             >>       04532000
<< INPUT:                                                      >>       04534000
<<                                                             >>       04536000
<<    NameBlock1 - This is a name block containing the first   >>       04538000
<<       symbolic name to be compared.                         >>       04540000
<<                                                             >>       04542000
<<    NameBlock2 - This is a name block containing the second  >>       04544000
<<       symbolic name to be compared.                         >>       04546000
<<                                                             >>       04548000
<< PROCEDURE VALUE:                                            >>       04550000
<<                                                             >>       04552000
<<    If the symbolic names are equal, TRUE is returned;       >>       04554000
<<    otherwise, FALSE is returned.                            >>       04556000
<<                                                             >>       04558000
<<------------------------------------------------------------->>       04560000
                                                                        04562000
begin << NamesMatch >>                                                  04564000
                                                                        04566000
integer Len1;                                                           04568000
integer Len2;                                                           04570000
                                                                        04572000
<< NamesMatch >>                                                        04574000
                                                                        04576000
   Len1 := NameNumCh(NameBlock1);                                       04578000
   Len2 := NameNumCh(NameBlock2);                                       04580000
   if Len1 = Len2 then                                                  04582000
      NamesMatch := (NameBlock1(1) = NameBlock2(1), (Len1))             04584000
   else                                                                 04586000
      NamesMatch := false;                                              04588000
                                                                        04590000
end; << NamesMatch >>                                                   04592000
$PAGE "GENERAL PURPOSE UTILITY PROCEDURE - BUILDNAMEBLOCK"              04594000
procedure BuildNameBlock(NameBlock, NameBlockLen,                       04596000
                         String, StringLen, Status);                    04598000
                                                                        04600000
   value NameBlockLen, StringLen;                                       04602000
   integer NameBlockLen, StringLen, Status;                             04604000
   byte array NameBlock, String;                                        04606000
   option variable;                                                     04608000
                                                                        04610000
<< This procedure format String into NameBlock        >>                04612000
<<    NameBlockLen specifies the length of NameBlock  >>                04614000
<<    to be returned.                                 >>                04616000
<<    StringLen specifies the length of String to be  >>                04618000
<<    formated, if not specified then String is ter-  >>                04620000
<<    minated by a blank.                             >>                04622000
<<    Status returned :                               >>                04624000
<<      = 0   formated Ok                             >>                04626000
<<      = 101 name truncated because StringLen        >>                04628000
<<            specified smaller than the length of    >>                04630000
<<            String                                  >>                04632000
<<      = 102 name truncated because NameBlockLen     >>                04634000
<<            specified too small                     >>                04636000
<<      = 103 illegal parameters, only StringLen is   >>                04638000
<<            optional                                >>                04640000
begin                                                                   04642000
   integer NumCh;  << Number of characters to be moved >>               04644000
   logical Parms = Q-4;                                                 04646000
   logical ParmsMap := %(2)11101;                                       04648000
                                                                        04650000
   if (Parms LAND ParmsMap) <> ParmsMap then                            04652000
      begin                                                             04654000
         Status:=103;                                                   04656000
         return;                                                        04658000
      end;                                                              04660000
   Status:=0;                                                           04662000
   NumCh:=0;                                                            04664000
   if Parms.(14:1) = 0 then                                             04666000
      Stringlen:=%77777;                                                04668000
   while NumCh < StringLen and String(NumCh) <> " " do                  04670000
      NumCh:=NumCh+1;                                                   04672000
   if NumCh = Stringlen and not (String(NumCh) = " ")                   04674000
      then Status:=101;                                                 04676000
   if NumCh > 15 and NumCh > NameBlockLen-2 then                        04678000
      begin                                                             04680000
         NumCh := NameBlockLen - 2;                                     04682000
         Status:=102;                                                   04684000
      end;                                                              04686000
   if NumCh <= 15 and NumCh > NameBlockLen-1 then                       04688000
      Begin                                                             04690000
         NumCh := NameBlockLen - 1;                                     04692000
         Status:=102;                                                   04694000
      end;                                                              04696000
   if Numch <= 15 then                                                  04698000
      NameBlock := NumCh                                                04700000
   else                                                                 04702000
      move NameBlock(NumCh+1) := " ";                                   04704000
   move NameBlock(1):=String,(NumCh);                                   04706000
end;                                                                    04708000
$PAGE "FEOF"                                                            04710000
integer procedure FEOF(FNum);                                           04712000
value FNum;                                                             04714000
integer FNum;                                                           04716000
begin                                                                   04718000
   tos:=0D;                                                             04720000
   FGetInfo(FNum,,,,,,,,,,DS1);                                         04722000
   FEOF:=tos;                                                           04724000
end;                                                                    04726000
$PAGE "GENERAL PURPOSE UTILITY PROCEDURES - FREADMR"                    04728000
procedure FReadMR(FNum,Target,Count,RecNum,Status);                     04730000
                                                                        04732000
value FNUM,Count,RecNum;                                                04734000
integer FNum,Count,RecNum,Status;                                       04736000
integer array Target;                                                   04738000
                                                                        04740000
begin                                                                   04742000
   FReadDir(Fnum,Target,Count,Double(RecNum));                          04744000
   if > then                                                            04746000
      begin                                                             04748000
         Count := (FEOF(Fnum)-RecNum)&lsl(7);                           04750000
         FReadDir(FNum,Target,Count,double(RecNum));                    04752000
      end;                                                              04754000
   CHECKIPMAPIO;                                                        04756000
end;                                                                    04758000
$PAGE "GENERAL PURPOES UTILITY PROCEDURE - FWRITEMR"                    04760000
procedure FWriteMR(FNum,Target,Count,RecNum,Status);                    04762000
                                                                        04764000
value FNUM,Count,RecNum;                                                04766000
integer FNum,Count,RecNum,Status;                                       04768000
integer array Target;                                                   04770000
                                                                        04772000
begin                                                                   04774000
   FWriteDir(Fnum,Target,Count,Double(RecNum));                         04776000
   if > then                                                            04778000
      begin                                                             04780000
         Count := (FEOF(Fnum)-RecNum)&lsl(7);                           04782000
         FWriteDir(FNum,Target,Count,double(RecNum));                   04784000
      end;                                                              04786000
   CHECKIPMAPIO;                                                        04788000
end;                                                                    04790000
$PAGE "GENERAL-PURPOSE UTILITY PROCEDURES - HASH"                       04792000
integer procedure Hash(SymName, SymNameLen);                            04794000
                                                                        04796000
   value SymNameLen;                                                    04798000
                                                                        04800000
   byte    array SymName;         << Symbolic name to hash >>           04802000
   integer       SymNameLen;      << Length of symbolic name >>         04804000
                                                                        04806000
   option internal;                                                     04808000
                                                                        04810000
<<------------------------------------------------------------->>       04812000
<<                                                             >>       04814000
<< This function returns the value of the Segmenter hash func- >>       04816000
<< tion as applied to the symbolic name 'SymName'.  The length >>       04818000
<< of the name as passed in 'SymNameLen' is assumed to be cor- >>       04820000
<< rect, and the name itself is assumed to be valid.           >>       04822000
<<                                                             >>       04824000
<< INPUT:                                                      >>       04826000
<<                                                             >>       04828000
<<    SymName - This is a byte array containing the symbolic   >>       04830000
<<       name to be hashed.  The first byte in this array is   >>       04832000
<<       assumed to be the first character of the name (and    >>       04834000
<<       NOT the "length byte," as in some implementations),   >>       04836000
<<       and the name itself is assumed to be valid (no spe-   >>       04838000
<<       cial characters, 1st character alphabetic).  Upper/   >>       04840000
<<       lower-case is not significant.                        >>       04842000
<<                                                             >>       04844000
<<    SymNameLen - This is the number of characters in the     >>       04846000
<<       symbolic name.  It is assumed to be in the range      >>       04848000
<<       [1, 15].                                              >>       04850000
<<                                                             >>       04852000
<< PROCEDURE VALUE:                                            >>       04854000
<<                                                             >>       04856000
<<    The value of the hash function is returned.  It will be  >>       04858000
<<    in the range [0, 94].                                    >>       04860000
<<                                                             >>       04862000
<<------------------------------------------------------------->>       04864000
<<                                                             >>       04866000
<< ALGORITHM:                                                  >>       04868000
<<                                                             >>       04870000
<< First, a doubleword integer is constructed from 4 bytes as  >>       04872000
<< follows:                                                    >>       04874000
<<                                                             >>       04876000
<<    Byte 0 - Binary number of characters in the name.        >>       04878000
<<    Byte 1 - First character of the name.                    >>       04880000
<<    Byte 2 - Second-to-last character of the name.           >>       04882000
<<    Byte 3 - Last character of the name.                     >>       04884000
<<                                                             >>       04886000
<< For one-word names, bytes 2 and 3 will be the same as bytes >>       04888000
<< 0 and 1.                                                    >>       04890000
<<                                                             >>       04892000
<< Next, the doubleword is treated as a binary integer (always >>       04894000
<< positive due to the maximum name length), and the value of  >>       04896000
<< the hash function is this number modulo 95.                 >>       04898000
<<                                                             >>       04900000
<<------------------------------------------------------------->>       04902000
$PAGE                                                                   04904000
begin << Hash >>                                                        04906000
                                                                        04908000
double  FoldedName;               << Folded name >>                     04910000
logical Word0 = FoldedName;       << Word 0 of the coded name >>        04912000
logical Word1 = FoldedName + 1;   << Word 1 of the coded name >>        04914000
                                                                        04916000
<<------------------------------------------------------------->>       04918000
                                                                        04920000
<< Hash >>                                                              04922000
                                                                        04924000
   Word0 := logical(SymNameLen) & lsl(8) lor                            04926000
            logical(integer(SymName));                                  04928000
   if SymNameLen = 1 then                                               04930000
      Word1 := Word0                                                    04932000
   else                                                                 04934000
      Word1 := logical(integer(SymName(SymNameLen - 2))) &              04936000
               lsl(8) lor                                               04938000
               logical(integer(SymName(SymNameLen - 1)));               04940000
   TurnOffTraps;                                                        04942000
   Hash := FoldedName modd 95;                                          04944000
                                                                        04946000
end; << Hash >>                                                         04948000
$PAGE "GENERAL-PURPOSE UTILITY PROCEDURES - GETDRECOFFSET"              04950000
procedure GetDRecOffset(WordAddr, DRecNum, DRecOffset);                 04952000
                                                                        04954000
   value WordAddr;                                                      04956000
                                                                        04958000
   double  WordAddr;              << File address to convert >>         04960000
   integer DRecNum;               << Disc file record number >>         04962000
   integer DRecOffset;            << Disc record word offset >>         04964000
                                                                        04966000
   option internal;                                                     04968000
                                                                        04970000
<<------------------------------------------------------------->>       04972000
<<                                                             >>       04974000
<< This procedure converts word addresses for disc files       >>       04976000
<< treated as word streams into a disc record number and word  >>       04978000
<< offset.                                                     >>       04980000
<<                                                             >>       04982000
<<------------------------------------------------------------->>       04984000
<<                                                             >>       04986000
<< INPUT:                                                      >>       04988000
<<                                                             >>       04990000
<<    WordAddr - This is the disc file word address to be con- >>       04992000
<<       verted.                                               >>       04994000
<<                                                             >>       04996000
<< OUTPUT:                                                     >>       04998000
<<                                                             >>       05000000
<<    DRecNum - This is the number of the disc file record     >>       05002000
<<       containing the word addressed by WordAddr.            >>       05004000
<<                                                             >>       05006000
<<    DRecOffset - This is the word offset in record DRecNum   >>       05008000
<<       to the word addressed by WordAddr.                    >>       05010000
<<                                                             >>       05012000
<<------------------------------------------------------------->>       05014000
                                                                        05016000
begin << GetDRecOffset >>                                               05018000
                                                                        05020000
   DRecNum    := WordAddr // DRECNUMWDS;                                05022000
   DRecOffset := WordAddr modd DRECNUMWDS;                              05024000
                                                                        05026000
end; << GetDRecOffset >>                                                05028000
$PAGE "GENERAL-PURPOSE UTILITY PROCEDURES - MAPSLDIRENT"                05030000
procedure MapSLDirEnt(SLDirEntry, SLDirEntP, SLDirEntBP,                05032000
                      SLDirEntP1,Len);                                  05034000
                                                                        05036000
   integer array   SLDirEntry;    << Entry to be mapped >>              05038000
   integer pointer SLDirEntP;     << 1st word of directory ent >>       05040000
   byte pointer    SLDirEntBP;                                          05042000
   integer pointer SLDirEntP1;    << 1st word after name >>             05044000
   integer         Len;           << Length of entry returned >>        05046000
                                                                        05048000
   option internal;                                                     05050000
                                                                        05052000
<<------------------------------------------------------------->>       05054000
<<                                                             >>       05056000
<< This procedure initializes the pointers required to sym-    >>       05058000
<< bolically access fields in a particular SL entry point      >>       05060000
<< directory entry, and also returns the length of the entry.  >>       05062000
<< See the field definitions for the SL file entry point       >>       05064000
<< directory entry in the global declarations for complete     >>       05066000
<< details on the use of these pointers.                       >>       05068000
<<                                                             >>       05070000
<<------------------------------------------------------------->>       05072000
<<                                                             >>       05074000
<< INPUT:                                                      >>       05076000
<<                                                             >>       05078000
<<    SLDirEntry - This is an integer array containing the     >>       05080000
<<       directory entry to be mapped.  The entry is assumed   >>       05082000
<<       to begin at the first word of the array.              >>       05084000
<<                                                             >>       05086000
<< OUTPUT:                                                     >>       05088000
<<                                                             >>       05090000
<<    SLDirEntP - This is an integer pointer to the first word >>       05092000
<<       of the directory entry.                               >>       05094000
<<                                                             >>       05096000
<<    SLDirEntP1 - This is an integer pointer to the first     >>       05098000
<<       word after the name field in the directory entry.     >>       05100000
<<                                                             >>       05102000
<<    Len - This is the number of words used by the directory  >>       05104000
<<       entry.                                                >>       05106000
<<                                                             >>       05108000
<<------------------------------------------------------------->>       05110000
$PAGE                                                                   05112000
begin << MapSLDirEnt >>                                                 05114000
                                                                        05116000
integer pointer ParmDesc;         << Directory entry parm desc >>       05118000
byte array SLDirEntryB(*)=SLDirEntry;                                   05120000
                                                                        05122000
<< MapSLDirEnt >>                                                       05124000
                                                                        05126000
   << Load the pointers. >>                                             05128000
                                                                        05130000
   @SLDirEntP  := @SLDirEntry;                                          05132000
   @SLDirEntBP := @SLDirEntry & lsl(1);                                 05134000
   @SLDirEntP1 := @SLDirEntP + NameNumCh(SLDirEntryB) / 2 + 1;          05136000
                                                                        05138000
   << Calculate the entry length. >>                                    05140000
                                                                        05142000
   @ParmDesc := @SLDirEnt'ParmDesc;                                     05144000
   case ParmDesc(PDA'CheckLevel) of                                     05146000
      begin                                                             05148000
      << 0 >> Len := @SLDirEntP1 - @SLDirEntP + 2;                      05150000
      << 1 >> Len := @SLDirEntP1 - @SLDirEntP + 3;                      05152000
      << 2 >> Len := @SLDirEntP1 - @SLDirEntP + 3;                      05154000
      << 3 >> Len := @SLDirEntP1 - @SLDirEntP + 3 +                     05156000
                     ParmDesc(PDA'NumParms);                            05158000
      end;                                                              05160000
                                                                        05162000
end; << MapSLDirEnt >>                                                  05164000
$PAGE "SL FILE UTILITY PROCEDURES - MAPSLREFENT"                        05166000
procedure MapSLRefEnt(SLRefEntry, SLRefP, SLRefBP);                     05168000
   integer array   SLRefEntry;    << Entry to be mapped >>              05170000
   integer pointer SLRefP;        << 1st word of entry >>               05172000
   byte    pointer SLRefBP;       << 1st byte of entry >>               05174000
                                                                        05176000
   option internal;                                                     05178000
                                                                        05180000
<<------------------------------------------------------------->>       05182000
<<                                                             >>       05184000
<< This procedure initializes the pointers required to symbol- >>       05186000
<< ically access fields in a particular SL segment reference   >>       05188000
<< table entry.  See the field definitions for SL files in the >>       05190000
<< global declarations for details on the use of these point-  >>       05192000
<< ers.                                                        >>       05194000
<<                                                             >>       05196000
<<------------------------------------------------------------->>       05198000
<<                                                             >>       05200000
<< INPUT:                                                      >>       05202000
<<                                                             >>       05204000
<<    SLRefEntry - This is an integer array containing the SL  >>       05206000
<<       reference table entry to be mapped.  Note that this   >>       05208000
<<       is assumed to be the first word of the entry, not the >>       05210000
<<       block containing the entry.                           >>       05212000
<<                                                             >>       05214000
<< OUTPUT:                                                     >>       05216000
<<                                                             >>       05218000
<<    SLRefEntP - This is an integer pointer to the first word >>       05220000
<<       of the reference table entry.                         >>       05222000
<<                                                             >>       05224000
<<    SLRefEntBP - This is a byte pointer to the first byte of >>       05226000
<<       the reference table entry.                            >>       05228000
<<                                                             >>       05230000
<<------------------------------------------------------------->>       05232000
                                                                        05234000
begin << MapSLRefEnt >>                                                 05236000
                                                                        05238000
<< MapSLRefEnt >>                                                       05240000
                                                                        05242000
   @SLRefP  := @SLRefEntry;                                             05244000
   @SLRefBP := @SLRefEntry & lsl(1);                                    05246000
                                                                        05248000
end; << MapSLRefEnt >>                                                  05250000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            05252000
$     "LOADIPMAPBUF"                                                    05254000
procedure LoadIPmapBuf(DRecNum, Offset, PmapCB, Status);                05256000
                                                                        05258000
   value DRecNum, Offset;                                               05260000
   integer       DRecNum;         << Record part of address >>          05262000
   integer       Offset;          << Word part of address >>            05264000
   integer array PmapCB;          << PMAP control block >>              05266000
   integer       Status;          << Status code returned >>            05268000
                                                                        05270000
   option internal;                                                     05272000
                                                                        05274000
<<------------------------------------------------------------->>       05276000
<<                                                             >>       05278000
<< This procedure loads PmapBuf with records DRecNum and       >>       05280000
<< DRecNum+1 and set PmapBufX to OffSet                        >>       05282000
<<                                                             >>       05284000
<<------------------------------------------------------------->>       05286000
<<                                                             >>       05288000
<< INPUT:                                                      >>       05290000
<<                                                             >>       05292000
<<    DRecNum - This is the number of the disc record from     >>       05294000
<<       which the address of the desired word(s) is to be     >>       05296000
<<       calculated.                                           >>       05298000
<<                                                             >>       05300000
<<    Offset - This is the offset from the specified disc rec- >>       05302000
<<       ord number to be used to calculate the address of the >>       05304000
<<       desired word(s).                                      >>       05306000
<<                                                             >>       05308000
<<    PmapCB - This is the PMAP control block as described in  >>       05310000
<<       the global declarations.  It must be initialized to   >>       05312000
<<       the extent that status of its PMAP buffer is correct- >>       05314000
<<       ly represented.                                       >>       05316000
<<                                                             >>       05318000
<< OUTPUT:                                                     >>       05320000
<<                                                             >>       05322000
<<    PmapCB - The PMAP control block is returned with the     >>       05324000
<<       quested words present in its internal PMAP buffer.    >>       05326000
<<                                                             >>       05328000
<<    Status - A status code indicating any file system errors >>       05330000
<<       on the program/SL file containing the PMAP is re-     >>       05332000
<<       turned.                                               >>       05334000
<<                                                             >>       05336000
<<------------------------------------------------------------->>       05338000
                                                                        05340000
begin << LoadIPmapBuf >>                                                05342000
   PMAPCBDEC;                                                           05344000
   FReadMR(IPmapFNum,PmapBuf,DRECNUMWDS*2,DRecNum,Status);              05346000
   if Status = STAT'IPMAPIOERR then return;                             05348000
   if IPMAPFILECODE = SLFILECODE then                                   05350000
      begin                                                             05352000
         move TypeTable := PmapBuf,(PmapBuf);                           05354000
         PmapBufX:=TypeTableLen;                                        05356000
      end                                                               05358000
   else                                                                 05360000
      PmapBufX:=OffSet;                                                 05362000
   PmapCurDRecNum:=DRecNum;                                             05364000
end; << LoadIPmapBuf >>                                                 05366000
$PAGE "GENERAL-PURPOSE UTILITY PROCEDURES - MAPIPMAPREC"                05368000
procedure MapIPmapRec(Buffer,IPmapP,IPmapBP,IPmapP1,Len,PmapCB);        05370000
                                                                        05372000
   integer array   Buffer;        << Int PMAP Rec to be mapped >>       05374000
   integer array PmapCB;                                                05376000
   integer pointer IPmapP;        << 1st word of int PMAP rec >>        05378000
   byte    pointer IPmapBP;       << 1st byte of int PMAP rec >>        05380000
   integer pointer IPmapP1;       << 1st word after name >>             05382000
   integer         Len;           << # words in PMAP record >>          05384000
                                                                        05386000
   option internal;                                                     05388000
                                                                        05390000
<<------------------------------------------------------------->>       05392000
<<                                                             >>       05394000
<< This procedure initializes the pointers required to sym-    >>       05396000
<< bolically access fields in a particular internal PMAP rec-  >>       05398000
<< ord, and also returns the length of the record.  See the    >>       05400000
<< field definitions for the internal PMAP record in the glo-  >>       05402000
<< bal declarations for complete details on the use of these   >>       05404000
<< pointers.                                                   >>       05406000
<<                                                             >>       05408000
<< INPUT:                                                      >>       05410000
<<                                                             >>       05412000
<<    Buffer - This is an integer array containing the inter-  >>       05414000
<<       nal PMAP record to be mapped.  The record is assumed  >>       05416000
<<       to begin at the first word of the array.              >>       05418000
<<                                                             >>       05420000
<< OUTPUT:                                                     >>       05422000
<<                                                             >>       05424000
<<    IPmapP - This is an integer pointer to the first word of >>       05426000
<<       the internal PMAP record.                             >>       05428000
<<                                                             >>       05430000
<<    IPmapBP - This is a byte pointer to the first byte of    >>       05432000
<<       the internal PMAP record.                             >>       05434000
<<                                                             >>       05436000
<<    IPmapP1 - This is an integer pointer to the first word   >>       05438000
<<       after the name field in the internal PMAP record.     >>       05440000
<<                                                             >>       05442000
<<    Len - This is the number of words used by the internal   >>       05444000
<<       PMAP record.                                          >>       05446000
<<                                                             >>       05448000
<<------------------------------------------------------------->>       05450000
                                                                        05452000
begin << MapIPmapRec >>                                                 05454000
PMAPCBDEC;                                                              05456000
                                                                        05458000
$PAGE                                                                   05460000
<< MapIPmapRec >>                                                       05462000
                                                                        05464000
   @IPmapP  := @Buffer;                                                 05466000
   @IPmapBP := @IPmapP & lsl(1);                                        05468000
   @IPmapP1 := @IPmapP + IPmap'NameNumCh & lsr(1) + 1;                  05470000
   Len      := @IPmapP1 - @IPmapP + TypeTable(IPmap'Type+1);            05472000
                                                                        05474000
end; << MapIPmapRec >>                                                  05476000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            05478000
$     "PMAPCBINIT"                                                      05480000
procedure PmapCBInit(ProgFile, PmapCB, Status);                         05482000
                                                                        05484000
   value ProgFile;                                                      05486000
                                                                        05488000
   integer       Progfile;        << Program/SL file number >>          05490000
   integer array PmapCB;          << PMAP Control Block >>              05492000
   integer       Status;          << Status returned >>                 05494000
                                                                        05496000
                                                                        05500000
<<------------------------------------------------------------->>       05502000
<<                                                             >>       05504000
<< This procedure first verifies that a program/SL file which  >>       05506000
<< was passed to one of the PMAP intrinsics has a valid file   >>       05508000
<< code and is compatible with this version of the PMAP        >>       05510000
<< intrinsics.  Then the PMAP control block PmapCB is par-     >>       05512000
<< tially intialized with data from the beginning of the file. >>       05514000
<<                                                             >>       05516000
<< Upon return, the caller must complete initialization of the >>       05518000
<< PMAP Control Block by calling one of the support procedures >>       05520000
<< which sts the PMAP pointers to a specified segment record.  >>       05522000
<<                                                             >>       05524000
<< INPUT:                                                      >>       05526000
<<                                                             >>       05528000
<<    ProgFile - This is the number of the program/SL file     >>       05530000
<<       passed to one of the PMAP intrinsics.                 >>       05532000
<<                                                             >>       05534000
<< OUTPUT:                                                     >>       05536000
<<                                                             >>       05538000
<<    PmapCB - This is the PMAP control block as described in  >>       05540000
<<       the global declarations.  It will be returned par-    >>       05542000
<<       tially initialized.                                   >>       05544000
<<                                                             >>       05546000
<<    Status - This is a status code indicating any errors de- >>       05548000
<<       tected as follows:                                    >>       05550000
<<                                                             >>       05552000
<<       OK:            No errors.                             >>       05554000
<<       BADFILECODE:   The file code of ProgFile is not that  >>       05556000
<<                      of a program or SL file.               >>       05558000
<<       NOPMAP:        ProgFile does not contain a PMAP.      >>       05560000
<<       BADLOADERID:   The loader ID in SL file ProgFile is   >>       05562000
<<                      not compatible with this version of    >>       05564000
<<                      of the PMAP intrinsics.                >>       05566000
<<                                                             >>       05568000
<<------------------------------------------------------------->>       05570000
$PAGE                                                                   05572000
begin << PmapCBInit >>                                                  05574000
                                                                        05576000
<< The following declarations provide access to the PMAP con-  >>       05578000
<< trol block:                                                 >>       05580000
                                                                        05582000
PMAPCBDEC;                   << PMAP Control Block arrays >>            05584000
                                                                        05586000
<< Miscellaneous declarations: >>                                       05588000
                                                                        05590000
logical AOptions;                 << PMAP file AOptions >>              05592000
define                                                                  05594000
   MultiRec = (11:1)#;                                                  05596000
$PAGE                                                                   05598000
<< PmapCBInit >>                                                        05600000
                                                                        05602000
   << Check the file code and AOptions. >>                              05604000
                                                                        05606000
   FGetInfo(ProgFile,,, AOptions,,,,, IPmapFileCode);                   05608000
   CHECKIPMAPIO;                                                        05610000
   if IPmapFileCode <> PROGFILECODE and                                 05612000
      IPmapFileCode <> SLFILECODE then                                  05614000
      begin                                                             05616000
      Status := STAT'BADFILECODE;                                       05618000
      return;                                                           05620000
      end;                                                              05622000
                                                                        05624000
   if not AOptions.MultiRec then                                        05626000
      begin                                                             05628000
      Status := STAT'IPMAPBADFOPEN;                                     05630000
      return;                                                           05632000
      end;                                                              05634000
                                                                        05636000
   << Miscellaneous PMAP Control Block initialization: >>               05638000
                                                                        05640000
   IPmapFNum := ProgFile;                                               05642000
   PmapFlags := 0;                << Means PMAP pointer is at  >>       05644000
                                  <<   last internal PMAP rec- >>       05646000
                                  <<   ord returned, and end-  >>       05648000
                                  <<   of-PMAP condition is    >>       05650000
                                  <<   cleared.                >>       05652000
   PmapCurSegNum := -1;           << Means initialization is   >>       05654000
                                  <<   not complete.           >>       05656000
                                                                        05658000
   << Fetch info from the program/SL file header records: >>            05660000
                                                                        05662000
   if IPmapFileCode = PROGFILECODE then                                 05664000
                                                                        05666000
      begin << Process program file header records. >>                  05668000
                                                                        05670000
      << Read info block from record 0. >>                              05672000
                                                                        05674000
      FReadDir(ProgFile, PF0P, PF0'INFONUMWDS, 0D);                     05676000
      CHECKIPMAPIO;                                                     05678000
                                                                        05680000
      << Check for presence of PMAP in program file. >>                 05682000
                                                                        05684000
      if not Pf0'Zeroed or Pf0'PmapDRecNum = 0 then                     05686000
         begin                                                          05688000
         Status := STAT'NOPMAP;                                         05690000
         return;                                                        05692000
         end;                                                           05694000
                                                                        05696000
      FReadMR(IPmapFNum,ProgPmapPtrsI,256+MAXTYPETABLELEN,              05698000
              Pf0'PmapDRecNum,Status);                                  05700000
      if Status= STAT'IPMAPIOERR then return;                           05702000
      move TypeTable := ProgPmapPtrsI,(ProgPmapPtrsI);                  05704000
      if Pf0'NumSegs > 128 then                                         05706000
         move ProgPmapPtrsI := ProgPmapPtrsI(TypeTableLen),             05708000
                               (256)                                    05710000
      else                                                              05712000
         move ProgPmapPtrsI := ProgPmapPtrsI(typetablelen),             05714000
                               (Pf0'NumSegs*2);                         05716000
      FirstHalfSegPtrLoaded := true;                                    05718000
                                                                        05720000
      end << Process program file header records. >>                    05722000
$PAGE                                                                   05724000
   else                                                                 05726000
      begin << Process SL file header records. >>                       05728000
                                                                        05730000
      << Read records 0 and 1. >>                                       05732000
                                                                        05734000
      FReadMr(ProgFile, SL0P, DRECNUMWDS + MAXNUMSLREFBLOCKS,           05736000
               0,Status);                                               05738000
      if Status = STAT'IPMAPIOERR then return;                          05740000
                                                                        05742000
      << Check the SL's format ID. >>                                   05744000
                                                                        05746000
      if SL0'FormatId > LASTSLFORMATID then                             05748000
         begin                                                          05750000
         Status := STAT'BADLOADERID;                                    05752000
         return;                                                        05754000
         end;                                                           05756000
                                                                        05758000
      end; << Process SL file records 0/1. >>                           05760000
                                                                        05762000
   Status := STAT'OK;                                                   05764000
                                                                        05766000
end; << PmapCBInit >>                                                   05768000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            05770000
$     "LOADSLREFENT"                                                    05772000
procedure LoadSLRefEnt(ReqSegNum, SLRefP, SLRefBP, PmapCB,              05774000
                       Status);                                         05776000
                                                                        05778000
   value ReqSegNum;                                                     05780000
                                                                        05782000
   integer         ReqSegNum;     << Requested segment number >>        05784000
   integer pointer SLRefP;        << 1st word of req entry >>           05786000
   byte    pointer SLRefBP;       << 1st byte of req entry >>           05788000
   integer array   PmapCB;        << PMAP control block >>              05790000
   integer         Status;        << Status code returned >>            05792000
                                                                        05794000
   option internal;                                                     05796000
                                                                        05798000
<<------------------------------------------------------------->>       05800000
<<                                                             >>       05802000
<< This procedure loads the SLRefBlock buffer in the PMAP con- >>       05804000
<< trol block with the SL segment reference table block con-   >>       05806000
<< taining a specified reference table entry, and returns word >>       05808000
<< and byte pointers to the entry.                             >>       05810000
<<                                                             >>       05812000
<< The variable PmapCurSegNum in the PMAP control block is     >>       05814000
<< used to determine if the needed block is already loaded,    >>       05816000
<< thus avoiding unnecessary disc reads.  It is updated by     >>       05818000
<< this routine, and upon entry its contents are assumed to    >>       05820000
<< accurately reflect the contents of SLRefBlock.              >>       05822000
<<                                                             >>       05824000
<< INPUT:                                                      >>       05826000
<<                                                             >>       05828000
<<    ReqSegNum - This is an integer specifying the number of  >>       05830000
<<       the requested segment.  It is assumed to be in the    >>       05832000
<<       range [0, PmapNumSegs - 1].                           >>       05834000
<<                                                             >>       05836000
<<    PmapCB - This is the PMAP control block as described in  >>       05838000
<<       the global declarations.  Prior to the first call to  >>       05840000
<<       this routine it must have been partially initialized  >>       05842000
<<       by PmapCBInit.                                        >>       05844000
<<                                                             >>       05846000
<< OUTPUT:                                                     >>       05848000
<<                                                             >>       05850000
<<    SLRefP - This is an integer pointer to the first word of >>       05852000
<<       the requested segment reference table entry.          >>       05854000
<<                                                             >>       05856000
<<    SLRefBP - This is a byte pointer to the first byte of    >>       05858000
<<       the requested segment reference table entry.          >>       05860000
<<                                                             >>       05862000
<<    PmapCB - This is the PMAP control block as described in  >>       05864000
<<       the global declarations.  It will be returned updated >>       05866000
<<       as appropriate.                                       >>       05868000
<<                                                             >>       05870000
<<    Status - This is a standard PMAP intrinsic error code    >>       05872000
<<       returned to indicate detection of any abnormal con-   >>       05874000
<<       dition.  Any value other than 0 should be passed on   >>       05876000
<<       to the caller of the originating PMAP intrinsic.      >>       05878000
<<                                                             >>       05880000
<<------------------------------------------------------------->>       05882000
$PAGE                                                                   05884000
begin << LoadSLRefEnt >>                                                05886000
                                                                        05888000
<< The following declarations provide access to the PMAP Con-  >>       05890000
<< trol Block:                                                 >>       05892000
                                                                        05894000
PMAPCBDEC;                   << PMAP Control Block arrays >>            05896000
                                                                        05898000
<< Miscellaneous variables. >>                                          05900000
                                                                        05902000
integer ReqBlockNum;              << Seg ref tab block con-    >>       05904000
                                  <<   taining reqested seg.   >>       05906000
                                                                        05908000
<<------------------------------------------------------------->>       05910000
                                                                        05912000
<< LoadSLRefEnt >>                                                      05914000
                                                                        05916000
   ReqBlockNum := ReqSegNum / SLREFBLOCKFACT;                           05918000
   if not SLRefBlockLoaded or                                           05920000
      PmapCurSegNum / SLREFBLOCKFACT <> ReqBlockNum then                05922000
                                                                        05924000
      begin << Load the proper block. >>                                05926000
      FReadDir(IPmapFNum, SLRefBlock, SLREFBLOCKNUMWDS,                 05928000
               double(SLRefBlockDRecNum(ReqBlockNum)));                 05930000
      CHECKIPMAPIO;                                                     05932000
      SLRefBlockLoaded := true;                                         05934000
      end;                                                              05936000
                                                                        05938000
   PmapCurSegNum := ReqSegNum;                                          05940000
   MapSLRefEnt(SLRefBlock((PmapCurSegNum mod SLREFBLOCKFACT)*           05942000
                 SLREFENTNUMWDS),SLRefP,SLRefBP);                       05944000
   Status     := STAT'OK;                                               05946000
                                                                        05948000
end; << LoadSLRefEnt >>                                                 05950000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURE - ",&             05952000
$     "GETPMAPSEGPTR"                                                   05954000
procedure GetPmapSegPtr(PmapCB,ReqSegNum,RecNum,RecOffSet,Status);      05956000
value ReqSegNum;                                                        05958000
integer array PmapCB;                                                   05960000
integer ReqSegNum,RecOffSet,Status;                                     05962000
integer RecNum;                                                         05964000
                                                                        05966000
begin                                                                   05968000
   PMAPCBDEC;                                                           05970000
   if ReqSegNum > 128 then                                              05972000
      begin                                                             05974000
         if FirstHalfSegPtrLoaded then                                  05976000
            begin                                                       05978000
               FReadMR(IPmapfNum,ProgPmapPtrsI,Pf0'NumSegs*             05980000
                       2-256+TypeTableLen,Pf0'PmapDRecNum+2,            05982000
                       Status);                                         05984000
               if Status=STAT'IPMAPIOERR then return;                   05986000
               move ProgPmapPtrsI:=ProgPmapPtrsI(TypeTablelen)          05988000
                                   ,(256);                              05990000
               FirstHalfSegPtrLoaded:=false;                            05992000
             end;                                                       05994000
          ReqSegNum:=ReqSegNum-128;                                     05996000
       end                                                              05998000
   else                                                                 06000000
      begin                                                             06002000
         if not FirstHalfSegPtrLoaded then                              06004000
            begin                                                       06006000
               FReadMR(IPmapFNum,ProgPmapPtrsI,256+                     06008000
                       TypeTableLen,Pf0'PmapDRecNum,Status);            06010000
               if Status=STAT'IPMAPIOERR then return;                   06012000
               move ProgPmapPtrsI:=ProgPmapPtrsI(TypeTablelen)          06014000
                                   ,(256);                              06016000
               FirstHalfSegPtrLoaded:=true;                             06018000
            end;                                                        06020000
      end;                                                              06022000
   GetDRecOffSet(ProgPmapPtrs(ReqSegNum),RecNum,RecOffSet);             06024000
end;                                                                    06026000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            06028000
$     "PMAPFINDSEGNUM"                                                  06030000
procedure PmapFindSegNum(ReqSegNum, PmapCB, Status);                    06032000
                                                                        06034000
   value ReqSegNum;                                                     06036000
                                                                        06038000
   integer       ReqSegNum;       << Requested segment number >>        06040000
   integer array PmapCB;          << PMAP control block >>              06042000
   integer       Status;          << Status returned >>                 06044000
                                                                        06046000
                                                                        06050000
<<------------------------------------------------------------->>       06052000
<<                                                             >>       06054000
<< This procedure completes initialization of the data in the  >>       06056000
<< PMAP control block, causing the next internal PMAP record   >>       06058000
<< returned by GetIPmapRec to be that of a requested segment   >>       06060000
<< number or the first active segment in the PMAP file.  The   >>       06062000
<< procedure PmapCBInit must be called prior to calling this   >>       06064000
<< one.                                                        >>       06066000
<<                                                             >>       06068000
<< INPUT:                                                      >>       06070000
<<                                                             >>       06072000
<<    ReqSegNum - This is the number of the segment whose      >>       06074000
<<       Internal PMAP Record is to be returned by the next    >>       06076000
<<       call to GetIPmapRec.  A value of -1 is a request for  >>       06078000
<<       the first active segment in an SL file, or for seg-   >>       06080000
<<       ment 0 in a program file.                             >>       06082000
<<                                                             >>       06084000
<<       If an inactive or illegal segment number is given, an >>       06086000
<<       error status will be returned.  If -1 is passed as a  >>       06088000
<<       segment number and the program or SL file is empty or >>       06090000
<<       has no active segments, the end-of-PMAP flag in the   >>       06092000
<<       PMAP control block will be set and a status of OK     >>       06094000
<<       will be returned.                                     >>       06096000
<<                                                             >>       06098000
<<    PmapCB - This is the PMAP control block as described in  >>       06100000
<<       the global declarations.  Prior to the first call to  >>       06102000
<<       this routine it must have been partially initialized  >>       06104000
<<       by PmapCBInit.                                        >>       06106000
<<                                                             >>       06108000
<< OUTPUT:                                                     >>       06110000
<<                                                             >>       06112000
<<    PmapCB - This is the PMAP control block as described in  >>       06114000
<<       the global declarations.  It will be returned updated >>       06116000
<<       as appropriate.                                       >>       06118000
<<                                                             >>       06120000
<<    Status - This is a standard PMAP intrinsic error code    >>       06122000
<<       returned to indicate detection of any abnormal con-   >>       06124000
<<       dition.  Any value other than 0 should be passed on   >>       06126000
<<       to the caller of the originating PMAP intrinsic.      >>       06128000
<<                                                             >>       06130000
<<------------------------------------------------------------->>       06132000
$PAGE                                                                   06134000
begin << PmapFindSegNum >>                                              06136000
                                                                        06138000
<< The following declarations provide access to the PMAP Con-  >>       06140000
<< trol Block:                                                 >>       06142000
                                                                        06144000
PMAPCBDEC;                   << PMAP Control Block arrays >>            06146000
                                                                        06148000
<< The following pointers provide access to an SL segment ref- >>       06150000
<< erence table entry.                                         >>       06152000
                                                                        06154000
integer pointer SLRefP;                                                 06156000
logical pointer SLRefLP = SLRefP;                                       06158000
byte    pointer SLRefBP;                                                06160000
integer RecNum,RecOffSet;                                               06162000
                                                                        06164000
<< Miscellaneous declarations: >>                                       06166000
                                                                        06168000
                                                                        06170000
<<------------------------------------------------------------->>       06172000
                                                                        06174000
   PmapEnd := false;          << Reset flags for          >>            06176000
   SegPmapMaped := false;     << next call to GetIPmapRec >>            06178000
                                                                        06180000
<< PmapFindSegNum >>                                                    06182000
                                                                        06184000
   if IPmapFileCode = PROGFILECODE then                                 06186000
                                                                        06188000
      << Resolve the segment request to a specific segment     >>       06190000
      << number.                                               >>       06192000
                                                                        06194000
      begin                                                             06196000
      PmapCurSegNum := ReqSegNum;                                       06198000
                                                                        06200000
      << Make sure the specified segment exists. >>                     06202000
                                                                        06204000
      if not (0 <= PmapCurSegNum <= PF0'NumSegs - 1) then               06206000
         begin                                                          06208000
         Status := STAT'BADSEGID;                                       06210000
         return;                                                        06212000
         end;                                                           06214000
                                                                        06216000
      GetPmapSegPtr(PmapCB,ReqSegNum,RecNum,RecOffSet,Status);          06218000
      if Status=STAT'IPMAPIOERR then return;                            06220000
      LoadIPmapBuf (RecNum,RecOffSet,PmapCB,Status);                    06222000
      if Status=STAT'IPMAPIOERR then return;                            06224000
                                                                        06226000
      end                                                               06228000
$PAGE                                                                   06230000
   else << IPmapFileCode = SLFILECODE >>                                06232000
                                                                        06234000
      << First find the SL segment reference table entry for   >>       06236000
      << the requested segment.                                >>       06238000
                                                                        06240000
      begin                                                             06242000
                                                                        06244000
         if not (0 <= ReqSegNum <= SL0'NumSegsAlloc-1) then             06246000
            begin                                                       06248000
            Status := STAT'BADSEGID;                                    06250000
            return;                                                     06252000
            end;                                                        06254000
                                                                        06256000
         LoadSLRefEnt(ReqSegNum, SLRefP, SLRefBP, PmapCB,               06258000
                      Status);                                          06260000
         if Status <> STAT'OK then                                      06262000
            return;                                                     06264000
         if SLRef'Deleted then                                          06266000
            begin                                                       06268000
            Status := STAT'SEGDELETED;                                  06270000
            return;                                                     06272000
            end;                                                        06274000
         if SLRef'PmapDRecNum = 0 then                                  06276000
            begin                                                       06278000
               Status:=STAT'NOPMAP;                                     06280000
               return;                                                  06282000
            end;                                                        06284000
                                                                        06286000
      << Next, use the pointer in the SL reference table entry >>       06288000
      << to locate the segment's PMAP.                         >>       06290000
                                                                        06292000
         LoadIPmapBuf(SLRef'PmapDRecNum,0,PmapCB,                       06294000
                     Status);                                           06296000
         if Status <> STAT'OK then                                      06298000
            return;                                                     06300000
      end;                                                              06302000
$PAGE                                                                   06304000
   << If we got this far, the buffer was successfully loaded   >>       06306000
   << and is currently pointing at the requested PMAP segment  >>       06308000
   << record.  We indicate this in the PMAP control block and  >>       06310000
   << perform a normal return.                                 >>       06312000
                                                                        06314000
   PmapPreset := true;            << Means PMAP pointer is at  >>       06316000
                                  <<   next record to return.  >>       06318000
   Status     := STAT'OK;                                               06320000
                                                                        06322000
end; << PmapFindSegNum >>                                               06324000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            06326000
$     "PMAPFINDSEGNAME"                                                 06328000
procedure PmapFindSegName(ReqSegName, PmapCB, Status);                  06330000
   byte    array ReqSegName;      << Segment name to be found >>        06332000
   integer array PmapCB;          << PMAP Control Block >>              06334000
   integer       Status;          << Status code returned >>            06336000
                                                                        06338000
   option internal;                                                     06340000
                                                                        06342000
<< This procedure completes initialization of the data in the  >>       06344000
<< PMAP Control Block, causing the next internal PMAP record   >>       06346000
<< returned by 'GetIPmapRec' to be that of a requested segment >>       06348000
<< name.  The procedure 'PmapCBInit' must be called prior to   >>       06350000
<< calling this one.                                           >>       06352000
<<                                                             >>       06354000
<< INPUT:                                                      >>       06356000
<<                                                             >>       06358000
<<    ReqSegName - This is a 16-byte array containing the name >>       06360000
<<       of the segment to be found.  The name is assumed to   >>       06362000
<<       be valid, as well as left-justified with blank fill.  >>       06364000
<<                                                             >>       06366000
<<    PmapCB - This is the PMAP control block as described in  >>       06368000
<<       the global declarations.  Prior to the first call to  >>       06370000
<<       this routine it must have been partially initialized  >>       06372000
<<       by PmapCBInit.                                        >>       06374000
<<                                                             >>       06376000
<< OUTPUT:                                                     >>       06378000
<<                                                             >>       06380000
<<    PmapCB - This is the PMAP control block as described in  >>       06382000
<<       the global declarations.  It will be returned updated >>       06384000
<<       as appropriate.                                       >>       06386000
<<                                                             >>       06388000
<<    Status - This is a standard PMAP intrinsic error code    >>       06390000
<<       returned to indicate detection of any abnormal con-   >>       06392000
<<       dition.  Any value other than 0 should be passed on   >>       06394000
<<       to the caller of the originating PMAP intrinsic.      >>       06396000
<<                                                             >>       06398000
                                                                        06400000
begin << PmapFindSegName >>                                             06402000
                                                                        06404000
<< The following declarations provide access to the PMAP Con-  >>       06406000
<< trol Block:                                                 >>       06408000
PMAPCBDEC;                   << PMAP Control Block arrays >>            06410000
integer pointer SLRefP;           << Current Ref Table entry >>         06412000
logical pointer SLRefLP = SLRefP;                                       06414000
byte    pointer SLRefBP;                                                06416000
integer pointer IPmapP;           << Current Internal PMAP Rec >>       06418000
byte    pointer IPmapBP;                                                06420000
integer pointer IPmapP1;          << 1st word after name >>             06422000
                                                                        06424000
<< Miscellaneous variables: >>                                          06426000
integer Len;                      << Scratch length >>                  06428000
logical NameFound := false;       << True when seg name found >>        06430000
integer REcOffSet;                                                      06432000
logical RecNum;                                                         06434000
                                  <<   word in PMAP buffer.    >>       06436000
byte array ReqSegNameBlock(0:16);                                       06438000
byte array SLSegName (0:16);                                            06440000
$PAGE                                                                   06442000
<< PmapFindSegName >>                                                   06444000
                                                                        06446000
   BuildNameBlock(ReqSegNameBlock,17,ReqSegName,,Status);               06448000
   PmapCurSegNum := 0;                                                  06450000
   NameFound     := false;                                              06452000
   if IPmapFileCode = PROGFILECODE then                                 06454000
                                                                        06456000
      begin                                                             06458000
                                                                        06460000
      << Segment names in program files are found by looking   >>       06462000
      << up the internal PMAP segment records via the PMAP     >>       06464000
      << pointers.                                             >>       06466000
                                                                        06468000
      while not NameFound and PmapCurSegNum < PF0'NumSegs do            06470000
         begin                                                          06472000
                                                                        06474000
         << The PMAP segment pointers are fetched one record   >>       06476000
         << at a time; test to see if we need a new batch.     >>       06478000
                                                                        06480000
            GetPmapSegPtr(PmapCB,PmapCurSegNum,RecNum,                  06482000
                          RecOffSet,Status);                            06484000
            if Status = STAT'IPMAPIOERR then return;                    06486000
            LoadIPmapBuf(RecNum,RecOffSet,PmapCB,Status);               06488000
            if Status =STAT'IPMAPIOERR then return;                     06490000
            MapIPmapRec(PmapBuf(PmapBufX),IPmapP,IPmapBP,               06492000
                        IPmapP1,Len,PmapCB);                            06494000
            if NamesMatch(ReqSegNameBlock,IPmap'Name) then              06496000
               NameFound:=true                                          06498000
            else                                                        06500000
               PmapCurSegNum:=PmapCurSegNum+1;                          06502000
         end;                                                           06504000
      end                                                               06506000
$PAGE                                                                   06508000
   else << IPmapFileCode = SLFILECODE >>                                06510000
      begin                                                             06512000
      while not NameFound and PmapCurSegNum < SL0'NumSegsAlloc do       06514000
         begin                                                          06516000
         LoadSLRefEnt(PmapCurSegNum, SLRefP, SLRefBP, PmapCB,           06518000
                      Status);                                          06520000
         if Status = STAT'IPMAPIOERR then                               06522000
            return;                                                     06524000
         if not SLRef'Deleted then                                      06526000
            begin                                                       06528000
               BuildNameBlock(SLSegName,17,SLRef'SegName0,,             06530000
                              Status);                                  06532000
               if NamesMatch(SLSegName,ReqSegNameBlock) then            06534000
                  begin                                                 06536000
                  if SLRef'PmapDRecNum = 0 then                         06538000
                     begin                                              06540000
                        Status:=STAT'NOPMAP;                            06542000
                        return;                                         06544000
                     end;                                               06546000
                  NameFound:=true;                                      06548000
                  end                                                   06550000
               else                                                     06552000
                  PmapCurSegNum:=PmapCurSegNum+1;                       06554000
            end                                                         06556000
         else                                                           06558000
            PmapCurSegNum:=PmapCurSegNum+1;                             06560000
         end;                                                           06562000
      if NameFound then                                                 06564000
         begin                                                          06566000
            LoadIPmapBuf(SLRef'PmapDRecNum,0,                           06568000
                         PmapCB,Status);                                06570000
            if Status <> STAT'OK then return;                           06572000
         end;                                                           06574000
      end;                                                              06576000
                                                                        06578000
   if NameFound then                                                    06580000
      begin                                                             06582000
      PmapPreset := true;                                               06584000
      Status := STAT'OK;                                                06586000
      end                                                               06588000
   else                                                                 06590000
      Status := STAT'BADSEGID;                                          06592000
                                                                        06594000
end; << PmapFindSegName >>                                              06596000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            06598000
$     "FINDSLENTNAME"                                                   06600000
procedure PmapFindSLEntName(ReqEntName, PmapCB, Status);                06602000
   byte    array ReqEntName;      << Requested entry name >>            06604000
   integer array PmapCB;          << PMAP Control Block >>              06606000
   integer       Status;          << Status code returned >>            06608000
                                                                        06610000
   option internal;                                                     06612000
                                                                        06614000
<< This procedure completes initialization of the data in the  >>       06616000
<< PMAP Control Block, causing the next internal PMAP record   >>       06618000
<< returned by 'GetIPmapRec' to be that of the segment con-    >>       06620000
<< taining a requested procedure or entry point name.  The     >>       06622000
<< procedure 'PmapCBInit' must be called prior to calling >>            06624000
<< this one.                                                   >>       06626000
<<                                                             >>       06628000
<< Note that this procedure will not find hidden procedures or >>       06630000
<< entry points.                                               >>       06632000
<<                                                             >>       06634000
<< INPUT:                                                      >>       06636000
<<                                                             >>       06638000
<<    ReqEntName - This is a 16-byte array containing the name >>       06640000
<<       of the procedure or secondary entry point to be       >>       06642000
<<       found.  It is assumed to be left-justified with blank >>       06644000
<<       fill.                                                 >>       06646000
<<                                                             >>       06648000
<<    PmapCB - This is the PMAP control block as described in  >>       06650000
<<       the global declarations.  Prior to the first call to  >>       06652000
<<       this routine it must have been partially initialized  >>       06654000
<<       by PmapCBInit.                                        >>       06656000
<<                                                             >>       06658000
<< OUTPUT:                                                     >>       06660000
<<                                                             >>       06662000
<<    PmapCB - This is the PMAP control block as described in  >>       06664000
<<       the global declarations.  It will be returned updated >>       06666000
<<       as appropriate.                                       >>       06668000
<<                                                             >>       06670000
<<    Status - This is a standard PMAP intrinsic error code    >>       06672000
<<       returned to indicate detection of any abnormal con-   >>       06674000
<<       dition.  Any value other than 0 should be passed on   >>       06676000
<<       to the caller of the originating PMAP intrinsic.      >>       06678000
<<                                                             >>       06680000
$PAGE                                                                   06682000
begin << PmapFindSLEntName >>                                           06684000
                                                                        06686000
<< The following declarations provide access to the PMAP Con-  >>       06688000
<< trol Block:                                                 >>       06690000
PMAPCBDEC;                   << PMAP Control Block arrays >>            06692000
byte array ReqEntNameBlock (0:16);                                      06694000
integer pointer SLRefP;           << Current Ref Tab entry >>           06696000
logical pointer SLRefLP = SLRefP;                                       06698000
byte    pointer SLRefBP;          << 1st byte of entry >>               06700000
                                                                        06702000
<< SL entry point directory buffer declarations: >>                     06704000
integer array SLDirRec(0:DRECNUMWDS - 1); << Current SL dir rec>>       06706000
integer pointer SLDirRecP  = SLDirRec;                                  06708000
logical pointer SLDirRecLP = SLDirRec;                                  06710000
integer pointer SLDirEntP;        << SL entry pt directory ent >>       06712000
byte    pointer SLDirEntBP;                                             06714000
integer pointer SLDirEntP1;       << 1st word after name >>             06716000
integer         SLDirSect;        << # current SL directory rec>>       06718000
integer         SLDirX;           << Index to cur SL dir entry >>       06720000
integer         SLDirEntLen;      << Length of current dir ent >>       06722000
                                                                        06724000
<< Miscellaneous declarations: >>                                       06726000
integer ReqNameLen;               << Length of requested name >>        06728000
integer pointer SLDirHashPtrs;                                          06730000
$PAGE                                                                   06732000
<< PmapFindSLEntName >>                                                 06734000
                                                                        06736000
   BuildNameBlock(ReqEntNameBlock,17,ReqEntName,,Status);               06738000
   ReqNameLen:=NameNumCh(ReqEntNameBlock);                              06740000
   SLDirSect:=SL0'DirHashPtrs(Hash(ReqEntName,ReqNameLen));             06742000
   while SLDirSect <> 0 do                                              06744000
      begin                                                             06746000
      FReadDir(IPmapFNum, SLDirRec, DRECNUMWDS,                         06748000
               double(SLDirSect));                                      06750000
      CHECKIPMAPIO;                                                     06752000
      SLDirX := 2;                                                      06754000
      while SLDirX < SLDirRec'NumWdsUsed do                             06756000
         begin                                                          06758000
         MapSLDirEnt(SLDirRec(SLDirX), SLDirEntP, SLDirEntBP,           06760000
                     SLDirEntP1,SLDirEntLen);                           06762000
         if NamesMatch(SLDirEnt'NameBlock, ReqEntNameBlock) then        06764000
            begin                                                       06766000
            LoadSLRefEnt(SLDirEnt'SegNum, SLRefP, SLRefBP,              06768000
                         PmapCB, Status);                               06770000
            if Status <> STAT'OK then                                   06772000
               return;                                                  06774000
            if SLRef'PmapDRecNum = 0 then                               06776000
               begin                                                    06778000
                  Status:=STAT'NOPMAP;                                  06780000
                  return;                                               06782000
               end;                                                     06784000
            LoadIPmapBuf(SLRef'PmapDRecNum,0,                           06786000
                         PmapCB,Status);                                06788000
            PmapPreset := true;                                         06790000
            Status     := STAT'OK;                                      06792000
            return;                                                     06794000
            end                                                         06796000
         else                                                           06798000
            SLDirX := SLDirX + SLDirEntLen;                             06800000
         end;                                                           06802000
      SLDirSect := SLDirRec'Link;                                       06804000
      end;                                                              06806000
   Status := STAT'ENTNAMENOTFOUND;                                      06808000
                                                                        06810000
end; << PmapFindSLEntName >>                                            06812000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            06814000
$     "GETIPMAPREC"                                                     06816000
logical procedure GetIPmapRec(IPmapRec, IPmapRecP1, ScanCode,           06818000
                              PmapCB, Status);                          06820000
   value ScanCode;                                                      06822000
   integer array IPmapRec;        << Int. PMAP rec returned >>          06824000
   integer pointer IPmapRecP1;    << 1st word after name >>             06826000
   integer ScanCode;              << Procedure scan code >>             06828000
   integer array PmapCB;          << PMAP Control Block >>              06830000
   integer Status;                << Status code returned >>            06832000
                                                                        06834000
                                                                        06838000
<< This procedure gets the next internal PMAP record from the  >>       06840000
<< program or SL file being read.  Upon return, pointers in    >>       06842000
<< the PMAP Control Block will be set to point to the next     >>       06844000
<< PMAP record.  A special stop code is provided for the       >>       06846000
<< caller to indicate if he wants reading to stop at the end   >>       06848000
<< of the PMAP or at the end of the segment being scanned.     >>       06850000
<<                                                             >>       06852000
<< Prior to calling this procedure, two initialization proce-  >>       06854000
<< dures must be called to set up the PMAP Control Block.  The >>       06856000
<< first of these is 'PmapCBInit', which performs general      >>       06858000
<< validation of the program/SL file containing the PMAP and   >>       06860000
<< partially initializes the PMAP Control Block.  The second   >>       06862000
<< routine must be one of 'PmapFindSegNum', 'PmapFindSegName', >>       06864000
<< and 'PmapFindSLEntName', each of which completes the ini-   >>       06866000
<< tialization process.  Refer to the documentation on each of >>       06868000
<< these procedures for further details.                       >>       06870000
<<                                                             >>       06872000
<< INPUT:                                                      >>       06874000
<<                                                             >>       06876000
<<    ScanCode - This is a code used to indicate when an end-  >>       06878000
<<       of-PMAP condition should be returned.  SCANCURSEG     >>       06880000
<<       means it should be returned at the end of the current >>       06882000
<<       segment.  SCANALLSEGS means it should be returned at  >>       06884000
<<       the end of the last segment in the file.              >>       06886000
<<                                                             >>       06888000
<<    PmapCB - This is the PMAP control block as described in  >>       06890000
<<       the global declarations.  It is assumed to have been  >>       06892000
<<       initialized for access to internal PMAP records.      >>       06894000
<<                                                             >>       06896000
<< OUTPUT:                                                     >>       06898000
<<                                                             >>       06900000
<<    IPmapRec - This is an array in which the next Internal   >>       06902000
<<       PMAP Record is returned.  It is assumed to be large   >>       06904000
<<       enough to contain the largest possible record (cur-   >>       06906000
<<       rently 32 words).                                     >>       06908000
<<                                                             >>       06910000
<<    IPmapRecP1 - This is an integer pointer to the first     >>       06912000
<<       word after the name in Internal PMAP Record returned. >>       06914000
<<                                                             >>       06916000
<<    PmapCB - This is the PMAP control block as described in  >>       06918000
<<       the global declarations.  It will be returned updated >>       06920000
<<       as appropriate.                                       >>       06922000
<<                                                             >>       06924000
<<    Status - This is a standard PMAP intrinsic error code    >>       06926000
<<       returned to indicate detection of any abnormal con-   >>       06928000
<<       dition.  Any value other than 0 should be passed on   >>       06930000
<<       to the caller of the originating PMAP intrinsic.      >>       06932000
<<                                                             >>       06934000
                                                                        06936000
begin << GetIPmapRec >>                                                 06938000
                                                                        06940000
<< The following declarations provide access to the PMAP Con-  >>       06942000
<< trol Block:                                                 >>       06944000
PMAPCBDEC;                   << PMAP Control Block arrays >>            06946000
                                                                        06948000
<< Internal PMAP Record declarations: >>                                06950000
integer pointer IPmapP;           << 1st word of PMAP record >>         06952000
byte    pointer IPmapBP;                                                06954000
integer pointer IPmapP1;                                                06956000
double  pointer IPmapDP1 = IPmapP1;                                     06958000
integer         IPmapRecLen;      << # words in current record >>       06960000
$PAGE                                                                   06962000
<< GetIPmapRec >>                                                       06964000
                                                                        06966000
   if PmapEnd then                                                      06968000
      begin                                                             06970000
      Status := STAT'ENDOFPMAP;                                         06972000
      return;                                                           06974000
      end;                                                              06976000
   if not PmapPreset then                                               06978000
      begin                                                             06980000
      MapIPmapRec(PmapBuf(PmapBufX), IPmapP, IPmapBP, IPmapP1,          06982000
               IPmapRecLen,PmapCB);                                     06984000
      PmapBufX := PmapBufX + IPmapRecLen;                               06986000
      end;                                                              06988000
   if PmapBuf(PmapBufX) = 0 then                                        06990000
      begin                                                             06992000
      Status:=STAT'ENDOFPMAP;                                           06994000
      PmapEnd:=true;                                                    06996000
      return;                                                           06998000
      end;                                                              07000000
   if PmapBufX+IPMAPRECMAX > IPMAPBUFNUMWDS-1 then                      07002000
   << All or parts of next Pmap record probably lies >>                 07004000
   << outside of PmapBuf.                           >>                  07006000
   begin                                                                07008000
      PmapCurDRecNum:=PmapCurDRecNum+1;                                 07010000
      FReadMR(IPmapFNum,PmapBuf,IPMAPBUFNUMWDS,                         07012000
              PmapCurDRecNum,Status);                                   07014000
      if Status=STAT'IPMAPIOERR then return;                            07016000
      PmapBufX:=PmapBufX-128;                                           07018000
   end;                                                                 07020000
   MapIPmapRec(PmapBuf(PmapBufX), IPmapP, IPmapBP, IPmapP1,             07022000
               IPmapRecLen,PmapCB);                                     07024000
   if SegPmapMaped and ScanCode=SCANCURSEG and                          07026000
      Ipmap'Type=PMAPSEGTYPE then                                       07028000
   begin                                                                07030000
      Status:=STAT'ENDOFPMAP;                                           07032000
      return;                                                           07034000
   end;                                                                 07036000
   if IPmap'Type = PMAPSEGTYPE then                                     07038000
      SegPmapMaped := true;                                             07040000
                                                                        07042000
                                                                        07044000
   move IPmapRec:=IPmapP,(IPmapRecLen);                                 07046000
   @IPmapRecP1:=@IPmapRec+IPmap'NameNumCh/2+1;                          07048000
   Status:=STAT'OK;                                                     07050000
   GetIPmapRec:=true;                                                   07052000
   PmapPreset:=false;                                                   07054000
                                                                        07056000
end; << GetIPmapRec >>                                                  07058000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            07060000
$     "UPDATEIPMAPREC"                                                  07062000
procedure UpdateIPmapRec(IPmapRec, PmapCB, Status);                     07064000
   integer array IPmapRec;        << New int. PMAP record >>            07066000
   integer array PmapCB;          << PMAP Control Block >>              07068000
   integer Status;                << Status code returned >>            07070000
                                                                        07072000
   option internal;                                                     07074000
                                                                        07076000
<< This procedure updates the current internal PMAP record in  >>       07078000
<< the program or SL file.  A previous call to 'GetIPmapRec'   >>       07080000
<< is assumed, and the length of the Internal PMAP Record      >>       07082000
<< being updated is assumed not to have changed.               >>       07084000
<<                                                             >>       07086000
<< INPUT:                                                      >>       07088000
<<                                                             >>       07090000
<<    IPmapRec - This is an array containing the updated copy  >>       07092000
<<       of the Internal PMAP Record returned from the last    >>       07094000
<<       call to 'GetIPmapRec'.  No change in the length of    >>       07096000
<<       this record is allowed.                               >>       07098000
<<                                                             >>       07100000
<<    PmapCB - This is the PMAP control block as described in  >>       07102000
<<       the global declarations.  It is assumed to have been  >>       07104000
<<       initialized for access to internal PMAP records.      >>       07106000
<<                                                             >>       07108000
<< OUTPUT:                                                     >>       07110000
<<                                                             >>       07112000
<<    PmapCB - This is the PMAP control block as described in  >>       07114000
<<       the global declarations.  It will be returned updated >>       07116000
<<       as appropriate.                                       >>       07118000
<<                                                             >>       07120000
<<    Status - This is a standard PMAP intrinsic error code    >>       07122000
<<       returned to indicate detection of any abnormal con-   >>       07124000
<<       dition.  Any value other than 0 should be passed on   >>       07126000
<<       to the caller of the originating PMAP intrinsic.      >>       07128000
<<                                                             >>       07130000
                                                                        07132000
begin << UpdateIPmapRec >>                                              07134000
                                                                        07136000
<< The following declarations provide access to the PMAP Con-  >>       07138000
<< trol Block:                                                 >>       07140000
PMAPCBDEC;                   << PMAP Control Block arrays >>            07142000
                                                                        07144000
<< Internal PMAP declarations: >>                                       07146000
integer pointer IPmapP;           << 1st word of PMAP record >>         07148000
byte    pointer IPmapBP;                                                07150000
integer pointer IPmapP1;                                                07152000
double  pointer IPmapDP1 = IPmapP1;                                     07154000
integer         IPmapRecLen;      << # words in current record >>       07156000
                                                                        07158000
$PAGE                                                                   07160000
<< UpdateIPmapRec >>                                                    07162000
                                                                        07164000
   MapIPmapRec(PmapBuf(PmapBufX),IPmapP,IPmapBP,IPmapP1,                07166000
               IPmapRecLen,PmapCB);                                     07168000
   move PmapBuf(PmapBufX) := IPmapRec, (IPmapRecLen);                   07170000
   FWriteMR(IPmapFNum,PmapBuf,DRECNUMWDS*2,PmapCurDrecNum,              07172000
            Status);                                                    07174000
   if Status=STAT'IPMAPIOERR then return;                               07176000
   Status := STAT'OK;                                                   07178000
                                                                        07180000
end; << UpdateIPmapRec >>                                               07182000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            07184000
$     "UNPACKPMAPREC"                                                   07186000
procedure UnpackPmapRec(XPmapRec, IPmapRec, PmapCB);                    07188000
   integer array XPmapRec;         << External PMAP record >>           07190000
   integer array IPmapRec;         << Internal PMAP record >>           07192000
   integer array PmapCB;                                                07194000
                                                                        07196000
   option internal;                                                     07198000
                                                                        07200000
   << This procedure unpacks an internal PMAP record into the  >>       07202000
   << format of an external PMAP record.  All fields in the    >>       07204000
   << external record that fall below the level of the inter-  >>       07206000
   << nal PMAP record being unpacked will be reset to the null >>       07208000
   << (blank) state.                                           >>       07210000
   <<                                                          >>       07212000
   << INPUT:                                                   >>       07214000
   <<    IPmapRec - This is the internal PMAP record to be un- >>       07216000
   <<       packed.                                            >>       07218000
   <<                                                          >>       07220000
   << OUTPUT:                                                  >>       07222000
   <<    XPmapRec - This is the external PMAP record to re-    >>       07224000
   <<       ceive the data to be unpacked.                     >>       07226000
                                                                        07228000
   begin << UnpackPmapRec >>                                            07230000
   PMAPCBDEC;                                                           07232000
                                                                        07234000
   << Pointers used to access the PMAP records: >>                      07236000
   integer pointer IPmapP;                                              07238000
   byte    pointer IPmapBP;                                             07240000
   integer pointer IPmapP1;                                             07242000
   double  pointer IPmapDP1 = IPmapP1;                                  07244000
   integer pointer XPmapP   = XPmapRec;                                 07246000
   byte    array   XPmapBP(*) = XPmapRec;                               07248000
   double  pointer XPmapDP  = XPmapRec;                                 07250000
   integer         Len;                                                 07252000
$PAGE                                                                   07254000
subroutine ZeroFill(Iarray, Len);                                       07256000
   value Len;                                                           07258000
   integer array Iarray;          << Array to be zeroed >>              07260000
   integer Len;                   << # of words to be zeroed >>         07262000
                                                                        07264000
   << This subroutine fills an array with binary zeroes. >>             07266000
                                                                        07268000
   begin << ZeroFill >>                                                 07270000
                                                                        07272000
      Iarray := 0;                                                      07274000
      move Iarray(1) := Iarray, (Len - 1);                              07276000
                                                                        07278000
   end; << ZeroFill >>                                                  07280000
                                                                        07282000
subroutine BlankFill(String, Len);                                      07284000
   value Len;                                                           07286000
   byte array String;             << Byte array to be blanked >>        07288000
   integer Len;                   << # of chars to be blanked >>        07290000
                                                                        07292000
   << This subroutine fills a string with blanks. >>                    07294000
                                                                        07296000
   begin << BlankString >>                                              07298000
                                                                        07300000
      String := " ";                                                    07302000
      move String(1) := String, (Len - 1);                              07304000
                                                                        07306000
   end; << BlankString >>                                               07308000
                                                                        07310000
subroutine UnpackName(Dest, Source, Len);                               07312000
   value Len;                                                           07314000
   byte array Dest;               << Unpacked name >>                   07316000
   byte array Source;             << Name to unpack >>                  07318000
   integer Len;                   << Length of packed name >>           07320000
                                                                        07322000
   << This procedure unpacks a variable-length symbolic name   >>       07324000
   << into a fixed-length buffer, left-justified with blank    >>       07326000
   << fill.  The length of the destination buffer is assumed   >>       07328000
   << to be 'SYMNAMEMAX' bytes.                                >>       07330000
                                                                        07332000
   begin << UnpackName >>                                               07334000
                                                                        07336000
      BlankFill(Dest, SYMNAMEMAX);                                      07338000
      move Dest := Source, (Len);                                       07340000
                                                                        07342000
   end; << UnpackName >>                                                07344000
$PAGE                                                                   07346000
<< UnpackPmapRec >>                                                     07348000
                                                                        07350000
   MapIPmapRec(IPmapRec,IPmapP,IPmapBP,IPmapP1,Len,PmapCB);             07352000
                                                                        07354000
   << Unpack the data. >>                                               07356000
   XPmap'Type := IPmap'Type;                                            07358000
   if IPmap'Type = PMAPSEGTYPE then                                     07360000
      begin                                                             07362000
      UnpackName(XPmap'SegName,IPmap'Name(1),IPmap'NameNumCh);          07364000
      XPmap'SegNum := IPmap'SegNum;                                     07366000
      XPmap'SegLen := IPmap'SegLen;                                     07368000
      XPmap'SttLen := IPmap'SttLen;                                     07370000
                                                                        07372000
      BlankFill(XPmap'ProcName, (SYMNAMEMAX + 1) * 2);                  07374000
      ZeroFill(XPmap'ProcStart, 8);                                     07376000
      end                                                               07378000
   else if IPmap'Type = PMAPPROCTYPE then                               07380000
      begin                                                             07382000
      UnpackName(XPmap'ProcName,IPmap'Name(1),IPmap'NameNumCh);         07384000
      XPmap'ProcStart := IPmap'ProcStart;                               07386000
      XPmap'ProcLen   := IPmap'ProcLen;                                 07388000
      XPmap'ProcEntry := IPmap'ProcEntry;                               07390000
      XPmap'TboxId    := IPmap'TboxId;                                  07392000
      XPmap'TboxLink  := IPmap'TboxLink;                                07394000
                                                                        07396000
      BlankFill(XPmap'SecName, SYMNAMEMAX + 1);                         07398000
      ZeroFill(XPmap'SecEntry, 2);                                      07400000
      end                                                               07402000
   else                                                                 07404000
      begin                                                             07406000
      UnpackName(XPmap'SecName,IPmap'Name(1),IPmap'NameNumCh);          07408000
      XPmap'SecEntry := IPmap'SecEntry;                                 07410000
      XPmap'SecEntNum := IPmap'SecEntNum;                               07412000
      end;                                                              07414000
                                                                        07416000
end; << UnpackPmapRec >>                                                07418000
$PAGE "PROGRAM FILE PMAP INTRINSICS SUPPORT PROCEDURES - ",&            07420000
$     "COPYXPMAPREC"                                                    07422000
procedure CopyXPmapRec(Dest, Source, Len);                              07424000
   value Len;                                                           07426000
   integer array Dest;       << Destination record >>                   07428000
   integer array Source;     << Source PMAP record >>                   07430000
   integer Len;              << Destination record length >>            07432000
                                                                        07434000
   option internal;                                                     07436000
                                                                        07438000
<< This procedure copies an external PMAP record from one buf- >>       07440000
<< fer to another.  The source buffer is assumed to contain an >>       07442000
<< external PMAP record of maximum length, while the length of >>       07444000
<< the destination buffer is specified by 'Len'.  In no case   >>       07446000
<< will more than the number of words in the source buffer be  >>       07448000
<< moved.                                                      >>       07450000
                                                                        07452000
begin << CopyXPmapRec >>                                                07454000
                                                                        07456000
   if Len < 1 then                                                      07458000
      return;                                                           07460000
   move Dest := Source, (if Len > XPMAPRECMAX then XPMAPRECMAX          07462000
                         else Len);                                     07464000
                                                                        07466000
end; << CopyXPmapRec >>                                                 07468000
$PAGE "PROGRAM FILE PMAP INTRINSICS - FINDPMAPNAME"                     07470000
procedure FindPmapName(ProgFile, SegName, EntName, XPmapRec,            07472000
                       XPmapRecLen, Status);                            07474000
   value Progfile, XPmapRecLen;                                         07476000
   integer ProgFile;              << Program/SL file number >>          07478000
   byte array SegName;            << Segment name to be found >>        07480000
   byte array EntName;            << Entry point to be found >>         07482000
   integer array XPmapRec;        << Extern. PMAP rec returned >>       07484000
   integer XPmapRecLen;           << # words to be returned >>          07486000
   integer Status;                << Status returned >>                 07488000
                                                                        07490000
option variable;                                                        07492000
                                                                        07494000
<< This procedure searches the PMAP in a program or SL file    >>       07496000
<< for a segment and/or entry point name.  If found, an appro- >>       07498000
<< priate External PMAP Record will be returned.  Otherwise,   >>       07500000
<< the status code will indicate why the search failed.        >>       07502000
<<                                                             >>       07504000
<< One or both of the parameters 'SegName' and 'EntName' must  >>       07506000
<< be included in the actual parameter list; the action taken  >>       07508000
<< according to their various combinations is as follows:      >>       07510000
<<                                                             >>       07512000
<< 'SegName' only:  This calling sequence results in a search  >>       07514000
<< for a segment name only.  If found, a segment (type 0) ex-  >>       07516000
<< ternal PMAP Record will be returned.                        >>       07518000
<<                                                             >>       07520000
<< 'EntName' only:  This calling sequence results in a search  >>       07522000
<< for a procedure or secondary entry point name.  In program  >>       07524000
<< files, all procedures and secondary entry points will be    >>       07526000
<< searched.  In SL files, only those procedures and secondary >>       07528000
<< entry points appearing in the file directory will be        >>       07530000
<< searched.  This implies that hidden procedures and secon-   >>       07532000
<< dary entry points will not be found.  A procedure (type 1   >>       07534000
<< or 3) or entry point (type 2 or 4) External PMAP Record     >>       07536000
<< will be returned.                                           >>       07538000
<<                                                             >>       07540000
<< Both 'SegName' and 'EntName':  This calling sequence re-    >>       07542000
<< sults in a search for a procedure or secondary entry point  >>       07544000
<< name in a specified segment.  Hidden procedures and secon-  >>       07546000
<< dary entry points will be included in the search since the  >>       07548000
<< segment name qualifies such names for uniqueness.           >>       07550000
<<                                                             >>       07552000
<< 'SegName' and 'EntName' may be excluded from a procedure    >>       07554000
<< call either by physical omission in the parameter list, or  >>       07556000
<< by the presence of a blank as the first character in their  >>       07558000
<< byte arrays.  All other parameters in the calling sequence  >>       07560000
<< must be present.                                            >>       07562000
$PAGE                                                                   07564000
begin << FindPmapName >>                                                07566000
                                                                        07568000
<< Option variable data: >>                                             07570000
equate REQPARMS = %47;            << Bits for required parms >>         07572000
define SegName' = ParmFlags.(11:1)#;                                    07574000
define EntName' = ParmFlags.(12:1)#;                                    07576000
                                                                        07578000
<< PMAP control block allocations: >>                                   07580000
integer array PmapCB(0:PMAPCBLEN - 1);                                  07582000
PMAPCBDEC;                                                              07584000
                                                                        07586000
<< Internal PMAP record buffer allocation: >>                           07588000
integer array   IPmapBuf(0:IPMAPRECMAX - 1);                            07590000
integer pointer IPmapP   = IPmapBuf;                                    07592000
byte    array   IPmapBP(*) = IPmapBuf;                                  07594000
integer pointer IPmapP1;                                                07596000
double  pointer IPmapDP1 = IPmapP1;                                     07598000
                                                                        07600000
<< External PMAP record buffer allocation: >>                           07602000
integer array XPmapBuf(0:XPMAPRECMAX - 1);                              07604000
                                                                        07606000
<< Miscellaneous declarations: >>                                       07608000
byte array ReqSeg(0:SYMNAMEMAX);  << Segment name to be found >>        07610000
byte array ReqEnt(0:SYMNAMEMAX);  << Entry point to be found >>         07612000
integer ReqEntLen;                << Length of entry pt. name >>        07614000
integer SearchType;               << Type of search to be done >>       07616000
   equate SEARCHSEG = 1;          << Search for segment name >>         07618000
   equate SEARCHENT = 2;          << Search for directory entry>>       07620000
   equate SEARCHHID = 3;          << Search segment for entry >>        07622000
integer ScanCode;                 << PMAP scan halt code >>             07624000
integer I;                        << Miscellaneous counter >>           07626000
$PAGE                                                                   07628000
subroutine FormatSymName(Dest, Source);                                 07630000
   value Source;                                                        07632000
   byte array Dest;               << Formatted name >>                  07634000
   byte pointer Source;           << Unformatted name >>                07636000
                                                                        07638000
   << This subroutine formats a symbolic name into a fixed-    >>       07640000
   << length buffer, left-justified with blank fill.  The      >>       07642000
   << buffer is assumed to be one character longer than the    >>       07644000
   << longest symbolic name ('SYMNAMEMAX' characters) so that  >>       07646000
   << the name is guaranteed to be followed by at least one    >>       07648000
   << blank.                                                   >>       07650000
   <<                                                          >>       07652000
   << The source name is assumed to be terminated by a blank   >>       07654000
   << if it contains fewer than 'SYMNAMEMAX' characters.       >>       07656000
   << Longer names will be truncated without warning after the >>       07658000
   << 'SYMNAMEMAX'th character to fit in the destination buf-  >>       07660000
   << fer.                                                     >>       07662000
                                                                        07664000
   begin << FormatSymName >>                                            07666000
                                                                        07668000
      for I := 0 until SYMNAMEMAX - 1 do                                07670000
         begin                                                          07672000
         Dest(I) := Source;                                             07674000
         if Source <> " " then                                          07676000
            @Source := @Source + 1;                                     07678000
         end;                                                           07680000
      Dest(SYMNAMEMAX) := " ";                                          07682000
                                                                        07684000
   end; << FormatSymName >>                                             07686000
$PAGE                                                                   07688000
subroutine SearchForSegName;                                            07690000
                                                                        07692000
   << This subroutine completes the search of the PMAP for a   >>       07694000
   << segment name after the caller has performed preliminary  >>       07696000
   << validation of the procedure parameters and has initial-  >>       07698000
   << ized the PMAP Control Block.                             >>       07700000
   <<                                                          >>       07702000
   << Upon return, the status code indicates success or fail-  >>       07704000
   << ure and must be used to set the condition code prior to  >>       07706000
   << returning control to the caller of the PMAP intrinsic.   >>       07708000
                                                                        07710000
   begin << SearchForSegName >>                                         07712000
                                                                        07714000
      PmapFindSegName(ReqSeg, PmapCB, Status);                          07716000
      if Status <> STAT'OK then                                         07718000
         return;                                                        07720000
      GetIPmapRec(IPmapBuf, IPmapP1, SCANCURSEG,                        07722000
                      PmapCB, Status);                                  07724000
      if Status <> STAT'OK then                                         07726000
         return;                                                        07728000
      UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB);                        07730000
      CopyXPmapRec(XPmapRec, XPmapBuf, XPmapRecLen);                    07732000
                                                                        07734000
   end; << SearchForSegName >>                                          07736000
$PAGE                                                                   07738000
subroutine SearchForEntName;                                            07740000
                                                                        07742000
   << This subroutine completes the search of the PMAP for a   >>       07744000
   << procedure or entry point name after the caller has per-  >>       07746000
   << formed preliminary validation of the procedure parame-   >>       07748000
   << ters and has initialized the PMAP Control Block.  Hidden >>       07750000
   << entry points will not be detected by this subroutine.    >>       07752000
   <<                                                          >>       07754000
   << Upon return, the status code indicates success or fail-  >>       07756000
   << ure and must be used to set the condition code prior to  >>       07758000
   << returning control to the caller of the PMAP intrinsic.   >>       07760000
                                                                        07762000
   begin << SearchForEntName >>                                         07764000
                                                                        07766000
      scan ReqEnt until "  ",1;                                         07768000
      ReqEntLen := tos - @ReqEnt;                                       07770000
      if IPmapFileCode = SLFILECODE then                                07772000
         begin                                                          07774000
         PmapFindSLEntName(ReqEnt, PmapCB,                              07776000
                           Status);                                     07778000
         if Status <> STAT'OK then                                      07780000
            return;                                                     07782000
         ScanCode := SCANCURSEG;                                        07784000
         end                                                            07786000
      else                                                              07788000
         begin                                                          07790000
         PmapFindSegNum(0, PmapCB, Status);                             07792000
         if Status <> STAT'OK then                                      07794000
            return;                                                     07796000
         ScanCode := SCANALLSEGS;                                       07798000
         end;                                                           07800000
      while GetIPmapRec(IPmapBuf, IPmapP1,                              07802000
                            ScanCode, PmapCB, Status) do                07804000
         if IPmap'Type = PMAPSEGTYPE then                               07806000
            UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB)                   07808000
         else if IPmap'HIdden = false and                               07810000
                 IPmap'NameNumCh = ReqEntLen and                        07812000
                 IPmap'Name(1) = ReqEnt, (ReqEntLen) then               07814000
            begin                                                       07816000
            UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB);                  07818000
            CopyXPmapRec(XPmapRec, XPmapBuf, XPmapRecLen);              07820000
            return;                                                     07822000
            end                                                         07824000
         else if IPmap'Type = PMAPPROCTYPE then                         07826000
            UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB);                  07828000
      if Status = STAT'ENDOFPMAP then                                   07830000
         Status := STAT'ENTNAMENOTFOUND;                                07832000
                                                                        07834000
   end; << SearchForEntName >>                                          07836000
$PAGE                                                                   07838000
subroutine SearchForHidEntry;                                           07840000
                                                                        07842000
   << This subroutine completes the search of the PMAP for a   >>       07844000
   << procedure or entry point name in a specified segment     >>       07846000
   << after the caller has performed preliminary validation of >>       07848000
   << the procedure parameters and has initialized the PMAP    >>       07850000
   << Control Block.  Hidden entry points will be detected by  >>       07852000
   << this subroutine.  Upon return, control may be passed     >>       07854000
   << directly to the caller of the procedure.                 >>       07856000
                                                                        07858000
   begin << SearchForHidEntry >>                                        07860000
                                                                        07862000
      scan ReqEnt until "  ",1;                                         07864000
      ReqEntLen := tos - @ReqEnt;                                       07866000
      PmapFindSegName(ReqSeg, PmapCB, Status);                          07868000
      if Status <> STAT'OK then                                         07870000
         return;                                                        07872000
      while GetIPmapRec(IPmapBuf, IPmapP1,                              07874000
                            SCANCURSEG, PmapCB, Status) do              07876000
         if IPmap'Type = PMAPSEGTYPE then                               07878000
            UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB)                   07880000
         else if IPmap'NameNumCh = ReqEntLen and                        07882000
                 IPmap'Name(1) = ReqEnt, (ReqEntLen) then               07884000
            begin                                                       07886000
            UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB);                  07888000
            CopyXPmapRec(XPmapRec, XPmapBuf, XPmapRecLen);              07890000
            return;                                                     07892000
            end                                                         07894000
         else if IPmap'Type = PMAPPROCTYPE then                         07896000
            UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB);                  07898000
      if Status = STAT'ENDOFPMAP then                                   07900000
         Status := STAT'ENTNAMENOTFOUND;                                07902000
                                                                        07904000
   end; << SearchForHidEntry >>                                         07906000
$PAGE                                                                   07908000
<< FindPmapName >>                                                      07910000
                                                                        07912000
   << Validate parameters. >>                                           07914000
   SearchType := 0;                                                     07916000
   if SegName' and SegName <> " " then                                  07918000
      begin                                                             07920000
      SearchType := SEARCHSEG;                                          07922000
      FormatSymName(ReqSeg, SegName);                                   07924000
      end;                                                              07926000
   if EntName' and EntName <> " " then                                  07928000
      begin                                                             07930000
      SearchType := if SearchType = SEARCHSEG then SEARCHHID            07932000
                                              else SEARCHENT;           07934000
      FormatSymName(ReqEnt, EntName);                                   07936000
      end;                                                              07938000
   if SearchType = 0 or (ParmFlags land REQPARMS) <> REQPARMS           07940000
      then                                                              07942000
      begin                                                             07944000
      Status := STAT'MISSINGPARMS;                                      07946000
      go EXIT;                                                          07948000
      end;                                                              07950000
   PmapCBInit(ProgFile, PmapCB, Status);                                07952000
   if Status <> STAT'OK then                                            07954000
      go EXIT;                                                          07956000
                                                                        07958000
   if SearchType = SEARCHSEG then                                       07960000
      SearchForSegName                                                  07962000
   else if SearchType = SEARCHENT then                                  07964000
      SearchForEntName                                                  07966000
   else << SearchType = SEARCHHID >>                                    07968000
      SearchForHidEnt;                                                  07970000
                                                                        07972000
EXIT:                                                                   07974000
   CondCode := if Status = STAT'OK then CCE                             07976000
               else if Status = STAT'BADSEGID or                        07978000
                       Status = STAT'ENTNAMENOTFOUND then CCG           07980000
               else CCL;                                                07982000
                                                                        07984000
end; << FindPmapName >>                                                 07986000
$PAGE "PROGRAM FILE PMAP INTRINSICS - FINDPMAPADDR"                     07988000
procedure FindPmapAddr(ProgFile, SegNum, Address, XPmapRec,             07990000
                       XPmapRecLen, Status);                            07992000
   value ProgFile, SegNum, Address, XPmapRecLen;                        07994000
   integer ProgFile;              << Program/SL <Fopen> number >>       07996000
   integer SegNum;                 << # of seg containing addr >>       07998000
   integer Address;               << Address to searhch for >>          08000000
   integer array XPmapRec;        << External PMAP rec returned>>       08002000
   integer XPmapRecLen;           << # words to return >>               08004000
   integer Status;                << Status returned >>                 08006000
                                                                        08008000
<< This procedure searches the PMAP in a program or SL file    >>       08010000
<< for a specific address in a particular code segment.  An    >>       08012000
<< External PMAP Record corresponding to the nearest entry     >>       08014000
<< point preceding <Address> will be returned.                 >>       08016000
                                                                        08018000
begin                                                                   08020000
                                                                        08022000
<< PMAP control block allocations: >>                                   08024000
integer array PmapCB(0:PMAPCBLEN - 1);                                  08026000
PMAPCBDEC;                                                              08028000
                                                                        08030000
<< Internal PMAP record buffer allocation: >>                           08032000
integer array   IPmapBuf(0:IPMAPRECMAX - 1);                            08034000
integer pointer IPmapP   = IPmapBuf;                                    08036000
byte    array   IPmapBP(*)  = IPmapBuf;                                 08038000
integer pointer IPmapP1;                                                08040000
double  pointer IPmapDP1 = IPmapP1;                                     08042000
                                                                        08044000
<< External PMAP record buffer allocation: >>                           08046000
integer array XPmapBuf(0:XPMAPRECMAX - 1);                              08048000
                                                                        08050000
<< Miscellaneous Variables: >>                                          08052000
logical FoundProc;                << True when procedure con-  >>       08054000
                                  <<   taining 'Address' has   >>       08056000
                                  <<   been seen.              >>       08058000
$PAGE                                                                   08060000
<< FindPmapAddr >>                                                      08062000
                                                                        08064000
   PmapCBInit(ProgFile, PmapCB, Status);                                08066000
   if Status <> STAT'OK then                                            08068000
      go EXIT;                                                          08070000
   PmapFindSegNum(SegNum, PmapCB, Status);                              08072000
   if Status <> STAT'OK then                                            08074000
      go EXIT;                                                          08076000
                                                                        08078000
   FoundProc := false;                                                  08080000
   while GetIPmapRec(IPmapBuf, IPmapP1, SCANCURSEG,                     08082000
                     PmapCB, Status) and not FoundProc do               08084000
      if IPmap'Type = PMAPSEGTYPE then                                  08086000
         UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB)                      08088000
      else if IPmap'Type = PMAPPROCTYPE then                            08090000
         if IPmap'ProcStart <= Address <= IPmap'ProcStart+              08092000
                                         IPmap'ProcLen - 1 then         08094000
            begin                                                       08096000
            UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB);                  08098000
            FoundProc := true;                                          08100000
            while GetIPmapRec(IPmapBuf,IPmapP1,SCANCURSEG,              08102000
                              PmapCB,Status) and                        08104000
                  IPmap'Type=PMAPSECTYPE do                             08106000
               if IPmap'SecEntry <= Address then                        08108000
                  UnpackPmapRec(XPmapBuf,IPmapBuf, PmapCB);             08110000
            end;                                                        08112000
   if FoundProc then                                                    08114000
      begin                                                             08116000
      CopyXPmapRec(XPmapRec, XPmapBuf, XPmapRecLen);                    08118000
      if Status = STAT'ENDOFPMAP then                                   08120000
         Status := STAT'OK;                                             08122000
      end                                                               08124000
   else                                                                 08126000
      if Status = STAT'OK or STATUS = STAT'ENDOFPMAP then               08128000
         Status := STAT'BADADDRESS;                                     08130000
                                                                        08132000
EXIT:                                                                   08134000
   CondCode := if Status = STAT'OK then CCE                             08136000
               else if STATUS = STAT'BADADDRESS then CCG                08138000
               else CCL;                                                08140000
                                                                        08142000
   end; << FindPmapAddress >>                                           08144000
$PAGE "PROGRAM FILE PMAP INTRINSICS - DUMPPMAP"                         08146000
procedure DumpPmap(ProgFile, XPmapFile, XPmapRecLen, RecCount,          08148000
                   SegNum, Status);                                     08150000
   value ProgFile, XPmapFile, XPmapRecLen, SegNum;                      08152000
   integer ProgFile;              << Program/SL file number >>          08154000
   integer XPmapFile;             << External PMAP file # >>            08156000
   integer XPmapRecLen;           << Max length of XPMAP recs >>        08158000
   integer SegNum;                 << Segment to be dumped >>           08160000
   integer RecCount;              << Record count returned >>           08162000
   integer Status;                << Status code returned >>            08164000
                                                                        08166000
<< This procedure copies the contents of an internal PMAP in a >>       08168000
<< program or SL file into a seperate file containing external >>       08170000
<< PMAP records.                                               >>       08172000
                                                                        08174000
begin << DumpPmap >>                                                    08176000
                                                                        08178000
<< PMAP control block allocations: >>                                   08180000
integer array PmapCB(0:PMAPCBLEN - 1);                                  08182000
PMAPCBDEC;                                                              08184000
                                                                        08186000
<< Internal PMAP record buffer allocation: >>                           08188000
integer array   IPmapBuf(0:IPMAPRECMAX - 1);                            08190000
integer pointer IPmapP   = IPmapBuf;                                    08192000
byte    array   IPmapBP(*)  = IPmapBuf;                                 08194000
integer pointer IPmapP1;                                                08196000
double  pointer IPmapDP1 = IPmapP1;                                     08198000
                                                                        08200000
<< External PMAP record buffer allocation: >>                           08202000
integer array XPmapBuf(0:XPMAPRECMAX - 1);                              08204000
logical array XPmapBufL(*) = XPmapBuf;                                  08206000
                                                                        08208000
<< Miscellaneous Declarations: >>                                       08210000
integer RecLen;                   << Actual XPMAP record len >>         08212000
integer ScanCode;                 << PMAP scan code used >>             08214000
$PAGE                                                                   08216000
subroutine CopyIntoXPmapFile;                                           08218000
begin                                                                   08220000
   while GetIPmapRec(IPmapBuf, IPmapP1, ScanCode,                       08222000
                     PmapCB, Status) do                                 08224000
      begin                                                             08226000
      UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB);                        08228000
      FWrite(XPmapFile, XPmapBufL, RecLen, 0);                          08230000
      if > then                                                         08232000
         begin                                                          08234000
         Status := STAT'XPMAPFILEFULL;                                  08236000
         go EXIT;                                                       08238000
         end                                                            08240000
      else if < then                                                    08242000
         begin                                                          08244000
         Status := STAT'XPMAPIOERR;                                     08246000
         go EXIT;                                                       08248000
         end;                                                           08250000
      RecCount := RecCount + 1;                                         08252000
      end;                                                              08254000
end;                                                                    08256000
$PAGE                                                                   08258000
<< DumpPmap >>                                                          08260000
                                                                        08262000
   PmapCBInit(ProgFile, PmapCB, Status);                                08264000
   if Status <> STAT'OK then                                            08266000
      go EXIT;                                                          08268000
   RecLen := if 1 <= XPmapRecLen <= XPMAPRECMAX                         08270000
             then XPmapRecLen else XPMAPRECMAX;                         08272000
   RecCount := 0;                                                       08274000
   if IPmapFileCode = PROGFILECODE then                                 08276000
      begin                                                             08278000
         ScanCode := if SegNum = -1 then SCANALLSEGS else SCANCURSEG;   08280000
         if SegNum=-1 then SegNum:=0;                                   08282000
         PmapFindSegNum(SegNum, PmapCB, Status);                        08284000
         if Status <> STAT'OK then                                      08286000
            go EXIT;                                                    08288000
         CopyIntoXPmapFile;                                             08290000
      end                                                               08292000
   else                                                                 08294000
      if SegNum = -1 then                                               08296000
         begin                                                          08298000
            SegNum:=0;                                                  08300000
            ScanCode:=SCANCURSEG;                                       08302000
            while SegNum < SL0'NUmSegsAlloc do                          08304000
               begin                                                    08306000
                  PmapFindSegNum(SegNum, PmapCB, Status);               08308000
                  if Status <> STAT'OK then                             08310000
                     if Status<>STAT'SEGDELETED and                     08312000
                        Status<>STAT'NOPMAP then                        08314000
                        go EXIT                                         08316000
                     else                                               08318000
                  else CopyIntoXPmapFile;                               08320000
                  SegNum:=SegNum+1;                                     08322000
               end;                                                     08324000
         end                                                            08326000
      else                                                              08328000
         begin                                                          08330000
            PmapFindSegNum(SegNum,PmapCB,Status);                       08332000
            if Status <> STAT'OK then go EXIT;                          08334000
            CopyIntoXPmapFile;                                          08336000
         end;                                                           08338000
   if Status = STAT'ENDOFPMAP then                                      08340000
      Status := STAT'OK;                                                08342000
                                                                        08344000
   if RecCount=0 then Status:=STAT'NOPMAP;                              08346000
                                                                        08348000
EXIT:                                                                   08350000
   CondCode := if Status = STAT'OK then CCE                             08352000
               else if Status = STAT'XPMAPIOERR then CCG                08354000
               else CCL;                                                08356000
                                                                        08358000
   end; << DumpPmap >>                                                  08360000
$PAGE "PROGRAM FILE PMAP INTRINSICS - FINDTOOLBOXID"                    08362000
procedure FindToolboxId(ProgFile, ToolboxId, XPmapRec,                  08364000
                                XPmapRecLen, Status);                   08366000
   value ProgFile, ToolboxId, XPmapRecLen;                              08368000
   integer ProgFile;              << Program/SL file number >>          08370000
   integer ToolboxId;             << Toolbox ID to be found >>          08372000
   integer array XPmapRec;        << Extern. PMAP rec returned >>       08374000
   integer XPmapRecLen;           << # words to be returned >>          08376000
   integer Status;                << Status returned >>                 08378000
                                                                        08380000
<< This procedure searches the PMAP in a program or SL file    >>       08382000
<< for a procedure entry associated with a specified TOOLBOX   >>       08384000
<< ID.  If found, a procedure (type 1 or 3) External PMAP Rec- >>       08386000
<< ord describing the code module associated with the ID will  >>       08388000
<< be returned.  Otherwise, the status code will indicate why  >>       08390000
<< the search failed.                                          >>       08392000
                                                                        08394000
begin << FindToolboxId >>                                               08396000
                                                                        08398000
<< PMAP control block allocations: >>                                   08400000
integer array PmapCB(0:PMAPCBLEN - 1);                                  08402000
PMAPCBDEC;                                                              08404000
                                                                        08406000
<< Internal PMAP record buffer allocation: >>                           08408000
integer array   IPmapBuf(0:IPMAPRECMAX - 1);                            08410000
integer pointer IPmapP   = IPmapBuf;                                    08412000
byte    array   IPmapBP(*)  = IPmapBuf;                                 08414000
integer pointer IPmapP1;                                                08416000
double  pointer IPmapDP1 = IPmapP1;                                     08418000
integer SegNum;                                                         08420000
integer ScanCode;                                                       08422000
                                                                        08424000
<< External PMAP record buffer allocation: >>                           08426000
integer array XPmapBuf(0:XPMAPRECMAX - 1);                              08428000
$PAGE                                                                   08430000
subroutine GetToolBoxID;                                                08432000
begin                                                                   08434000
   while GetIPmapRec(IPmapBuf, IPmapP1, ScanCode,                       08436000
                     PmapCB, Status) do                                 08438000
      begin                                                             08440000
      if IPmap'Type = PMAPSEGTYPE then                                  08442000
         UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB)                      08444000
      else if IPmap'Type = PMAPPROCTYPE and                             08446000
              IPmap'TboxId = ToolboxId then                             08448000
         begin                                                          08450000
         UnpackPmapRec(XPmapBuf, IPmapBuf, PmapCB);                     08452000
         CopyXPmapRec(XPmapRec, XPmapBuf, XPmapRecLen);                 08454000
         go EXIT;                                                       08456000
         end;                                                           08458000
      end;                                                              08460000
end;                                                                    08462000
$PAGE                                                                   08464000
<< FindToolboxId >>                                                     08466000
                                                                        08468000
   PmapCBInit(ProgFile, PmapCB, Status);                                08470000
   if Status <> STAT'OK then                                            08472000
      go EXIT;                                                          08474000
   if IPmapFileCode = ProgFileCode then                                 08476000
      begin                                                             08478000
         PmapFindSegNum(0, PmapCB, Status);                             08480000
         if Status <> STAT'OK then                                      08482000
            go EXIT;                                                    08484000
         ScanCode := SCANALLSEGS;                                       08486000
         GetToolBoxID;                                                  08488000
      end                                                               08490000
   else                                                                 08492000
      begin                                                             08494000
         SegNum:=0;                                                     08496000
         ScanCode:=SCANCURSEG;                                          08498000
         while SegNum < SL0'NumSegsAlloc do                             08500000
            begin                                                       08502000
               PmapFindSegNum(SegNum,PmapCB,Status);                    08504000
               if Status <> STAT'OK then                                08506000
                  if Status <> STAT'SEGDELETED and                      08508000
                     Status <> STAT'NOPMAP then                         08510000
                     go EXIT                                            08512000
                  else                                                  08514000
               else                                                     08516000
                  GetToolBoxID;                                         08518000
               SegNum:=SegNum+1;                                        08520000
            end;                                                        08522000
      end;                                                              08524000
                                                                        08526000
   if Status = STAT'ENDOFPMAP then                                      08528000
      Status := STAT'TBOXIDNOTFOUND;                                    08530000
                                                                        08532000
EXIT:                                                                   08534000
   CondCode := if Status = STAT'OK then CCE                             08536000
               else if Status = STAT'TBOXIDNOTFOUND then CCG            08538000
               else CCL;                                                08540000
                                                                        08542000
end; << FindToolboxId >>                                                08544000
$PAGE "PROGRAM FILE PMAP INTRINSICS - UPDATETOOLBOXID"                  08546000
procedure UpdateToolboxId(ProgFile, ToolboxId, ToolboxIdLink,           08548000
                          Status);                                      08550000
   value ProgFile, ToolboxId, ToolboxIdLink;                            08552000
   integer ProgFile;              << Program/SL file number >>          08554000
   integer ToolboxId;             << Toolbox ID to be found >>          08556000
   double  ToolboxIdLink;         << New TOOLBOX ID link >>             08558000
   integer Status;                << Status returned >>                 08560000
                                                                        08562000
<< This procedure searches the PMAP in a program or SL file    >>       08564000
<< for a procedure entry associated with a specified TOOLBOX   >>       08566000
<< ID.  If found, the TOOLBOX ID Link field in that entry will >>       08568000
<< be changed to the value supplied by the caller.  Otherwise, >>       08570000
<< the status code will indicate why the search failed.        >>       08572000
                                                                        08574000
begin << UpdateToolboxId >>                                             08576000
                                                                        08578000
<< PMAP control block allocations: >>                                   08580000
integer array PmapCB(0:PMAPCBLEN - 1);                                  08582000
PMAPCBDEC;                                                              08584000
                                                                        08586000
<< Internal PMAP record buffer allocation: >>                           08588000
integer array   IPmapBuf(0:IPMAPRECMAX - 1);                            08590000
integer pointer IPmapP   = IPmapBuf;                                    08592000
byte    array   IPmapBP(*)  = IPmapBuf;                                 08594000
integer pointer IPmapP1;                                                08596000
double  pointer IPmapDP1 = IPmapP1;                                     08598000
integer SegNum;                                                         08600000
integer ScanCode;                                                       08602000
                                                                        08604000
<< External PMAP record buffer allocation: >>                           08606000
integer array XPmapBuf(0:XPMAPRECMAX - 1);                              08608000
$PAGE                                                                   08610000
subroutine UpdateIfFoundID;                                             08612000
begin                                                                   08614000
   while GetIPmapRec(IPmapBuf, IPmapP1, ScanCode,                       08616000
                     PmapCB, Status) do                                 08618000
      begin                                                             08620000
      if IPmap'Type = PMAPPROCTYPE and                                  08622000
         IPmap'TboxId = ToolboxId then                                  08624000
         begin                                                          08626000
         IPmap'TboxId := ToolboxId;                                     08628000
         IPmap'TboxLink := ToolboxIdLink;                               08630000
         UpdateIPmapRec(IPmapBuf, PmapCB, Status);                      08632000
         go EXIT;                                                       08634000
         end;                                                           08636000
      end;                                                              08638000
end;                                                                    08640000
$PAGE                                                                   08642000
<< UpdateToolboxId >>                                                   08644000
                                                                        08646000
   PmapCBInit(ProgFile, PmapCB, Status);                                08648000
   if Status <> STAT'OK then                                            08650000
      go EXIT;                                                          08652000
   if IPmapFileCode = ProgFileCode then                                 08654000
      begin                                                             08656000
         PmapFindSegNum(0, PmapCB, Status);                             08658000
         if Status <> STAT'OK then                                      08660000
            go EXIT;                                                    08662000
         ScanCode := SCANALLSEGS;                                       08664000
         UpdateIfFoundID;                                               08666000
      end                                                               08668000
   else                                                                 08670000
      begin                                                             08672000
         SegNum:=0;                                                     08674000
         ScanCode:=SCANCURSEG;                                          08676000
         while SegNum < SL0'NumSegsAlloc do                             08678000
            begin                                                       08680000
               PmapFindSegNum(SegNum,PmapCB,Status);                    08682000
               if Status <> STAT'OK then                                08684000
                  if Status <> STAT'SEGDELETED and                      08686000
                     Status <> STAT'NOPMAP then                         08688000
                     go EXIT                                            08690000
                  else                                                  08692000
               else                                                     08694000
                  UpdateIfFoundID;                                      08696000
               SegNum:=SegNum+1;                                        08698000
            end;                                                        08700000
      end;                                                              08702000
                                                                        08704000
   if Status = STAT'ENDOFPMAP then                                      08706000
      Status := STAT'TBOXIDNOTFOUND;                                    08708000
                                                                        08710000
EXIT:                                                                   08712000
   CondCode := if Status = STAT'OK then CCE                             08714000
               else if Status = STAT'TBOXIDNOTFOUND then CCG            08716000
               else CCL;                                                08718000
                                                                        08720000
   end; << UpdateToolboxId >>                                           08722000
$PAGE "CHECKSUM INTRINSIC PROCEDURES - MATCHNAME"                       08724000
LOGICAL PROCEDURE MATCHNAME(NAME1,NAME2);                               08726000
BYTE ARRAY NAME1,NAME2;                                                 08728000
                                                                        08730000
<< THIS PROCEDURE COMPARE TWO NAMES AND    >>                           08732000
<< RETURN TRUE IF TWO NAMES ARE THE SAME.  >>                           08734000
<< NOTE : NAME1 AND NAME2 ARE BYTE ARRAY   >>                           08736000
<<        CONTAINING ONLY CHARACTERS.      >>                           08738000
<<        THEY ARE NOT FORMATED NAMEBLOCK. >>                           08740000
<<        MUST BE TERMINATED BY A BLANK.   >>                           08742000
                                                                        08744000
BEGIN                                                                   08746000
   BYTE ARRAY NAMEBLOCK1(0:16);                                         08748000
   BYTE ARRAY NAMEBLOCK2(0:16);                                         08750000
   INTEGER STATUS;                                                      08752000
   BUILDNAMEBLOCK(NAMEBLOCK1,17,NAME1,,STATUS);                         08754000
   BUILDNAMEBLOCK(NAMEBLOCK2,17,NAME2,,STATUS);                         08756000
   MATCHNAME := NAMESMATCH(NAMEBLOCK1,NAMEBLOCK2);                      08758000
END;                                                                    08760000
$PAGE "CHECKSUM INTRINSIC"                                              08762000
PROCEDURE GETCHECKSUM(FNUM,SEGNAME,SEGNUM,CHECKSUM,STATUS);             08764000
                                                                        08766000
VALUE FNUM,SEGNUM;                                                      08768000
INTEGER FNUM,SEGNUM,STATUS;                                             08770000
BYTE ARRAY SEGNAME;                                                     08772000
LOGICAL CHECKSUM;                                                       08774000
OPTION VARIABLE;                                                        08776000
                                                                        08778000
<<********************************************>>                        08780000
<< THIS PROCEDURE RETRIVE THE CHECKSUM STORED >>                        08782000
<< IN PROGRAM OR SL FILE.                     >>                        08784000
<<********************************************>>                        08786000
<< INPUT:                                     >>                        08788000
<<  FNUM   : PROGRAM OR SL FILE NUMBER.       >>                        08790000
<<  SEGNAME : SEGMENT NAME WHOSE CHECKSUM IS  >>                        08792000
<<            TO BE RETURNED.(OPTIONAL)       >>                        08794000
<<  SEGNUM : SEGMENT NUMBER WHOSE CHECKSUM IS >>                        08796000
<<           TO BE RETURNED.(OPTIONAL)        >>                        08798000
<<           IF SEGNUM = -1 THEN TOTAL CHECK  >>                        08800000
<<           SUM IS RETURNED.                 >>                        08802000
<<  **NOTE** 1. ONE OR BOTH OF THE PARAMETERS >>                        08804000
<<              'SEGNAME' AND 'SEGNUM'        >>                        08806000
<<              MUST BE SPECIFIED. IF BOTH    >>                        08808000
<<              SPECIFIED THEN THEY MUST      >>                        08810000
<<              AGREE WITH EACH OTHER.        >>                        08812000
<<           2. -1 FOR SEGNUM IS ONLY GOOD    >>                        08814000
<<              FOR PROGRAM FILES.            >>                        08816000
<<********************************************>>                        08818000
<< OUTPUT:                                    >>                        08820000
<<  CHECKSUM : CHECK SUM RETURNED.            >>                        08822000
<<  STATUS   :                                >>                        08824000
<<   = 0 : CHECKSUM RETURNED.                 >>                        08826000
<<   = 1 : SEGNAME SPECIFIED IS NOT THE       >>                        08828000
<<         SPECIFIED SEGNUM.                  >>                        08830000
<<   = 2 : ILLEGAL SEGNUM.                    >>                        08832000
<<   = 3 : SEGNAME NOT FOUND.                 >>                        08834000
<<   = 4 : ILLEGAL PARM SPECIFICATION.        >>                        08836000
<<   = 5 : NO CHECKSUM IN PROG/SL FILE.       >>                        08838000
<<   = 6 : FILE IS NOT PROG/SL FILE.          >>                        08840000
<<   =12 : I/O ERROR.                         >>                        08842000
<<   = 8 : FILE OPENED WITHOUT READ ACCESS.   >>                        08844000
<<********************************************>>                        08846000
                                                                        08848000
BEGIN                                                                   08850000
   LOGICAL PARMS = Q-4;                                                 08852000
   INTEGER S3=S-3;                                                      08854000
   DEFINE                                                               08856000
      SEGNUMSPECIFIED = PARMS.(13:1)#,                                  08858000
      SEGNAMESPECIFIED = PARMS.(12:1)#;                                 08860000
                                                                        08862000
   INTEGER ARRAY CKSUMCB(0:255);                                        08864000
      INTEGER ARRAY PF0P(*)         = CKSUMCB;                          08866000
      LOGICAL ARRAY PF0LP(*)        = CKSUMCB;                          08868000
                                                                        08870000
      INTEGER ARRAY SL0P(*)         = CKSUMCB;                          08872000
      LOGICAL ARRAY SL0LP(*)        = CKSUMCB;                          08874000
      LOGICAL ARRAY SLREFBLOCKDRECNUM(*) = CKSUMCB(20);                 08876000
      INTEGER ARRAY SLREFBLOCK(*)   = CKSUMCB(84);                      08878000
                                                                        08880000
   INTEGER POINTER SLREFP;                                              08882000
   LOGICAL POINTER SLREFLP = SLREFP;                                    08884000
   BYTE POINTER SLREFBP;                                                08886000
                                                                        08888000
   DEFINE                                                               08890000
      STAT'UNMATCH   = 1#,                                              08892000
      STAT'BADSEGNUM = 2#,                                              08894000
      STAT'SEGNOTFOUND = 3#,                                            08896000
      STAT'BADPARMS  = 4#,                                              08898000
      STAT'NOCKSUM   = 5#,                                              08900000
      STAT'BADFILE   = 6#,                                              08902000
      STAT'IOERROR   = 7#,                                              08904000
      STAT'BADFOPEN  = 8#;                                              08906000
                                                                        08908000
   INTEGER POINTER SEGDESC;                                             08910000
                                                                        08912000
   DEFINE                                                               08914000
      PF0'TOTALCKSUM  = PF0LP(19)#,                                     08916000
      PF0'CKSUMOK     = PF0LP(18).(1:1)#;                               08918000
                                                                        08920000
   DEFINE                                                               08922000
      SLREF'CKSUMOK = SLREFLP(6).(1:1)#;                                08924000
                                                                        08926000
   LOGICAL       PA'CHECKSUM;                                           08928000
   LOGICAL ARRAY PA'SEGNAMELA(0:8);                                     08930000
   BYTE ARRAY    PA'SEGNAME(*)=PA'SEGNAMELA;                            08932000
                                                                        08934000
   LOGICAL ARRAY BUF(0:127);                                            08936000
                                                                        08938000
   INTEGER       CURSEG'REC,                                            08940000
                 CURSEG'NUM,                                            08942000
                 CURSEG'LEN,                                            08944000
                 CURSEG'TEMPREC,                                        08946000
                                                                        08948000
                 STTLEN,                                                08950000
                 PATCHLEN,                                              08952000
                 RECDISP;                                               08954000
                                                                        08956000
   LOGICAL SLREFLOADED;                                                 08958000
   INTEGER REQREFBLOCK;                                                 08960000
   INTEGER CURREFBLOCK;                                                 08962000
                                                                        08964000
   LOGICAL AOPTION;                                                     08966000
   INTEGER FILECODE;                                                    08968000
$PAGE "GETSEGMENT"                                                      08970000
SUBROUTINE GETSEGMENT(SEGNO);                                           08972000
VALUE SEGNO;                                                            08974000
INTEGER SEGNO;                                                          08976000
                                                                        08978000
   IF FILECODE = PROGFILECODE THEN                                      08980000
      WHILE SEGNO > CURSEG'NUM DO                                       08982000
         BEGIN                                                          08984000
            CURSEG'REC:=CURSEG'REC+(CURSEG'LEN+127)/128;                08986000
            CURSEG'NUM:=CURSEG'NUM+1;                                   08988000
            CURSEG'LEN:=SEGDESC(CURSEG'NUM).(2:14);                     08990000
         END                                                            08992000
   ELSE  << SL FILE >>                                                  08994000
      BEGIN                                                             08996000
         REQREFBLOCK:=SEGNO/SLREFBLOCKFACT;                             08998000
         IF NOT SLREFLOADED OR REQREFBLOCK <> CURREFBLOCK               09000000
            THEN BEGIN                                                  09002000
               FREADDIR(FNUM,SLREFBLOCK,128,                            09004000
               DOUBLE(SLREFBLOCKDRECNUM(REQREFBLOCK)));                 09006000
               CHECKIPMAPIO;                                            09008000
               CURREFBLOCK:=REQREFBLOCK;                                09010000
               SLREFLOADED:=TRUE;                                       09012000
            END;                                                        09014000
         MAPSLREFENT(SLREFBLOCK((SEGNO MOD 4)*32),SLREFP,               09016000
                     SLREFBP);                                          09018000
         CURSEG'LEN:=SLREF'SEGNUMWDS;                                   09020000
         CURSEG'REC:=SLREF'CODEDRECNUM;                                 09022000
      END;                                                              09024000
$PAGE "ADJUSTRECDISP"                                                   09026000
SUBROUTINE ADJUSTRECDISP(LEN);                                          09028000
VALUE LEN;                                                              09030000
INTEGER LEN;                                                            09032000
                                                                        09034000
BEGIN                                                                   09036000
   CURSEG'TEMPREC:=CURSEG'TEMPREC-LEN/128;                              09038000
   LEN:=LEN MOD 128;                                                    09040000
   IF LEN > RECDISP THEN                                                09042000
      BEGIN                                                             09044000
         RECDISP:=RECDISP+128-LEN;                                      09046000
         CURSEG'TEMPREC:=CURSEG'TEMPREC-1;                              09048000
      END                                                               09050000
   ELSE                                                                 09052000
      RECDISP:=RECDISP-LEN;                                             09054000
END;                                                                    09056000
$PAGE "GETPATCHAREA"                                                    09058000
   SUBROUTINE GETPATCHAREA;                                             09060000
                                                                        09062000
   BEGIN                                                                09064000
      TOS:=CURSEG'LEN;                                                  09066000
      TOS:=128;                                                         09068000
      ASSEMBLE(DIV);                                                    09070000
      RECDISP:=TOS;                                                     09072000
      CURSEG'TEMPREC:=CURSEG'REC+TOS;                                   09074000
      IF RECDISP=0 THEN                                                 09076000
         BEGIN                                                          09078000
            RECDISP:=127;                                               09080000
            CURSEG'TEMPREC:=CURSEG'TEMPREC-1;                           09082000
         END                                                            09084000
      ELSE                                                              09086000
         RECDISP:=RECDISP-1;                                            09088000
                                                                        09090000
      << FIND STT LENGTH >>                                             09092000
                                                                        09094000
      FREADDIR(FNUM,BUF,128,DOUBLE(CURSEG'TEMPREC));                    09096000
      CHECKIPMAPIO;                                                     09098000
      STTLEN:=INTEGER(BUF(RECDISP).(8:8))+1;                            09100000
                                                                        09102000
      << FIND PATCH SIZE >>                                             09104000
                                                                        09106000
      ADJUSTRECDISP(STTLEN);                                            09108000
      FREADDIR(FNUM,BUF,128,DOUBLE(CURSEG'TEMPREC));                    09110000
      CHECKIPMAPIO;                                                     09112000
      PATCHLEN:=INTEGER(BUF(RECDISP))+1;                                09114000
                                                                        09116000
      << FIND PATCH AREA >>                                             09118000
                                                                        09120000
      ADJUSTRECDISP(PATCHLEN);                                          09122000
      IF RECDISP < 127 THEN                                             09124000
         BEGIN                                                          09126000
            FREADDIR(FNUM,BUF,128,DOUBLE(CURSEG'TEMPREC-1));            09128000
            CHECKIPMAPIO;                                               09130000
            MOVE BUF:=BUF(RECDISP+1),(127-RECDISP);                     09132000
         END;                                                           09134000
      FREADDIR(FNUM,BUF(127-RECDISP),RECDISP+1,                         09136000
               DOUBLE(CURSEG'TEMPREC));                                 09138000
      CHECKIPMAPIO;                                                     09140000
      PA'CHECKSUM:=BUF(123);                                            09142000
      MOVE PA'SEGNAMELA:=BUF(114),(8);                                  09144000
   END;                                                                 09146000
$PAGE "GETCKSUMBYNAME"                                                  09148000
   SUBROUTINE GETCKSUMBYNAME(NUMSEGS);                                  09150000
                                                                        09152000
   VALUE NUMSEGS;                                                       09154000
   INTEGER NUMSEGS;                                                     09156000
                                                                        09158000
   BEGIN                                                                09160000
      SEGNUM := 0;                                                      09162000
      WHILE SEGNUM < NUMSEGS DO                                         09164000
         BEGIN                                                          09166000
            GETSEGMENT(SEGNUM);                                         09168000
            IF FILECODE = SLFILECODE THEN                               09170000
               IF MATCHNAME(SLREF'SEGNAME0,SEGNAME) AND                 09172000
                  NOT SLREF'DELETED THEN                                09174000
                  BEGIN                                                 09176000
                     IF NOT SLREF'CKSUMOK THEN                          09178000
                        BEGIN                                           09180000
                           STATUS:=STAT'NOCKSUM;                        09182000
                           RETURN;                                      09184000
                        END;                                            09186000
                     GETPATCHAREA;                                      09188000
                     CHECKSUM:=PA'CHECKSUM;                             09190000
                     RETURN;                                            09192000
                  END                                                   09194000
               ELSE                                                     09196000
            ELSE                                                        09198000
               BEGIN                                                    09200000
                  GETPATCHAREA;                                         09202000
                  IF MATCHNAME(PA'SEGNAME,SEGNAME) THEN                 09204000
                     BEGIN                                              09206000
                        CHECKSUM := PA'CHECKSUM;                        09208000
                        RETURN;                                         09210000
                     END;                                               09212000
               END;                                                     09214000
            SEGNUM := SEGNUM + 1;                                       09216000
         END;                                                           09218000
      STATUS:=STAT'SEGNOTFOUND;                                         09220000
   END;                                                                 09222000
$PAGE "GETCKSUMBYNUM"                                                   09224000
   SUBROUTINE GETCKSUMBYNUM(NUMSEGS);                                   09226000
                                                                        09228000
   VALUE NUMSEGS;                                                       09230000
   INTEGER NUMSEGS;                                                     09232000
                                                                        09234000
   BEGIN                                                                09236000
      IF NOT ( 0 <= SEGNUM <= NUMSEGS-1 ) THEN                          09238000
         BEGIN                                                          09240000
            STATUS:=STAT'BADSEGNUM;                                     09242000
            RETURN;                                                     09244000
         END;                                                           09246000
      GETSEGMENT(SEGNUM);                                               09248000
      IF FILECODE = SLFILECODE THEN                                     09250000
         BEGIN                                                          09252000
            IF SLREF'DELETED THEN                                       09254000
               BEGIN                                                    09256000
                  STATUS:=STAT'BADSEGNUM;                               09258000
                  RETURN;                                               09260000
               END;                                                     09262000
            IF SEGNAMESPECIFIED THEN                                    09264000
               IF NOT MATCHNAME(SLREF'SEGNAME0,SEGNAME) THEN            09266000
                  BEGIN                                                 09268000
                     STATUS:=STAT'UNMATCH;                              09270000
                     RETURN;                                            09272000
                  END;                                                  09274000
            IF NOT SLREF'CKSUMOK THEN                                   09276000
               BEGIN                                                    09278000
                  STATUS:=STAT'NOCKSUM;                                 09280000
                  RETURN;                                               09282000
               END;                                                     09284000
         END;                                                           09286000
      GETPATCHAREA;                                                     09288000
      IF SEGNAMESPECIFIED AND FILECODE = PROGFILECODE THEN              09290000
         IF NOT MATCHNAME(PA'SEGNAME,SEGNAME) THEN                      09292000
            BEGIN                                                       09294000
               STATUS:=STAT'UNMATCH;                                    09296000
               RETURN;                                                  09298000
            END;                                                        09300000
      CHECKSUM:=PA'CHECKSUM;                                            09302000
   END;                                                                 09304000
$PAGE "CHECKSUM INTRINSIC - MAIN"                                       09306000
   STATUS:=STAT'OK;                                                     09308000
   IF (PARMS <> %(2)11111) AND                                          09310000
      (PARMS <> %(2)11011) AND                                          09312000
      (PARMS <> %(2)10111) THEN                                         09314000
      BEGIN                                                             09316000
         STATUS := STAT'BADPARMS;                                       09318000
         RETURN;                                                        09320000
      END;                                                              09322000
   FGETINFO(FNUM,,,AOPTION,,,,,FILECODE);                               09324000
   IF FILECODE <> PROGFILECODE AND                                      09326000
      FILECODE <> SLFILECODE THEN                                       09328000
      BEGIN                                                             09330000
         STATUS := STAT'BADFILE;                                        09332000
         RETURN;                                                        09334000
      END;                                                              09336000
   IF 1 <= INTEGER(AOPTION.(12:4)) <= 3 THEN                            09338000
      BEGIN                                                             09340000
         STATUS := STAT'BADFOPEN;                                       09342000
         RETURN;                                                        09344000
      END;                                                              09346000
   SLREFLOADED:=FALSE;                                                  09348000
   IF FILECODE = PROGFILECODE THEN                                      09350000
      BEGIN                                                             09352000
         FREADDIR(FNUM,PF0LP,128,0D);                                   09354000
         CHECKIPMAPIO;                                                  09356000
         IF NOT PF0'CKSUMOK THEN                                        09358000
            BEGIN                                                       09360000
               STATUS:=STAT'NOCKSUM;                                    09362000
               RETURN;                                                  09364000
            END;                                                        09366000
         FREADDIR(FNUM,PF0LP(128),128,1D);                              09368000
         CHECKIPMAPIO;                                                  09370000
         @SEGDESC:=@PF0P(28+(PF0'NUMSEGS+1)/2);                         09372000
         CURSEG'REC:=PF0'FIRSTSEGDRECNUM;                               09374000
         CURSEG'NUM:=0;                                                 09376000
         CURSEG'LEN:=SEGDESC(CURSEG'NUM).(2:14);                        09378000
                                                                        09380000
         IF SEGNUMSPECIFIED THEN                                        09382000
            IF SEGNUM=-1 THEN                                           09384000
               BEGIN                                                    09386000
                  IF SEGNAMESPECIFIED THEN                              09388000
                     BEGIN                                              09390000
                        STATUS := STAT'UNMATCH;                         09392000
                        RETURN;                                         09394000
                     END;                                               09396000
                  CHECKSUM := PF0'TOTALCKSUM;                           09398000
               END                                                      09400000
            ELSE                                                        09402000
               GETCKSUMBYNUM(PF0'NUMSEGS)                               09404000
         ELSE  << SEGNAME SPECIFIED >>                                  09406000
            GETCKSUMBYNAME(PF0'NUMSEGS);                                09408000
      END                                                               09410000
   ELSE  << SL FILE >>                                                  09412000
      BEGIN                                                             09414000
         FREADDIR(FNUM,SL0P,12,0D);                                     09416000
         CHECKIPMAPIO;                                                  09418000
         FREADDIR(FNUM,SLREFBLOCKDRECNUM,64,1D);                        09420000
         CHECKIPMAPIO;                                                  09422000
         IF SEGNUMSPECIFIED THEN                                        09424000
            GETCKSUMBYNUM(SL0'NUMSEGSALLOC)                             09426000
         ELSE  << SEGNAME SPECIFIED >>                                  09428000
            GETCKSUMBYNAME(SL0'NUMSEGSALLOC);                           09430000
      END;                                                              09432000
END;                                                                    09434000
$CONTROL SEGMENT=MAIN                                                   09436000
END.                                                                    09438000
