$CONTROL USLINIT,CODE,MAP                                               00010000
<<SPOOK>>                                                      <<00897>>00012000
<< HP32002C MPE SOURCE C.00.00 >>                                       00014000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00016000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00018000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00020000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00022000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00024000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00026000
$CONTROL PRIVILEGED                                                     00028000
$CONTROL MAIN=SPOOK                                                     00030000
<<*************************************>>                               00032000
<<  SPOOK    VERSION C.00.02           >>                      <<02724>>00034000
<<*************************************>>                               00036000
                                                                        00038000
 << NOTE : CHANGE VERSION # IN MESSAGE >>                               00040000
                                                               <<04145>>00042000
<<**********************************************************>> <<04145>>00044000
<<                                                          >> <<04145>>00046000
<<                FIX  INFORMATION                          >> <<04145>>00048000
<<                                                          >> <<04145>>00050000
<< For each fix submitted, please describe                  >> <<04145>>00052000
<< the fix and date below.                                  >> <<04145>>00054000
<<**********************************************************>> <<04145>>00056000
                                                               <<04145>>00058000
<<**********************************************************>> <<04145>>00060000
<<  Fixed a variety of SR's against SPOOK.  Also added a few>> <<04145>>00062000
<< minor enhancements in FIND and in the way SPOOK handles  >> <<04145>>00064000
<< file error conditions.  Also added a lot of comments,    >> <<04145>>00066000
<< please do the same!!                                     >> <<04145>>00068000
<<**********************************************************>> <<04145>>00070000
                                                               <<04145>>00072000
                                                                        00074000
BEGIN                                                                   00076000
   DEFINE                                                      <<01.02>>00078000
BAD'RENAME                                                     <<04145>>00080000
=("UNABLE TO RENAME COPY FILE")#,                              <<04145>>00082000
PRINTFILE                                                      <<04145>>00084000
= ("FILE                             ALREADY EXISTS")#,        <<04145>>00086000
REPLACEFILE                                                    <<04145>>00088000
= ("DO YOU WANT TO REPLACE IT?(Y/N)")#,                        <<04145>>00090000
RENAMEFILE                                                     <<B0.01>>00092000
= ("ENTER NEW NAME OR CARRIAGE RETURN (PURGE)")#,              <<B0.01>>00094000
RENAMED'MESSAGE                                                <<B0.01>>00096000
= ("COPY FILE HAS BEEN RENAMED")#,                             <<B0.01>>00098000
PTITLE = ("SPOOK4 V.UU.FF  (C) HEWLETT-PACKARD CO., 1983")#;   <<xd.m4>>00100000
EQUATE VUUFF'COL = 7;  << Index into PTITLE for V.UU.FF     >> <<xd.m4>>00102000
$INCLUDE INCLVUF                                               <<04151>>00104000
                                                                        00106000
$SET X8=ON                                                              00108000
<<$INCLUDE INCLLDT5>>                                          <<ld.m4>>00110000
<<      MPE4 LDT include file follows                       >>          00112000
$PAGE "MPE TABLE ACCESS:  LDT, DCT, LDTX"                               00114000
COMMENT                                                                 00116000
<<**********************************************************>>          00118000
<<*                                                        *>>          00120000
<<*                 INCLLDT - Module C0                    *>>          00122000
<<*            (contains LDT, DCT and LDTX)                *>>          00124000
<<*                    MPE 4 version                       *>>          00126000
<<*                                                        *>>          00128000
<<**********************************************************>>          00130000
                                                                        00132000
$IF X8 = OFF                                                            00134000
$CONTROL NOLIST                                                         00136000
$IF                                                                     00138000
$TITLE "MPE TABLE ACCESS:  LOGICAL DEVICE TABLE (LDT)"                  00140000
                                                                        00142000
                   Overview of Device Tables                            00144000
                   -------------------------                            00146000
                                                                        00148000
DST 14 (= %16)   +---------------------------+<-----DST %16             00150000
SIR 10 (= %12)   |                           |                          00152000
                 |   Logical Device Table    |                          00154000
                 |                           |                          00156000
                 |          (LDT)            |                          00158000
                 |                           |                          00160000
                 +---------------------------+                          00162000
                 |                           |                          00164000
                 |    Device Class Table     |                          00166000
                 |                           |                          00168000
                 |          (DCT)            |                          00170000
                 |                           |                          00172000
                 +---------------------------+                          00174000
                 |                           |                          00176000
                 |   Logical Device Table    |                          00178000
                 |         Extension         |                          00180000
                 |          (LDTX)           |                          00182000
                 |                           |                          00184000
                 +---------------------------+                          00186000
                                                                        00188000
                                                                        00190000
               LOGICAL DEVICE TABLE                                     00192000
               --------------------                                     00194000
                                                                        00196000
                Zero Entry Format                                       00198000
                -----------------                                       00200000
                                                                        00202000
   0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                       00204000
 +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                      00206000
0|    Highest entry #    |     Entry size = 5    |                      00208000
 +-----------------------+-----------------------+                      00210000
 |      Pointer to first Device Class entry      |                      00212000
1|          (relative to segment base)           |                      00214000
 +-----------------------------------------------+                      00216000
2|        Number of Device Class entries         |                      00218000
 +-----------------------------------------------+                      00220000
3|          Size of Device Class Table           |                      00222000
 +-----------------------------------------------+                      00224000
4|///////////////////////| Streams device number |                      00226000
 +-----------------------------------------------+                      00228000
$PAGE                                                                   00230000
               Typical Entry Format                                     00232000
               --------------------                                     00234000
                                                                        00236000
   0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                       00238000
 +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                      00240000
 |                File use count                 |0                     00242000
 +-----------------------+-----------------------+                      00244000
 |Vol table index if dev |                       |                      00246000
 |  type = 0-7, otherwise|     CONTROL-Y pin     |1                     00248000
 |  main process pin #   |                       |                      00250000
 |  or dev's spooler pin |                       |                      00252000
 +-----------------------+-----------------------+                      00254000
 |     Record width      |CS|FO|  Device type    |2                     00256000
 +-----+--+--+--+--+--+--+-----------------------+                      00258000
 |Spool|Sy|Di|Dn|Tr|Hd|Cl| Default output device |                      00260000
 |state|st|ag|Rq|lr|r |as|  or class index (C=1) |3                     00262000
 +-----+--+--+--+--+--+--+-----------------------+                      00264000
 |                    |S |    XDD head entry     |                      00266000
 |        Misc        | Q|        pointer        |4                     00268000
 +--------------------+--+-----------------------+                      00270000
                                                                        00272000
Discussion:                                                             00274000
  Word 2.(8:1) -- Communication system device if set.                   00276000
  Word 2.(9:1) -- If set, there are special forms  mounted  on          00278000
                  the device.                                           00280000
  Word 3.(0:2) -- Spooled state of the device:                          00282000
                  0 -- Not spooled.                                     00284000
                  1 -- Owned by an input  spooler.                      00286000
                  2 -- Owned by an output spooler.                      00288000
  Word 3.(2:1) -- Device is available to system (not down).             00290000
  Word 3.(3:1) -- Device is available to diagnostics (obs).             00292000
  Word 3.(4:1) -- :DOWN requested, honored when use count = 0.          00294000
  Word 3.(5:1) -- If set, trailers are disabled.                        00296000
  Word 3.(6:1) -- If set, headers are disabled. These two bits          00298000
                  are managed such  that  header/trailers  are          00300000
                  generated in pairs or not at all.                     00302000
  Word 3.(7:1) -- If set, word 3.(8:8) is the DCT index of the          00304000
                  default output class  associated  with  this          00306000
                  device.  If  clear,  word 3.(8:8) is the de-          00308000
                  fault logical output device number associat-          00310000
                  ed with this device.                                  00312000
  Word 4.(0:7) -- Device dependent information:                         00314000
                  1.  For terminal-like devices,  the  default          00316000
                      terminal  type  to be used if not speci-          00318000
                      fied in the :HELLO command.                       00320000
                  2.  For variable density tape drives:                 00322000
      Word 4.(1:3) -- actual tape density:                              00324000
                      0 = density not yet determined.                   00326000
                      1 = 1600 BPI                                      00328000
                      2 = 6250 BPI                                      00330000
      Word 4.(4:3) -- density requested in FOPEN for writes to          00332000
                      unlabelled tapes only:                            00334000
                      0 = no FOPEN with write access yet.               00336000
                      1 = 1600 BPI                                      00338000
                      2 = 6250 BPI                                      00340000
  Word 4.(7:1) -- Spooling has been enabled (spool queues  are          00342000
                  open) for this device.                                00344000
$PAGE                                                                   00346000
$IF X8 = OFF                                                            00348000
$CONTROL LIST                                                           00350000
$IF                                                                     00352000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              00354000
             |  Declarations start here  |                              00356000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              00358000
                                                                        00360000
Conventions used in the declarations:                                   00362000
1.  We presume the existence of the following identifiers:              00364000
  a)  A logical array or pointer, LDT.                                  00366000
  b)  An offset integer LDT'INDEX, normally  set  to  LDEV#  *          00368000
      LDT'ENTRY'SIZE.                                                   00370000
    The LDT array (pointer) can be direct, indirect,  DB-rela-          00372000
    tive  or  Q-relative.  If  DB-relative, make sure you know          00374000
    where DB is before you use it.                                      00376000
      Setting LDT'INDEX as above allows you to do segment-rel-          00378000
    ative LDT accesses.  If you prefer to make a local copy of          00380000
    an LDT entry via MFDS/MTDS, or if you have  existing  code          00382000
    which does this, simply set LDT'INDEX := 0.                         00384000
2.  Each DEFINE is prefixed by LDT'... to distinguish it  from          00386000
    references to other MPE tables.                                     00388000
3.  DEFINEs of fields are  listed  alphabetically  for  easier          00390000
    lookup without using XREF. DEFINEs of states of fields are          00392000
    listed sequentially following the field DEFINE.                     00394000
;                                                                       00396000
EQUATE                                                                  00398000
   LDT'DST                = %16,           << = 14(10)      >>          00400000
   LDT'SIR                = %12,           << = 10(10)      >>          00402000
   LDT'MPE'VERSION        =   4;                                        00404000
                                                                        00406000
<< The following EQUATE must be changed if the length of an >>          00408000
<< LDT entry changes.                                       >>          00410000
                                                                        00412000
EQUATE                                                                  00414000
   SIZE'OF'LDT'ENTRY      =   5;                                        00416000
                                                                        00418000
<< LDT header (zero'th) entry fields.  Be sure to check the >>          00420000
<< LDTX portion of this $INCLUDE file  if  you  change  the >>          00422000
<< symbol names in this section.                            >>          00424000
                                                                        00426000
DEFINE                                                                  00428000
   LDT'DCT'BASE          = LDT(1)         #,                            00430000
   LDT'DCT'SIZE          = LDT(3)         #,                            00432000
   LDT'ENTRY'SIZE        = LDT(0).( 8:8)  #,                            00434000
   LDT'NUM'DCT'ENTRIES   = LDT(2)         #,                            00436000
   LDT'NUM'ENTRIES       = LDT(0).( 0:8)  #,                            00438000
   LDT'STREAMS'LDEV      = LDT(4).( 8:8)  #;                            00440000
$PAGE                                                                   00442000
<<               Fields for a typical LDT entry.            >>          00444000
DEFINE                                                                  00446000
   LDT'ACCESS'TYPE        = LDT(LDT'INDEX+2).(10:3) #,                  00448000
       LDT'DIRECT'ACCESS  = 0                       #,                  00450000
       LDT'SERIAL'IN      = 1                       #,                  00452000
       LDT'IO'CONCURRENT  = 2                       #,                  00454000
       LDT'IO'NONCONCUR   = 3                       #,                  00456000
       LDT'SERIAL'OUT     = 4                       #,                  00458000
   LDT'ACTUAL'TAPE'DENS   = LDT(LDT'INDEX+4).( 1:3) #,                  00460000
       LDT'NO'DENSITY     = 0                       #,                  00462000
       LDT'DENSITY'1600   = 1                       #,                  00464000
       LDT'DENSITY'6250   = 2                       #,                  00466000
   LDT'AVAIL'TO'DIAG      = LDT(LDT'INDEX+3).( 3:1) #,                  00468000
   LDT'AVAIL'TO'SYS       = LDT(LDT'INDEX+3).( 2:1) #,                  00470000
   LDT'CLASS'INDEX        = LDT(LDT'INDEX+3).( 7:1) #,                  00472000
   LDT'CONTROL'Y'PIN      = LDT(LDT'INDEX+1).( 8:8) #,                  00474000
   LDT'CS'DEVICE          = LDT(LDT'INDEX+2).( 8:1) #,                  00476000
   LDT'DEVICE'TYPE        = LDT(LDT'INDEX+2).(10:6) #,                  00478000
       LDT'13037'DISC     =  0                      #,                  00480000
       LDT'FLOPPY'DISC    =  2                      #,                  00482000
       LDT'CS80'DEVICE    =  3                      #,                  00484000
       LDT'FOREIGN'DISC   =  7                      #,                  00486000
       LDT'CARD'READER    =  8                      #,                  00488000
       LDT'TERMINAL       = 16                      #,                  00490000
       LDT'READER'PUNCH   = 20                      #,                  00492000
       LDT'MAG'TAPE       = 24                      #,                  00494000
       LDT'SERIAL'DISC    = 31  << = %37 >>         #,                  00496000
       LDT'PRINTER        = 32                      #,                  00498000
       LDT'CARD'PUNCH     = 33                      #,                  00500000
       LDT'PLOTTER        = 35                      #,                  00502000
   LDT'DFLT'OUT'CLASS     = LDT(LDT'INDEX+3).( 8:8) #,                  00504000
   LDT'DFLT'OUT'DEV       = LDT(LDT'INDEX+3).( 8:8) #,                  00506000
   LDT'DFLT'TERM'TYPE     = LDT(LDT'INDEX+4).( 0:7) #,                  00508000
   LDT'DOWN'PENDING       = LDT(LDT'INDEX+3).( 4:1) #,                  00510000
   LDT'FILE'USE'CNT       = LDT(LDT'INDEX+0)        #,                  00512000
   LDT'HEADER             = LDT(LDT'INDEX+3).( 6:1) #,                  00514000
   LDT'HEADER'OFF         = LDT'HEADER              #,                  00516000
   LDT'HEADER'ON          = NOT LDT'HEADER          #,                  00518000
   LDT'HEADER'TRAILER     = LDT(LDT'INDEX+3).( 5:2) #,                  00520000
   LDT'MAIN'PIN           = LDT(LDT'INDEX+1).( 0:8) #,                  00522000
   LDT'RECORD'WIDTH       = LDT(LDT'INDEX+2).( 0:8) #,                  00524000
   LDT'RQST'TAPE'DENS     = LDT(LDT'INDEX+4).( 4:3) #,                  00526000
       << See values under LDT'ACTUAL'TAPE'DENS. >>                     00528000
   LDT'SPECIAL'FORMS      = LDT(LDT'INDEX+2).( 9:1) #,                  00530000
   LDT'SPOOL'QUEUES       = LDT(LDT'INDEX+4).( 7:1) #,                  00532000
       LDT'QOPEN          = 1                       #,                  00534000
       LDT'QSHUT          = 0                       #,                  00536000
   LDT'SPOOL'STATE        = LDT(LDT'INDEX+3).( 0:2) #,                  00538000
       LDT'NOT'SPOOLED    = 0                       #,                  00540000
       LDT'INPUT'SPOOLED  = 1                       #,                  00542000
       LDT'OUTPUT'SPOOLED = 2                       #,                  00544000
   LDT'SPOOLER'PIN        = LDT(LDT'INDEX+1).( 0:8) #,                  00546000
   LDT'TRAILER            = LDT(LDT'INDEX+3).( 5:1) #,                  00548000
   LDT'TRAILER'OFF        = LDT'TRAILER             #,                  00550000
   LDT'TRAILER'ON         = NOT LDT'TRAILER         #,                  00552000
   LDT'VOLUME'TBL'INDEX   = LDT(LDT'INDEX+1).( 0:8) #,                  00554000
   LDT'XDD'HEAD'ENTRY'PTR = LDT(LDT'INDEX+4).( 8:8) #;                  00556000
$PAGE "MPE TABLE ACCESS:  DEVICE CLASS TABLE (DCT)"                     00558000
COMMENT                                                                 00560000
$IF X8 = OFF                                                            00562000
$CONTROL NOLIST                                                         00564000
$IF                                                                     00566000
                    DEVICE CLASS TABLE                                  00568000
                                                                        00570000
                   Typical Entry Format                                 00572000
                   --------------------                                 00574000
                                                                        00576000
       0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                   00578000
     +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                  00580000
    0|                                               |                  00582000
     |                                               |                  00584000
    1|                                               |                  00586000
     |              Class name (ASCII)               |                  00588000
    2|                                               |                  00590000
     |                                               |                  00592000
    3|                                               |                  00594000
     +--+--------------------+--+--+-----------------+                  00596000
    4|//|  Cyclical pointer  |SQ| T|Class Access Type|                  00598000
     +--+--------------------+--+--+-----------------+                  00600000
    5| # devices in class (N)|        LDEV #1        |                  00602000
     +-----------------------+-----------------------+                  00604000
     |        LDEV #2        |       LDEV #3         |                  00606000
     +-----------------------+-----------------------+                  00608000
                 .                      .                               00610000
                 .                      .                               00612000
                 .                      .                               00614000
     +-----------------------+-----------------------+                  00616000
N/2+5|       LDEV #N-1       |       LDEV #N         |                  00618000
     +-----------------------+-----------------------+                  00620000
                                                                        00622000
Discussion:                                                             00624000
  The Device Class Table (DCT) contains a  varying  number  of          00626000
variable length entries.  This is because you may configure an          00628000
arbitrary number of device classes on a system, and  each  de-          00630000
vice  class may be comprised of an arbitrary number of logical          00632000
devices. There is one DCT entry per device class, and each DCT          00634000
entry contains a list of logical devices in the  class.  There          00636000
is no established order of entries in the DCT, nor is there an          00638000
order of LDEVs within an entry.                                         00640000
  Due to the haphazard nature of the DCT, its overall  proper-          00642000
ties  are kept in the 0th (master) entry of the Logical Device          00644000
Table (see above). These include the segment-relative starting          00646000
address of the DCT, the number of entries in the table and the          00648000
size in words of the DCT area of the segment. This latter word          00650000
is useful for skipping over the DCT entirely when all you want          00652000
is to access the Logical Device Table  Extension  (LDTX)  (see          00654000
below).  When  you ARE interested in a DCT entry, the variable          00656000
size of each entry means that you must always start at the be-          00658000
ginning of the DCT and link through each entry until you  find          00660000
the one you're interested in.                                           00662000
$PAGE                                                                   00664000
  A few of the fields in the DCT require further description:           00666000
  Word 4.( 1:7) -- Cyclical pointer.  Currently used only  for          00668000
                   system and private volume disc devices. The          00670000
                   pointer varies from 1 to N (number  of  en-          00672000
                   tries in the class) and indicates the LDEV#          00674000
                   in the class list on which the last  extent          00676000
                   was  allocated.  The  disc space allocation          00678000
                   routines will try to satisfy the  next  re-          00680000
                   quest  on  the next disc drive indicated by          00682000
                   the cyclical pointer (with wraparound to  1          00684000
                   if  the  pointer  > N).  If that fails, the          00686000
                   pointer is incremented until space is found          00688000
                   or all  devices  in  the  class  have  been          00690000
                   tried.                                               00692000
  Word 4.( 8:1) -- If set, spooling has  been  enabled  (spool          00694000
                   queues opened) for this device class.                00696000
  Word 4.( 9:1) -- If set, the class is a terminal type class.          00698000
  Word 4.(10:6) -- Usually the same as the device type  repre-          00700000
                   sented  by  the  class  (0 for disc, 24 for          00702000
                   tape, 32 for printer,  etc.).  Serial  disc          00704000
                   classes  are  disc devices accessed as tape          00706000
                   drives, so their true device types are kept          00708000
                   in the LDT, while this field holds  a  spe-          00710000
                   cial type (31, or %37), indicating a serial          00712000
                   I/O (non-concurrent) device.  Similarly,  a          00714000
                   foreign disc is a NON-shareable disc drive,          00716000
                   so that fact is reflected by a special type          00718000
                   7 in this field, even though the true hard-          00720000
                   ware type is kept in the LDT, as for serial          00722000
                   discs.                                               00724000
$PAGE                                                                   00726000
$IF X8 = OFF                                                            00728000
$CONTROL LIST                                                           00730000
$IF                                                                     00732000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              00734000
             |  Declarations start here  |                              00736000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              00738000
                                                                        00740000
Conventions used in the declarations:                                   00742000
1.  We presume the existence of the following  logical  arrays          00744000
    or pointers:                                                        00746000
  a)  DCT'B -- byte array equivalent of  DCT  for  referencing          00748000
               the class name or LDEV list.                             00750000
  b)  DCT   -- for referencing any other field of an entry.             00752000
    The arrays (pointers) can be direct, indirect, DB-relative          00754000
    or Q-relative. If DB-relative, make sure you know where DB          00756000
    is before you use them.  The only time you have to  expli-          00758000
    citly reference them is when you declare them and when you          00760000
    set their starting address.  Thereafter the DEFINEs  below          00762000
    will  implicitly reference them.  You must use the DEFINEs          00764000
    though.                                                             00766000
2.  Prefixes in the DEFINEs are:                                        00768000
  a)  DCTB -- when referencing the byte array DCT'B.                    00770000
  b)  DCT  -- when referencing the logical array DCT.                   00772000
3.  Within the DEFINEs, symbols are given  alphabetically  for          00774000
    easier lookup without using XREF.                                   00776000
;                                                                       00778000
EQUATE                                                                  00780000
   DCT'MPE'VERSION    =  4;                                             00782000
                                                                        00784000
EQUATE                                                                  00786000
   DCT'FIRST'LDEV     = 11;   << Entry-rltv byte of LDEV #1 >>          00788000
                                                                        00790000
DEFINE                                                                  00792000
   DCT'CLASS'ACC'TYPE = DCT(4).(10:6)        #,                         00794000
   DCT'CYCLICAL'PTR   = DCT(4).( 1:7)        #,                         00796000
   DCT'NEXT'ENTRY     = DCT'NUM'DEVICES/2 + 6#,                         00798000
   DCT'NUM'DEVICES    = DCT(5).( 0:8)        #,                         00800000
   DCT'SPOOL'QUEUES   = DCT(4).( 8:1)        #,                         00802000
       DCT'OPEN       = 1                    #,                         00804000
       DCT'SHUT       = 0                    #,                         00806000
   DCT'TERM'CLASS     = DCT(4).( 9:1)        #,                         00808000
   DCT'WORDS'IN'ENTRY = DCT'NEXT'ENTRY       #,                         00810000
   DCTB'CLASS'NAME    = DCT'B(0)             #;                         00812000
$PAGE "MPE TABLE ACCESS:  LOGICAL DEVICE TABLE EXTENSION (LDTX)"        00814000
COMMENT                                                                 00816000
$IF X8 = OFF                                                            00818000
$CONTROL NOLIST                                                         00820000
$IF                                                                     00822000
                                                                        00824000
                                                                        00826000
            Logical Device Table Extension (LDTX)                       00828000
            -------------------------------------                       00830000
                                                                        00832000
                         Zero entry                                     00834000
                         ----------                                     00836000
                                                                        00838000
        0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                  00840000
      +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                 00842000
    0 |    Highest entry #    |    Entry size = 5     |                 00844000
      +-----------------------+-----------------------+                 00846000
    1 |///////////////////////////////////////////////|                 00848000
      +-----------------------------------------------+                 00850000
    2 |///////////////////////////////////////////////|                 00852000
      +-----------------------------------------------+                 00854000
    3 |///////////////////////////////////////////////|                 00856000
      +-----------------------------------------------+                 00858000
    4 |///////////////////////////////////////////////|                 00860000
      +-----------------------------------------------+                 00862000
                                                                        00864000
                                                                        00866000
                         Typical entry                                  00868000
                         -------------                                  00870000
                                                                        00872000
        0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                  00874000
      +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                 00876000
    0 | S|SD|CP|FS|   Reserved   |  Device-specific   |                 00878000
      +--+--+--+--+--+-----------+                    |                 00880000
    1 |                 information                   |                 00882000
      +-------                                 -------+                 00884000
    2 |                   fields.                     |                 00886000
      +-------                                 -------+                 00888000
    3 |           See the following LDTX              |                 00890000
      +-------                                 -------+                 00892000
    4 |            descriptor examples.               |                 00894000
      +-----------------------------------------------+                 00896000
                                                                        00898000
Where:                                                                  00900000
                                                                        00902000
S.....Seek ahead enable/disable flag (system or PV disc only).          00904000
SD....This logical device is a Serial Disc or a Foreign Disc.           00906000
CP....This logical device uses the CIPER protocol.                      00908000
FS....This is a system or PV disc with Disc Free Space                  00910000
      management.                                                       00912000
$PAGE                                                                   00914000
                        Terminal entry                                  00916000
                        --------------                                  00918000
                                                                        00920000
        0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                  00922000
      +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                 00924000
    0 | 0| 0| 0| 0|     Reserved    |      TBRC       |                 00926000
      +--+--+--+--+-----------------+-----------------+                 00928000
    1 |///////////////////////////////////////////////|                 00930000
      +--+--------------------------------------------+                 00932000
    2 |LX|////////////////////////////////////////////|                 00934000
      +--+--------------------------------------------+                 00936000
    3 |///////////////////////////////////////////////|                 00938000
      +-----------------------------------------------+                 00940000
    4 |///////////////////////////////////////////////|                 00942000
      +-----------------------------------------------+                 00944000
                                                                        00946000
TBRC..Terminal's baud rate code (CPS = characters per second).          00948000
                                                                        00950000
Speed (CPS)   ATC (II/III) TBRC      ADCC/ATP (HPIB) TBRC               00952000
-----------   -----------------      --------------------               00954000
                                                                        00956000
Not known             0                        0                        00958000
  1920               ---                      16 (ATP only)             00960000
   960               ---                       8                        00962000
   480               ---                       9                        00964000
   240                1                        7                        00966000
   120                2                       11                        00968000
    60                3                        6                        00970000
    30                4                       13                        00972000
    15                5                       14                        00974000
    14                7                       ---                       00976000
    10                6                       15                        00978000
                                                                        00980000
LX....This terminal is connected to a LYNXII port.                      00982000
                                                                        00984000
                Serial or Foreign Disc entry                            00986000
                ----------------------------                            00988000
                                                                        00990000
        0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                  00992000
      +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                 00994000
    0 | 0| 1| 0| 0|     Reserved    |/////////////////|                 00996000
      +--+--+--+--+-----------------+-----------------+                 00998000
    1 |     SDISC:  XDS# for variables, Gap Table     |                 01000000
      |     FDISC:  1                                 |                 01002000
      +-----------------------------------------------+                 01004000
    2 |     SDISC:  1 ==> data buffer XDS's acquired  |                 01006000
      |     FDISC:  not used.                         |                 01008000
      +-----------------------------------------------+                 01010000
    3 |///////////////////////////////////////////////|                 01012000
      +-----------------------------------------------+                 01014000
    4 |///////////////////////////////////////////////|                 01016000
      +-----------------------------------------------+                 01018000
$PAGE                                                                   01020000
                          CIPER entry                                   01022000
                          -----------                                   01024000
                                                                        01026000
        0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                  01028000
      +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                 01030000
    0 | 0| 0| 1| 0|   Reserved   |DB|/////////////////|                 01032000
      +--+--+--+--+--------------+--+-----------------+                 01034000
    1 |  CIPER Device Control Data Segment # (CDCDS)  |                 01036000
      +--+--------------------------------------------+                 01038000
    2 |DN|      CTM Index for this device (CTMI)      |                 01040000
      +--+--------------------------------------------+                 01042000
    3 |///////////////////////////////////////////////|                 01044000
      +-----------------------------------------------+                 01046000
    4 |///////////////////////////////////////////////|                 01048000
      +-----------------------------------------------+                 01050000
                                                                        01052000
DB.....If set to 1, then debugging is in effect.                        01054000
DN.....If 1, the CIPER facility has been de-activated for this          01056000
       device because of error.                                         01058000
CTMI...Control Table Map Index (an index into the Control               01060000
       Table Map (CTM), which is located in the CDCDS.                  01062000
                                                                        01064000
                                                                        01066000
            System or Private Volume Disc entry                         01068000
            -----------------------------------                         01070000
                                                                        01072000
        0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                  01074000
      +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                 01076000
    0 | S| 0| 0| 1|     Reserved    |/////////////////|                 01078000
      +--+--+--+--+-----------------+-----------------+                 01080000
    1 |///////////////////////////////////////////////|                 01082000
      +-----------------------------------------------+                 01084000
    2 |      Disc Free Space DST number (DFSDST)      |                 01086000
      +-----------------------------------------------+                 01088000
    3 |     Disc Free Space error status (DFSERR)     |                 01090000
      +-----------------------------------------------+                 01092000
    4 |///////////////////////////////////////////////|                 01094000
      +-----------------------------------------------+                 01096000
                                                                        01098000
S......Seek ahead enable/disable flag.                                  01100000
$PAGE                                                                   01102000
$IF X8 = OFF                                                            01104000
$CONTROL LIST                                                           01106000
$IF                                                                     01108000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              01110000
             |  Declarations start here  |                              01112000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              01114000
                                                                        01116000
Conventions used in the declarations:                                   01118000
1.  We presume the existence of the following identifiers:              01120000
  a)  A logical array or pointer, LDTX.                                 01122000
  b)  An offset integer LDTX'INDEX, normally set  to  LDEV#  *          01124000
      LDTX'ENTRY'SIZE.                                                  01126000
    The LDTX array (pointer) can be direct, indirect, DB-rela-          01128000
    tive  or  Q-relative.  If  DB-relative, make sure you know          01130000
    where DB is before you use it.                                      01132000
      Setting LDTX'INDEX as above allows you  to  do  segment-          01134000
    relative LDTX accesses. If you prefer to make a local copy          01136000
    of an LDTX entry via MFDX/MTDS, or if  you  have  existing          01138000
    code which does this, simply set LDTX'INDEX := 0.                   01140000
2.  Each DEFINE is prefixed by LDTX'... to distinguish it from          01142000
    references to other MPE tables.                                     01144000
3.  DEFINEs of fields are  listed  alphabetically  for  easier          01146000
    lookup without using XREF. DEFINEs of states of fields are          01148000
    listed sequentially following the field DEFINE.                     01150000
;                                                                       01152000
EQUATE                                                                  01154000
   LDTX'MPE'VERSION      =  4;                                          01156000
                                                                        01158000
<< The following EQUATE must be changed if the length of an >>          01160000
<< LDTX entry changes.                                      >>          01162000
                                                                        01164000
EQUATE                                                                  01166000
   SIZE'OF'LDTX'ENTRY     = 5;                                          01168000
                                                                        01170000
<< LDTX header (zero'th) entry fields.                      >>          01172000
                                                                        01174000
DEFINE                                                                  01176000
   LDTX'ENTRY'SIZE       = LDTX(0).( 8:8)#,                             01178000
   LDTX'NUM'ENTRIES      = LDTX(0).( 0:8)#;                             01180000
                                                                        01182000
<< The following expression calculates the segment-relative >>          01184000
<< base address of the LDTX.  It uses symbols from the  LDT >>          01186000
<< portion of this $INCLUDE file.                           >>          01188000
                                                                        01190000
DEFINE                                                                  01192000
   LDTX'BASE              = INTEGER (LDT'DCT'BASE) +                    01194000
                            INTEGER (LDT'DCT'SIZE)#;                    01196000
$PAGE                                                                   01198000
<< LDTX device entry fields.                                >>          01200000
                                                                        01202000
DEFINE                                                                  01204000
   LDTX'BAUD'RATE'CODE     = LDTX(LDTX'INDEX+0).(10:6)#,                01206000
        LDTX'ADCC'960      =  8                       #,                01208000
        LDTX'ADCC'480      =  9                       #,                01210000
        LDTX'ADCC'240      =  7                       #,                01212000
        LDTX'ADCC'120      = 11                       #,                01214000
        LDTX'ADCC'60       =  6                       #,                01216000
        LDTX'ADCC'30       = 13                       #,                01218000
        LDTX'ADCC'15       = 14                       #,                01220000
        LDTX'ADCC'10       = 15                       #,                01222000
        LDTX'ATC'240       =  1                       #,                01224000
        LDTX'ATC'120       =  2                       #,                01226000
        LDTX'ATC'60        =  3                       #,                01228000
        LDTX'ATC'30        =  4                       #,                01230000
        LDTX'ATC'15        =  5                       #,                01232000
        LDTX'ATC'10        =  6                       #,                01234000
        LDTX'ATC'14        =  7                       #,                01236000
        LDTX'ATP'1920      = 16                       #,                01238000
        LDTX'UNKNOWN       =  0                       #,                01240000
   LDTX'CIPER'CNTL'DSEG    = LDTX(LDTX'INDEX+1)       #,                01242000
   LDTX'CIPER'CT'MAP'INDEX = LDTX(LDTX'INDEX+2).(1:15)#,                01244000
   LDTX'CIPER'DEBUG        = LDTX(LDTX'INDEX+0).( 9:1)#,                01246000
   LDTX'CIPER'PROTOCOL     = LDTX(LDTX'INDEX+0).( 2:1)#,                01248000
   LDTX'CIPER'SHUT'DOWN    = LDTX(LDTX'INDEX+2).( 0:1)#,                01250000
   LDTX'DFS'DISC           = LDTX(LDTX'INDEX+0).( 3:1)#,                01252000
   LDTX'DFS'ERR            = LDTX(LDTX'INDEX+3)       #,                01254000
   LDTX'DISC'FREE'SPC'XDS  = LDTX(LDTX'INDEX+2)       #,                01256000
   LDTX'FDISC'ALLOC        = LDTX(LDTX'INDEX+1)       #,                01258000
   LDTX'LYNXII             = LDTX(LDTX'INDEX+2).( 0:1)#,                01260000
   LDTX'SDISC'DBUFS'ALLOC  = LDTX(LDTX'INDEX+2)       #,                01262000
   LDTX'SDISC'GPT'XDS      = LDTX(LDTX'INDEX+1)       #,                01264000
   LDTX'SEEK'AHEAD         = LDTX(LDTX'INDEX+0).( 0:1)#,                01266000
   LDTX'SERIAL'OR'FOREIGN  = LDTX(LDTX'INDEX+0).( 1:1)#;                01268000
                                                                        01270000
COMMENT --                                                              01272000
<<**********************************************************>>          01274000
<<*                                                        *>>          01276000
<<*                     END INCLLDT                        *>>          01278000
<<*                                                        *>>          01280000
<<**********************************************************>>          01282000
;                                                                       01284000
<<$INCLUDE INCLLPDT>>                                          <<ld.m4>>01286000
<<       MPE4 LPDT include file follows                      >>         01288000
<< LINES .001/.009 ARE RESERVED FOR SYSTEMS INTEGRATION>>               01290000
$PAGE "MPE TABLE ACCESS:  LOGICAL/PHYSICAL DEVICE TABLE (LPDT)"         01292000
<<**********************************************************>>          01294000
<<*                                                        *>>          01296000
<<*                INCLLPDT - Module xx                    *>>          01298000
<<*                    MPE4 version                        *>>          01300000
<<*                                                        *>>          01302000
<<**********************************************************>>          01304000
                                                                        01306000
$IF X8 = OFF                                                            01308000
$CONTROL NOLIST                                                         01310000
$IF                                                                     01312000
COMMENT --                                                              01314000
                                                                        01316000
LOGICAL-TO-PHYSICAL DEVICE TABLE (LPDT)                                 01318000
---------------------------------------                                 01320000
                                                                        01322000
DST = 13 (= %15)                                                        01324000
SIR =  9 (= %11)                                                        01326000
                                                                        01328000
  The LPDT has several fields which describe the  state  of  a          01330000
device. Some of these fields have the same meaning for all de-          01332000
vices.  Others are device dependent.  All are described below.          01334000
  The LPDT is one of the most popular--and most abused--tables          01336000
in MPE.  The chief reason for its popularity  is  that  it  is          01338000
main-memory  resident  and  has its own SYSDB-relative pointer          01340000
(SYSDB + 8, or absolute location %1010).  A designer who wants          01342000
to check some device  attribute  knows  that  the  attribute's          01344000
field  need  not  be brought in from disc if it is kept in the          01346000
LPDT.  This has led to cramming entirely too much  information          01348000
into the present two-word entry. A third word would do much to          01350000
relieve the crowding, but in addition to taking up  more  main          01352000
memory  there are many modules which access the LPDT as a dou-          01354000
ble array.  All these modules would need changing.                      01356000
  There are two types of devices represented in the LPDT: real          01358000
devices and virtual devices.  A real device is one  which  has          01360000
been  configured  into the system and is capable of performing          01362000
input and/or output.  A virtual device simulates some  of  the          01364000
properties of a real device (for example a spooled line print-          01366000
er or an INP), but there is no physical I/O involved.  The two          01368000
main uses for virtual devices are for OPEN spooled devicefiles          01370000
and certain communication devices (such as INP's).                      01372000
  A given virtual device entry is in use only  while  the  de-          01374000
vicefile it represents is open.  When the file is FCLOSEd, the          01376000
entry becomes available for another virtual  device.  This  is          01378000
the reason for the SYSDUMP/INITIAL configurator question MAX #          01380000
OF OPEN SPOOLFILES--it needs to know how many  virtual  device          01382000
entries to allocate to the LPDT (and to the LDT).                       01384000
  Entries in the LPDT are ordered by  logical  device  number.          01386000
The  first  word address of a real device entry is obtained by          01388000
multiplying the LDN by the entry size.  Except for the 0th en-          01390000
try, entries for which no logical device is  configured  on  a          01392000
given system are used for virtual device entries.  Any remain-          01394000
ing virtual device entries follow the last real device entry.           01396000
$PAGE                                                                   01398000
                       Entry 0                                          01400000
                       -------                                          01402000
                                                                        01404000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      01406000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     01408000
 0|    Highest entry #    |     Entry size = 2    |                     01410000
  +-----------------------+-----------------------+                     01412000
 1|         DEVREC service request count          |                     01414000
  +-----------------------------------------------+                     01416000
                                                                        01418000
Discussion:                                                             01420000
  Word 1 is incremented by a device driver  whenever  it  sets          01422000
the  Device  Ownership  State  field (below) to 2 (Service Re-          01424000
quested).  DEVREC decrements the count for each  interrupt  it          01426000
services  until  the count reaches 0, at which time DEVREC hi-          01428000
bernates.                                                               01430000
                       -- CAUTION --                                    01432000
         Device drivers must lock this table by  DIS-                   01434000
         ABLE/ENABLEing,  -NOT-  by trying to acquire                   01436000
         the LPDT SIR.                                                  01438000
                                                                        01440000
                                                                        01442000
          Typical entry (virtual devices)                               01444000
          -------------------------------                               01446000
                                                                        01448000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      01450000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     01452000
 0| 1|IO|        Pointer to XDD subentry          |                     01454000
  +--+--+--+--+--+--+--+--------+--+--+-----------+                     01456000
 1|     |  |  |  |  |  |        |  |  |           |                     01458000
  +-----+--+--+--+--+--+--------+--+--+-----------+                     01460000
                                                                        01462000
IO -- 0 for output, 1 for input.                                        01464000
                                                                        01466000
Word 0, bit 0 is 1 for a virtual device, 0 for a real  device.          01468000
The  fields  in word 1 are the same, as applicable, as for the          01470000
real device represented by a given virtual device.  See below.          01472000
                                                                        01474000
                                                                        01476000
          Typical entry (all real devices)                              01478000
          --------------------------------                              01480000
                                                                        01482000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      01484000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     01486000
 0| 0|     SYSDB-relative pointer to the DIT      |                     01488000
  +--+--+--+--+--+--+--+--------+--+--+-----------+                     01490000
  |Devc | J|Da|  | D| I| End of |  |  |Au: Device |                     01492000
 1|Owned| o|ta|  | u| n|  File  |  |  |to: Subtype|                     01494000
  |State| b|  |  | p| t|Cndition|  |  |  :        |                     01496000
  +-----+--+--+--+--+--+--------+--+--+-----------+                     01498000
$PAGE                                                                   01500000
Discussion:                                                             01502000
  Word 1.( 0:2) -- Device Ownership State:                              01504000
                   0 -- Not owned by any process.                       01506000
                   1 -- Owned by a process.                             01508000
                   2 -- Service requested.  Set by driver  for          01510000
                        unexpected  interrupt, then wakes DEV-          01512000
                        REC.                                            01514000
                   3 -- Service granted.  Set by DEVREC. Logon          01516000
                        sequence is 0-2-3-1.                            01518000
                   3 -- Device reserved (alternate  use).  Set          01520000
                        during   STARTSPOOL,  spooler  process          01522000
                        sets to 1 when it gets started.                 01524000
  Word 1.( 2:1) -- Device is Job/Session Accepting if true.             01526000
  Word 1.( 3:1) -- Device is Data Accepting if true.                    01528000
  Word 1.( 5:1) -- Device is Duplicative if true (all  devices          01530000
                   except discs).                                       01532000
  Word 1.( 6:1) -- Device is Interactive if true (all  devices          01534000
                   except discs).                                       01536000
  Word 1.( 7:3) -- End of File condition:                               01538000
                   0 -- No EOF detected.                                01540000
                   1 -- Hardware EOF (e.g., tape mark).                 01542000
                   2 -- :DATA  record read.                             01544000
                   3 -- :EOD   record read.                             01546000
                   4 -- :HELLO record read.                             01548000
                   5 -- :BYE   record read.                             01550000
                   6 -- :JOB   record read.                             01552000
                   7 -- :EOJ   record read.                             01554000
  Word 1.(12:4) -- Device subtype. See discussion for tape en-          01556000
                   try (below) for a description of  the  Auto          01558000
                   bit (12:1).                                          01560000
  The remaining bits in Word 1 are  device-dependent  and  are          01562000
described with their corresponding entry diagram.                       01564000
                                                                        01566000
                                                                        01568000
          Entry for terminal-like devices                               01570000
          -------------------------------                               01572000
                                                                        01574000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      01576000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     01578000
 0| 0|     SYSDB-relative pointer to the DIT      |                     01580000
  +--+--+--+--+--+--+--+--------+--+--+-----------+                     01582000
  |Devc | J|Da|Ct| D| I| End of | B| L|    Device |                     01584000
 1|Owned| o|ta|lY| u| n|  File  | r| o|    Subtype|                     01586000
  |State| b|  |  | p| t|Cndition| k| g|           |                     01588000
  +-----+--+--+--+--+--+--------+--+--+-----------+                     01590000
                                                                        01592000
Discussion (unique fields only):                                        01594000
  Word 1.( 4:1) -- CONTROL-Y is allowed and has been detected.          01596000
  Word 1.(10:1) -- BREAK has been detected -OR-  ignore  BREAK          01598000
                   if the C.I. is running.                              01600000
  Word 1.(11:1) -- The terminal is logging on. This bit is set          01602000
                   by  PROGEN  and  DEVREC  when the logon se-          01604000
                   quence starts.  If  the  bit  is  off  when          01606000
                   polled  by  INITJSMP, the terminal has dis-          01608000
                   connected.  For now, only IOTERM0 and  HIO-          01610000
                   TERM0  support the use of this bit.  Multi-          01612000
                   point and DS pseudo-terminals do not.                01614000
$PAGE                                                                   01616000
               Entry for tape drives                                    01618000
               ---------------------                                    01620000
                                                                        01622000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      01624000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     01626000
 0| 0|     SYSDB-relative pointer to the DIT      |                     01628000
  +--+--+--+--+--+--+--+--------+--+--+-----------+                     01630000
  |Devc | J|Da| B| D| I| End of |  | A|Au: Device |                     01632000
 1|Owned| o|ta| O| u| n|  File  |  | V|to: Subtype|                     01634000
  |State| b|  | T| p| t|Cndition|  | R|  :        |                     01636000
  +-----+--+--+--+--+--+--------+--+--+-----------+                     01638000
                                                                        01640000
Discussion (unique fields only):                                        01642000
  Word 1.( 4:1) -- BOT.  Tape is at Load Point  -OR-  no  tape          01644000
                   mounted.  Recording  density  may  only  be          01646000
                   switched when this bit is true (for  multi-          01648000
                   ple density tape drives).                            01650000
  Word 1.(11:1) -- If true,  DEVREC  is  performing  Automatic          01652000
                   Volume  Recognition  (AVR)  on  a  tape (or          01654000
                   PVPROC is doing the same on a serial disc),          01656000
                   -OR- AVR is to be suppressed on job or data          01658000
                   accepting devices.                                   01660000
  Word 1.(12:1) -- Part of Device Subtype field.  If true, de-          01662000
                   vice  is   allocated   automatically   when          01664000
                   opened.  If false, operator must allocate.           01666000
                                                                        01668000
               Entry for disc drives                                    01670000
               ---------------------                                    01672000
                                                                        01674000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      01676000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     01678000
 0| 0|     SYSDB-relative pointer to the DIT      |                     01680000
  +--+--+--+--+--+--+--+--------+--+--+-----------+                     01682000
  |Devc | J|Da| N|Mt|RV| End of | S| F|    Device |                     01684000
 1|Owned| o|ta| S|d |  |  File  |or| o|    Subtype|                     01686000
  |State| b|  | D|PV|  |Cndition| F| r|           |                     01688000
  +-----+--+--+--+--+--+--------+--+--+-----------+                     01690000
                                                                        01692000
Discussion (unique fields only):                                        01694000
  Word 1.( 0:2) -- Device  Ownership  State.  May  not  be   1          01696000
                   (owned) for shared device (system volume or          01698000
                   private volume).  Serial and foreign  discs          01700000
                   are non-sharable and may be owned.  See the          01702000
                   full discussion of this field under Typical          01704000
                   Entry, above.                                        01706000
  Word 1.( 4:1) -- If true, the disc is  a  non-system  domain          01708000
                   (private  volume,  serial  disc  or foreign          01710000
                   disc) disc drive.                                    01712000
  Word 1.( 5:1) -- If true, disc is a mounted private volume.           01714000
  Word 1.( 6:1) -- If true, the disc is a reserved volume used          01716000
                   to satisfy the requirements of a  multiple-          01718000
                   volume private volume set.                           01720000
  Word 1.(10:1) -- If true, the disc is a physically and logi-          01722000
                   cally mounted serial or foreign disc.  Bits          01724000
                   5 and 6 must be false.                               01726000
  Word 1.(11:1) -- If bit 10 is true, then 1 ==> foreign disc,          01728000
                   0 ==> serial disc.                                   01730000
$PAGE                                                                   01732000
$IF X8 = OFF                                                            01734000
$CONTROL LIST                                                           01736000
$IF                                                                     01738000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              01740000
             |  Declarations start here  |                              01742000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              01744000
                                                                        01746000
Conventions used in the declarations:                                   01748000
1.  The LPDT is referenced via the system pointer at  absolute          01750000
    location  %1010.  The pointer is declared in this $INCLUDE          01752000
    file.                                                               01754000
2.  We assume the existence of an offset integer,  LPDT'INDEX,          01756000
    to  access a particular LPDT entry.  LPDT'INDEX would nor-          01758000
    mally be set to LDEV# * LPDT'ENTRY'SIZE.                            01760000
3.  Each DEFINE is prefixed by LPDT'... to distinguish it from          01762000
    references to other MPE tables.                                     01764000
4.  DEFINEs of fields are  listed  alphabetically  for  easier          01766000
    lookup without using XREF. DEFINEs of states of fields are          01768000
    listed sequentially following the field DEFINE.  The  com-          01770000
    ment field indicates for which device(s) a symbol is rele-          01772000
    vant, according to the following code:                              01774000
       ABD -- All But Disc           TAP -- tape                        01776000
       ALL -- all devices            TRM -- terminal                    01778000
       DSC -- all discs              VDV -- virtual devices             01780000
       NSD -- non-system domain discs                                   01782000
;                                                                       01784000
$IF X6 = OFF                                                            01786000
                                                                        01788000
LOGICAL POINTER                                                         01790000
   LPDT                   =   8;                                        01792000
                                                                        01794000
$IF                                                                     01796000
                                                                        01798000
EQUATE                                                                  01800000
   LPDT'DST               = %15,                                        01802000
   LPDT'SIR               = %11,                                        01804000
   LPDT'MPE'VERSION       =   4,                                        01806000
                                                                        01808000
<< The following EQUATE must be changed if the length of an >>          01810000
<< LPDT entry changes.                                      >>          01812000
                                                                        01814000
   SIZE'OF'LPDT'ENTRY     =   2;                                        01816000
$PAGE                                                                   01818000
DEFINE                                                                  01820000
   LPDT'AUTO'ALLOC        = LPDT(LPDT'INDEX+1).(12:1)#,<<TAP>>          01822000
   LPDT'AUTO'SUBTYPE      = LPDT(LPDT'INDEX+1).(13:3)#,<<TAP>>          01824000
   LPDT'BREAK             = LPDT(LPDT'INDEX+1).(10:1)#,<<TRM>>          01826000
   LPDT'CONTROL'Y         = LPDT(LPDT'INDEX+1).(4:1) #,<<TRM>>          01828000
   LPDT'DATA'ACCEPT       = LPDT(LPDT'INDEX+1).(3:1) #,<<ALL>>          01830000
   LPDT'DEV'OWN'STATE     = LPDT(LPDT'INDEX+1).(0:2) #,<<ALL>>          01832000
      LPDT'NOT'OWNED      = 0                        #,                 01834000
      LPDT'OWNED          = 1                        #,                 01836000
      LPDT'SERVICE'REQ    = 2                        #,                 01838000
      LPDT'SERVICE'OK     = 3                        #,                 01840000
      LPDT'RESERVED       = 3                        #,                 01842000
   LPDT'DIT'PTR           = LPDT(LPDT'INDEX+0).(1:15)#,<<ALL>>          01844000
   LPDT'DUPLICATIVE       = LPDT(LPDT'INDEX+1).(5:1) #,<<ABD>>          01846000
   LPDT'ENTRY'SIZE        = LPDT(0).(8:8)            #,                 01848000
   LPDT'EOF'TYPE          = LPDT(LPDT'INDEX+1).(7:3) #,<<ALL>>          01850000
      LPDT'NO'EOF         = 0                        #,                 01852000
      LPDT'HARDWARE'EOF   = 1                        #,                 01854000
      LPDT'DATA           = 2                        #,                 01856000
      LPDT'EOD            = 3                        #,                 01858000
      LPDT'HELLO          = 4                        #,                 01860000
      LPDT'BYE            = 5                        #,                 01862000
      LPDT'JOB            = 6                        #,                 01864000
      LPDT'EOJ            = 7                        #,                 01866000
   LPDT'INTERACTIVE       = LPDT(LPDT'INDEX+1).(6:1) #,<<ABD>>          01868000
   LPDT'JOB'ACCEPT        = LPDT(LPDT'INDEX+1).(2:1) #,<<ALL>>          01870000
   LPDT'LOAD'POINT        = LPDT(LPDT'INDEX+1).(4:1) #,<<TAP>>          01872000
   LPDT'LOGGING'ON        = LPDT(LPDT'INDEX+1).(11:1)#,<<TRM>>          01874000
   LPDT'MAX'ENTRIES       = LPDT(0).(0:8)            #,                 01876000
   LPDT'MOUNTED'PV        = LPDT(LPDT'INDEX+1).(5:1) #,<<NSD>>          01878000
   LPDT'NON'SYS'DOMAIN    = LPDT(LPDT'INDEX+1).(4:1) #,<<DSC>>          01880000
   LPDT'NOT'PV'OR'SYS     = LPDT(LPDT'INDEX+1).(4:3) = 4#,              01882000
   LPDT'RDY'SER'FRN'DISC  = LPDT(LPDT'INDEX+1).(10:1)#,<<NSD>>          01884000
   LPDT'RESERVED'PV       = LPDT(LPDT'INDEX+1).(6:1) #,<<NSD>>          01886000
   LPDT'SERIAL'OR'FOREIGN = LPDT(LPDT'INDEX+1).(11:1)#,<<NSD>>          01888000
      LPDT'SERIAL         = 0                        #,                 01890000
      LPDT'FOREIGN        = 1                        #,                 01892000
   LPDT'SERV'REQ'COUNT    = LPDT(1)                  #,                 01894000
   LPDT'SUBTYPE           = LPDT(LPDT'INDEX+1).(12:4)#,<<ALL>>          01896000
   LPDT'TAPE'AVR          = LPDT(LPDT'INDEX+1).(11:1)#,<<TAP>>          01898000
   LPDT'VDEV'DIRECTION    = LPDT(LPDT'INDEX+0).(1:1) #,<<VDV>>          01900000
      LPDT'VDEV'INPUT     = 0                        #,                 01902000
      LPDT'VDEV'OUTPUT    = 1                        #,                 01904000
   LPDT'VIRTUAL'DEVICE    = LPDT(LPDT'INDEX+0).(0:1) #,<<VDV>>          01906000
   LPDT'XDD'SUBENTRY'PTR  = LPDT(LPDT'INDEX+0).(2:14)#;<<VDV>>          01908000
                                                                        01910000
COMMENT --                                                              01912000
<<**********************************************************>>          01914000
<<*                                                        *>>          01916000
<<*                    END INCLLPDT                        *>>          01918000
<<*                                                        *>>          01920000
<<**********************************************************>>          01922000
;                                                                       01924000
<<$INCLUDE INCLXDD5>>                                          <<xd.m4>>01926000
<<           MPE4 XDD include file follows                  >>          01928000
$PAGE "MPE TABLE ACCESS:  INPUT/OUTPUT DEVICE DIRECTORY (XDD)"          01930000
COMMENT --                                                              01932000
<<**********************************************************>>          01934000
<<*                                                        *>>          01936000
<<*                 INCLXDD - Module C2                    *>>          01938000
<<*                     MPE4 version                       *>>          01940000
<<*                                                        *>>          01942000
<<**********************************************************>>          01944000
                                                                        01946000
$IF X8 = OFF                                                            01948000
$CONTROL NOLIST                                                         01950000
$IF                                                                     01952000
                                                                        01954000
INPUT DEVICE DIRECTORY/OUTPUT DEVICE DIRECTORY                          01956000
----------------------------------------------                          01958000
                                                                        01960000
IDD/ODD (Common attributes referred to as XDD)                          01962000
                                                                        01964000
        IDD:  DST = 45 (= %55)         ODD:  DST = 46 (= %56)           01966000
              SIR =  3                       SIR =  4                   01968000
                                                                        01970000
               Overview of table structure                              01972000
               ---------------------------                              01974000
                                                                        01976000
         +-------------------------------------+                        01978000
         |   Entry 0 (8 words)                 |                        01980000
         | . . . . . . . . . . . . . . . . . . |                        01982000
       2 |   Subentry area pointer             | ---                    01984000
         | . . . . . . . . . . . . . . . . . . |   |                    01986000
         |                                     |   |                    01988000
         +-------------------------------------+   |                    01990000
         |   Head entries (4 words each)       |   |                    01992000
         +-------------------------------------+   |                    01994000
         |   Subentries (%36 words each)       | <--                    01996000
         +-------------------------------------+                        01998000
                                                                        02000000
                                                                        02002000
          Entry 0 (overall table definitions)                           02004000
          -----------------------------------                           02006000
                                                                        02008000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      02010000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     02012000
 0|      Maximum size     |      Current size     |0 (sectors)          02014000
  +-----------------------+-----------------------+                     02016000
 1|  Head entry size = 4  |  Subentry size = %36  |1 ( words )          02018000
  +-----------------------+-----------------------+                     02020000
 2|   Subentry area pointer (segment relative)    |2                    02022000
  +--+--------------------------------------------+                     02024000
 3|DD|      Next avail device file ID (DFID)      |3                    02026000
  +--+--------------------------------+-----------+                     02028000
 4|///////////////////////////////////|   Fence   |4                    02030000
  +-----------------------------------+-----------+                     02032000
 5|///////////////////////////////////////////////|5                    02034000
  +-----------------------------------------------+                     02036000
 6|///////////////////////////////////////////////|6                    02038000
  +-----------------------------------------------+                     02040000
 7|///////////////////////////////////////////////|7                    02042000
  +-----------------------------------------------+                     02044000
                                                                        02046000
DD:     0 ==> This is the IDD,                                          02048000
        1 ==> This is the ODD.                                          02050000
                                                                        02052000
Fence:  For spooled output devices (ODD), the system-wide out-          02054000
        fence.  For spooled input devices (IDD), the jobfence.          02056000
                                                                        02058000
                                                                        02060000
         Typical head entry (4 words)                                   02062000
         ----------------------------                                   02064000
                                                                        02066000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      02068000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     02070000
  |    Device outfence    |     Logical device    |                     02072000
  +-----------------------+-----------------------+                     02074000
  |                 Head pointer                  |                     02076000
  +-----------------------------------------------+                     02078000
  |                 Tail pointer                  |                     02080000
  +-----------------------------------------------+                     02082000
  |///////////////////////////////////////////////|                     02084000
  +-----------------------------------------------+                     02086000
                                                                        02088000
  There are two types of head entry, a class entry and a logi-          02090000
cal device entry. There is only one class entry, and it is the          02092000
first head entry in the XDD.  All  spoofles  opened  by  class          02094000
(e.g.,  LP,  SLOWLP, EPOC, PP, etc.) are linked to this entry.          02096000
There is one logical device entry for each real (physical,  as          02098000
opposed  to virtual) device on the system.  Output devices ap-          02100000
pear in the ODD, input devices in the IDD.  AC/DC devices such          02102000
as terminals appear in both directories.                                02104000
  Each head entry is linked to 0 or more subentries (a typical          02106000
subentry is shown in the next table).  There is  one  subentry          02108000
for  each  file (including spoofles) which exists for a device          02110000
or device class.  A null chain (0 subentries) consists of head          02112000
pointer = 0 and tail pointer = segment-relative address of the          02114000
head pointer.  If one or more subentries exists, the  pointers          02116000
are  segment-relative addresses of the first word of the first          02118000
and last subentries of the chain.  Any intermediate subentries          02120000
are forward-linked through the subentries.  The tail  subentry          02122000
always contains a 0-link.                                               02124000
  Subentries are linked first by descending priority, then  by          02126000
class  (only if in the class chain), and finally by rank (time          02128000
stamp in the subentry).  As priorities and/or  devices  change          02130000
(:ALTSPOOLFILE or SPOOK), subentries must be relinked to main-          02132000
tain the above order.                                                   02134000
  The Device Outfence and LDEV# fields are meaningless for the          02136000
class entry.  For logical device entries (non-0 Logical Device          02138000
field), a non-0 Device Outfence means that this outfence over-          02140000
rides the system-wide outfence in word 4 of entry 0, but  only          02142000
for this device.                                                        02144000
$PAGE                                                                   02146000
         Typical subentry (%36 words)                                   02148000
         ----------------------------                                   02150000
                                                                        02152000
    0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                      02154000
  +--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--+                     02156000
 0|VF|State|  Outpri   |CL|         Device        |0                    02158000
  +--+--+--+-----------+--+-----------------------+                     02160000
 1| Type|                Job number               |1                    02162000
  +-----+-----------------------------------------+                     02164000
 2|                                               |2                    02166000
 3|                   User name                   |3                    02168000
 4|                                               |4                    02170000
 5|                                               |5                    02172000
  +-----------------------------------------------+                     02174000
 6|                                               |6                    02176000
 7|                 Account name                  |7                    02178000
10|                                               |8                    02180000
11|                                               |9                    02182000
  +-----------------------------------------------+                     02184000
12|                                               |10                   02186000
13|                    Job name                   |11                   02188000
14|                                               |12                   02190000
15|                                               |13                   02192000
  +-----------------------------------------------+                     02194000
16|                                               |14                   02196000
17|                   File name                   |15                   02198000
20|                                               |16                   02200000
21|                                               |17                   02202000
  +--+--------------------------------------------+                     02204000
22|IO|              Device file ID                |18                   02206000
  +--+--+-----------------+-----------------------+                     02208000
23|FS|DA|/////////////////| Head index (see expl) |19                   02210000
  +--+--+-----------------+-----------------------+                     02212000
24|    Logical device     |   Sector address...   |20                   02214000
  +-----------------------+                       |                     02216000
25|                           of spoofle label.   |21                   02218000
  +-----------------------------------------------+                     02220000
26|   Number of extents   |      Virtual LDEV     |22                   02222000
  +-----------------------+-----------------------+                     02224000
27|           Last extent size (sectors)          |23                   02226000
  +--+--+--+--+--+--+--+--------------------------+                     02228000
30|SQ|//|RS|FD|SO|AB|//|     Number of copies     |24                   02230000
  +--+--+--+--+--+--+--+--------------------------+                     02232000
31|    Segment-relative link to next subentry,    |25                   02234000
  |    this device or class. 0 ==> last subentry. |                     02236000
  +-----------------------------------------------+                     02238000
32|   Number of records in spoofle (doubleword)   |26                   02240000
33|                                               |27                   02242000
  +-----------------------+-----------------------+                     02244000
34|     Year MOD 100      | Julian Day of Year/2  |28                   02246000
  +--+--------------+-----------------+-----------+                     02248000
35|DY| Hour (24 hr) |     Minute      |///////////|29                   02250000
  +--+--------------+-----------------+-----------+                     02252000
$PAGE                                                                   02254000
Note:  Words 0-%24 are used in all subentries.  Words %25-%37,          02256000
       although present in all subentries, are zero unless the          02258000
       subentry is for a spooled file (spoofle).                        02260000
                                                                        02262000
Word   0:  VF    -- An "entry visited" flag for SHOWFILES.              02264000
           State -- State of subentry:                                  02266000
                      0 ==> Active                                      02268000
                      1 ==> Ready                                       02270000
                      2 ==> Open                                        02272000
                      3 ==> Locked                                      02274000
           CL    -- 1 ==> DEVICE field is a class  index  into          02276000
                      the Device Class Table.                           02278000
                    0 ==> DEVICE field is an LDEV number.               02280000
Word   1:  Type  -- Describes which  environment  created  the          02282000
                    subentry:                                           02284000
                      0 ==> Session' (SPOOK)                            02286000
                      1 ==> Session                                     02288000
                      2 ==> Job                                         02290000
                      3 ==> Job'     (SPOOK)                            02292000
Word %22:  IO    -- 1 ==> Output DFID                                   02294000
                    0 ==> Input  DFID                                   02296000
Word %23:  FS    -- There are one or more  forms  message  re-          02298000
                    quests in the spoofle.                              02300000
           DA    -- The spoofle was created via a :DATA record          02302000
                    (input spooling only).                              02304000
Word %24:  LDEV  -- The logical device in  class  SPOOL  where          02306000
                    the file label (first extent) of the spoo-          02308000
                    fle lives.                                          02310000
Word %26:  VDEV  -- LPDT index of virtual device  LDEV.  Simu-          02312000
                    lates the properties of a real LDEV to the          02314000
                    process which  FOPENs  a  new  (previously          02316000
                    non-existing)  file  (State field (XDD(0).          02318000
                    (1:2)) = 2 (Open)).                                 02320000
Word %30:  SQ    -- 1 ==> Squeeze (purge) spoofle  extents  as          02322000
                          the final copy is printed.                    02324000
                    0 ==> Purge only when final copy printed.           02326000
           RS    -- 1 ==> Restart job when warmstarting (input          02328000
                          spooling only).                               02330000
           FD    -- 1 ==> There are non-standard forms on  the          02332000
                          device.                                       02334000
           SO    -- Spaced Out bit.  File System could not ac-          02336000
                    quire a new extent when creating spoofle.           02338000
           AB    -- This is the $STDLIST of an aborted job.             02340000
Words %34-35:    -- Time stamp when spoofle was made READY, or          02342000
                    0D if not closed properly.  Julian day  is          02344000
                    9 bits starting with Word %34, bit 8.               02346000
                                                                        02348000
Head index:  The (segment-relative address)/4 of the head  en-          02350000
             try  with  which  this subentry is linked.  Since          02352000
             head entries are four words  long,  this  can  be          02354000
             thought  of  as an index into the head entry por-          02356000
             tion of the XDD -- if you disallow  values  of  0          02358000
             and 1.  Cute, huh?                                         02360000
$PAGE                                                                   02362000
$IF X8 = OFF                                                            02364000
$CONTROL LIST                                                           02366000
$IF                                                                     02368000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              02370000
             |  Declarations start here  |                              02372000
             *-*-*-*-*-*-*-*-*-*-*-*-*-*-*                              02374000
Conventions used in the declarations:                                   02376000
1.  We presume the existence of the following  logical  arrays          02378000
    or pointers:                                                        02380000
  a)  XDD           -- when referencing the master entry or  a          02382000
                       data segment relative address.                   02384000
  b)  XDD'HEAD      -- when referencing a head entry.                   02386000
  c)  XDD'SUBENTRY  -- when referencing a subentry.                     02388000
  d)  XDD'BSUBENTRY -- byte array equivalent of XDD'SUBENTRY.           02390000
  e)  XDD'DSUBENTRY -- double array equivalent of XDD'SUBENTRY          02392000
    Use the array size EQUATEs below (2x for XDD'BSUBENTRY and          02394000
    x/2 for XDD'DSUBENTRY). The 0-element of all arrays is as-          02396000
    sumed to be the first word of the current entry, -NOT- the          02398000
    first word of that area of the XDD.  The arrays can be di-          02400000
    rect, indirect, DB-relative or Q-relative. If DB-relative,          02402000
    make sure you know where DB is before you  use  them.  The          02404000
    only  time  you  have to explicitly reference them is when          02406000
    you declare them and when you set their starting  address.          02408000
    (Note the EQUATE to get you the class head entry).  There-          02410000
    after the DEFINEs below will  implicitly  reference  them.          02412000
    You must use the DEFINEs though.                                    02414000
2.  Prefixes in the DEFINEs are:                                        02416000
  a)  XDD0  -- when referencing something in the master entry.          02418000
  b)  XDDH  -- when referencing something in a head entry.              02420000
  c)  XDDS  -- when referencing something relevant to both  an          02422000
               IDD subentry and an ODD subentry.                        02424000
  d)  XDDSB -- when using a byte reference in an XDD subentry.          02426000
  e)  XDDSD -- when using a double reference in  an  XDD  sub-          02428000
               entry.                                                   02430000
  f)  ODDS  -- when referencing something relevant only to  an          02432000
               ODD subentry.                                            02434000
  g)  IDDS  -- when referencing something relevant only to  an          02436000
               IDD subentry.                                            02438000
3.  Within each set of prefixes, DEFINEs of fields  are  given          02440000
    alphabetically  for easier lookup without using XREF.  DE-          02442000
    FINEs of states of fields are listed sequentially  follow-          02444000
    ing the field DEFINE.                                               02446000
;                                                                       02448000
EQUATE                                                                  02450000
   IDD'DST               = 45                       ,                   02452000
   IDD'SIR               =  3                       ,                   02454000
                                                                        02456000
   ODD'DST               = 46                       ,                   02458000
   ODD'SIR               =  4                       ,                   02460000
$PAGE                                                                   02462000
<< The following three EQUATE's must be changed if XDD  en- >>          02464000
<< try lengths change.                                      >>          02466000
                                                                        02468000
   SIZE'OF'XDD0          =  8                       ,                   02470000
   SIZE'OF'XDD'HEAD      =  4                       ,                   02472000
   SIZE'OF'XDD'SUBENTRY  = 30                       ,                   02474000
                                                                        02476000
   XDD'MPE'VERSION       =  4                       ,                   02478000
   XDD'CLASS'INDEX       =  2                       ,                   02480000
   XDD'CLASS'ENTRY       = XDD'CLASS'INDEX *                            02482000
                             SIZE'OF'XDD'HEAD       ;                   02484000
                                                                        02486000
<< XDD zero'th entry fields                                 >>          02488000
                                                                        02490000
DEFINE                                                                  02492000
   XDD0'CURRENT'SECTORS  = XDD(0).(8:8)            #,                   02494000
   XDD0'HEAD'LENGTH      = XDD(1).(0:8)            #,                   02496000
   XDD0'MAX'SECTORS      = XDD(0).(0:8)            #,                   02498000
   XDD0'NEXT'DFID        = XDD(3).(1:15)           #,                   02500000
   XDD0'SUBENTRY'AREA    = XDD(2)                  #,                   02502000
   XDD0'SUBENTRY'LENGTH  = XDD(1).(8:8)            #,                   02504000
   XDD0'SYSTEM'OUTFENCE  = XDD(4).(12:4)           #,                   02506000
   XDD0'IDD'OR'ODD       = XDD(3).(0:1)            #,                   02508000
        XDD0'IDD         = 0                       #,                   02510000
        XDD0'ODD         = 1                       #;                   02512000
                                                                        02514000
<< XDD head entry fields                                    >>          02516000
                                                                        02518000
DEFINE                                                                  02520000
   XDDH'DEV'OUTFENCE     = XDD'HEAD(0).(0:8)       #,                   02522000
   XDDH'FIRST'SUBENTRY   = XDD'HEAD(1)             #,                   02524000
   XDDH'LAST'SUBENTRY    = XDD'HEAD(2)             #,                   02526000
   XDDH'LDEV             = XDD'HEAD(0).(8:8)       #;                   02528000
                                                                        02530000
<< XDD subentry fields (except IDD/ODD specific fields).    >>          02532000
                                                                        02534000
DEFINE                                                                  02536000
   XDDS'ACCOUNT'NAME     = XDD'SUBENTRY(6)         #,                   02538000
   XDDS'CLASS            = XDD'SUBENTRY(0).(7:1)   #,                   02540000
   XDDS'DAY'OF'YEAR      = XDD'SUBENTRY(28).(8:8) & LSL(1)              02542000
                               LOR XDD'SUBENTRY(29).(0:1) #,            02544000
   XDDS'DEVICE           = XDD'SUBENTRY(0).(8:8)   #,                   02546000
   XDDS'DFID'IN'OR'OUT   = XDD'SUBENTRY(18).(0:1)  #,                   02548000
        XDDS'DFID'IN     = 0                       #,                   02550000
        XDDS'DFID'OUT    = 1                       #,                   02552000
   XDDS'DFID'NUMBER      = XDD'SUBENTRY(18).(1:15) #,                   02554000
   XDDS'FILE'NAME        = XDD'SUBENTRY(14)        #,                   02556000
   XDDS'HEAD'INDEX       = XDD'SUBENTRY(19).(8:8)  #,                   02558000
   XDDS'HOUR             = XDD'SUBENTRY(29).(1:5)  #,                   02560000
   XDDS'JOB'NAME         = XDD'SUBENTRY(10)        #,                   02562000
   XDDS'JOB'NUMBER       = XDD'SUBENTRY(1).(2:14)  #,                   02564000
   XDDS'JOB'TYPE         = XDD'SUBENTRY(1).(0:2)   #,                   02566000
        XDDS'SESSION'    = 0                       #,                   02568000
        XDDS'SESSION     = 1                       #,                   02570000
        XDDS'JOB         = 2                       #,                   02572000
        XDDS'JOB'        = 3                       #,                   02574000
   XDDS'LAST'EXTENT'SIZE = XDD'SUBENTRY(23)        #,                   02576000
   XDDS'LSW'LABEL        = XDD'SUBENTRY(21)        #,                   02578000
   XDDS'LSW'RECORD'COUNT = XDD'SUBENTRY(27)        #,                   02580000
   XDDS'MINUTE           = XDD'SUBENTRY(29).(6:6)  #,                   02582000
   XDDS'MSW'LABEL        = XDD'SUBENTRY(20).(8:8)  #,                   02584000
   XDDS'MSW'RECORD'COUNT = XDD'SUBENTRY(26)        #,                   02586000
   XDDS'NEXT'SUBENTRY    = XDD'SUBENTRY(25)        #,                   02588000
      XDDS'END'OF'CHAIN  = 0                       #,                   02590000
   XDDS'NUMBER'EXTENTS   = XDD'SUBENTRY(22).(0:8)  #,                   02592000
   XDDS'OUTPUT'PRIORITY  = XDD'SUBENTRY(0).(3:4)   #,                   02594000
   XDDS'SPACED'OUT       = XDD'SUBENTRY(24).(4:1)  #,                   02596000
   XDDS'SPOOFLE'LDEV     = XDD'SUBENTRY(20).(0:8)  #,                   02598000
   XDDS'SPOOL'STATE      = XDD'SUBENTRY(0).(1:2)   #,                   02600000
        XDDS'ACTIVE      = 0                       #,                   02602000
        XDDS'READY       = 1                       #,                   02604000
        XDDS'OPEN        = 2                       #,                   02606000
        XDDS'LOCKED      = 3                       #,                   02608000
   XDDS'SUBENTRY'VISITED = XDD'SUBENTRY(0).(0:1)   #,                   02610000
   XDDS'USER'NAME        = XDD'SUBENTRY(2)         #,                   02612000
   XDDS'VIRTUAL'LDEV     = XDD'SUBENTRY(22).(8:8)  #,                   02614000
   XDDS'YEAR             = XDD'SUBENTRY(28).(0:8)  #,                   02616000
   XDDSB'ACCOUNT'NAME    = XDD'BSUBENTRY(12)       #,                   02618000
   XDDSB'FILE'NAME       = XDD'BSUBENTRY(28)       #,                   02620000
   XDDSB'JOB'NAME        = XDD'BSUBENTRY(20)       #,                   02622000
   XDDSB'USER'NAME       = XDD'BSUBENTRY(4)        #,                   02624000
   XDDSD'DISC'LABEL      = XDD'DSUBENTRY(10)       #,                   02626000
   XDDSD'READY'TIME      = XDD'DSUBENTRY(14)       #,                   02628000
   XDDSD'RECORD'COUNT    = XDD'DSUBENTRY(13)       #;                   02630000
                                                                        02632000
<< IDD-only subentry fields.                                >>          02634000
                                                                        02636000
DEFINE                                                                  02638000
   IDDS'DATA             = XDD'SUBENTRY(19).(1:1)  #,                   02640000
   IDDS'RESTART          = XDD'SUBENTRY(24).(2:1)  #;                   02642000
                                                                        02644000
<< ODD-only subentry fields.                                >>          02646000
                                                                        02648000
DEFINE                                                                  02650000
   ODDS'ABORTED'JOB      = XDD'SUBENTRY(24).(5:1)  #,                   02652000
   ODDS'FORMS'IN'FILE    = XDD'SUBENTRY(19).(0:1)  #,                   02654000
   ODDS'FORMS'ON'DEVICE  = XDD'SUBENTRY(24).(3:1)  #,                   02656000
   ODDS'NUMBER'COPIES    = XDD'SUBENTRY(24).(8:8)  #,                   02658000
   ODDS'PURGE'EXTENTS    = XDD'SUBENTRY(24).(0:1)  #;                   02660000
                                                                        02662000
COMMENT --                                                              02664000
<<**********************************************************>>          02666000
<<*                                                        *>>          02668000
<<*                     END INCLXDD                        *>>          02670000
<<*                                                        *>>          02672000
<<**********************************************************>>          02674000
;                                                                       02676000
$PAGE "SPOOK GLOBAL VARIABLES AND DEFINES"                     <<xd.m4>>02678000
                                                               <<xd.m4>>02680000
<<---------------------------------------------------------->> <<xd.m4>>02682000
<<                                                          >> <<xd.m4>>02684000
<<           XDD DECLARATIONS FOR THIS MODULE ONLY          >> <<xd.m4>>02686000
<<                                                          >> <<xd.m4>>02688000
<<---------------------------------------------------------->> <<xd.m4>>02690000
DEFINE                                                         <<xd.m4>>02692000
   << refers to both XDDS'DFID'IN'OR'OUT bit and XDDS'DFID' >> <<xd.m4>>02694000
   << NUMBER at the same time                               >> <<xd.m4>>02696000
   XD'DFID      = 18#,                                         <<xd.m4>>02698000
   XDDS'DFID'ALL            = XDD'SUBENTRY(XD'DFID)#,          <<xd.m4>>02700000
                                                               <<xd.m4>>02702000
   << refers to PURGE'EXTENTS, RESTART, FORMS'ON'DEVICE,    >> <<xd.m4>>02704000
   << SPACED'OUT, ABORTED'JOB, and NUMBER'COPIES fields at  >> <<xd.m4>>02706000
   << the same time.                                        >> <<xd.m4>>02708000
   XD'COPY'INFO = 24#,                                         <<xd.m4>>02710000
   XDDS'COPY'INFO           = XDD'SUBENTRY(XD'COPY'INFO)#,     <<xd.m4>>02712000
                                                               <<xd.m4>>02714000
   << SPOOK uses the XDDS'NEXT'SUBENTRY field to store err- >> <<xd.m4>>02716000
   << ors encountered while processing commands.  It can    >> <<xd.m4>>02718000
   << get away with this as it's only playing with its own  >> <<xd.m4>>02720000
   << local copies of the significant XDD subentries in the >> <<xd.m4>>02722000
   << DB- area.  Of course, this define must be changed if  >> <<xd.m4>>02724000
   << XDDS'NEXT'SUBENTRY moves in the table.                >> <<xd.m4>>02726000
                                                               <<xd.m4>>02728000
   XD'ERRS      = 25#,                                         <<xd.m4>>02730000
   XDDS'SHOW'ERRS           = XDD'SUBENTRY(XD'ERRS)#,          <<xd.m4>>02732000
   XDDS'SPOOK'ERR           = XDD'SUBENTRY(XD'ERRS).(0:8)#,    <<xd.m4>>02734000
   XDDS'FILESYS'ERR         = XDD'SUBENTRY(XD'ERRS).(8:8)#;    <<xd.m4>>02736000
                                                               <<xd.m4>>02738000
<<GLOBAL DECLARATIONS>>                                                 02740000
EQUATE                                                                  02742000
   NO'FILE'ERROR = -1,                                         <<04145>>02744000
   CR            = %15,                                        <<04145>>02746000
   EXITINSTR = %031400;                                        <<xd.m4>>02748000
DEFINE INTRINS = INTRWORD.(0:10)#,                             <<B0.00>>02750000
      NUMPARMS = INTRWORD.(10:6)#;                             <<B0.00>>02752000
DEFINE                                                         <<xd.m4>>02754000
   << for device file id's >>                                  <<xd.m4>>02756000
   IS'ODD = (0:1)#,                                            <<xd.m4>>02758000
   IDNUM  = (1:15)#,                                           <<xd.m4>>02760000
                                                               <<xd.m4>>02762000
   << for SHOWIO >>                                            <<xd.m4>>02764000
   IDDS = (14:1)#,                                             <<xd.m4>>02766000
   ODDS = (15:1)#;                                             <<xd.m4>>02768000
                                                               <<xd.m4>>02770000
INTEGER X=X;                                                            02772000
INTEGER S0=S-0;                                                         02774000
LOGICAL LS0=S-0;                                                        02776000
INTEGER POINTER PS0=S-0;                                                02778000
BYTE POINTER BPS0=S-0;                                                  02780000
                                                                        02782000
<<GENERAL>>                                                             02784000
INTEGER I,COUNT,CNT;                                           <<xd.m4>>02786000
LOGICAL CARRYF;                                                         02788000
<< pointer to PCB table >>                                     <<xd.m4>>02790000
                                                                        02792000
LOGICAL POINTER PCB = 3;                                       <<xd.m4>>02794000
                                                               <<xd.m4>>02796000
<<CONTROL Y>>                                                           02798000
INTEGER CYLABEL,CYOLD,CYADDR;                                           02800000
INTEGER SVAL,QVAL,STATVAL;                                              02802000
INTEGER DELTAP=Q-2,QMSTAT=Q-1,DELTAQ=Q-0;                               02804000
LOGICAL CRITFLAG,CONTROLYFLAG,                                 <<04145>>02806000
   FILE'MATCH,   << at least one dfid found on input tape >>   <<infil>>02808000
   FILE'FOUND;     << At least one DEV File found in command>> <<04145>>02810000
                                                               <<B0.00>>02812000
<< SUBTASKING INTERFACE >>                                     <<B0.00>>02814000
INTEGER PIN:=0,LASTPIN:=0,PINOFFATHER:=0;                      <<B0.00>>02816000
DOUBLE FATHERINFO;                                             <<B0.00>>02818000
BYTE ARRAY PROGNAME(0:26);                                     <<B0.00>>02820000
BYTE ARRAY LASTCREATE(0:26);                                   <<B0.00>>02822000
LOGICAL SUBTASK:=FALSE;                                        <<B0.00>>02824000
INTEGER SUBTASK'LEVEL := 0,SUBLEVEL = Q-4;                     <<B0.00>>02826000
INTEGER INTRWORD;                                              <<B0.00>>02828000
INTEGER FATHERINFO0=FATHERINFO;                                <<B0.01>>02830000
INTEGER FATHERINFO1=FATHERINFO0+1;                             <<B0.01>>02832000
<<                      >>                                     <<B0.00>>02834000
                                                                        02836000
<<USER ATTRIBUTES>>                                                     02838000
INTEGER MODE,LDEV;                                                      02840000
DOUBLE  CAP,LAT;                                                        02842000
LOGICAL CAP1=CAP,CAP2=CAP+1;                                            02844000
ARRAY NAMES(0:15);                                                      02846000
BYTE ARRAY BNAMES(*)=NAMES;                                             02848000
BYTE ARRAY USERN(*)=NAMES(0),                                           02850000
           ACCTN(*)=NAMES(4),                                           02852000
           GROUPN(*)=NAMES(8),                                          02854000
           HOMEN(*)=NAMES(12);                                          02856000
                                                                        02858000
<<MODES>>                                                               02860000
LOGICAL FALL;                                                           02862000
INTEGER FWIDTH;                                                         02864000
                                                                        02866000
<<ALTER>>                                                               02868000
INTEGER PRI,COPIES,CLASS,DEVICE;                               <<xd.m4>>02870000
                                                                        02872000
<<COMMANDS AND XDD MGMT>>                                               02874000
INTEGER CRIT,ERRN,WARN,ERRF;                                   <<xd.m4>>02876000
INTEGER INITXDDP;                                                       02878000
INTEGER XDDX,XDDC,DEVF,DEVFC,FILEF;                                     02880000
LOGICAL USERF,ACCTF;                                                    02882000
LOGICAL SHOWIO,SHOWF,SHOWP;                                             02884000
ARRAY SNAMES(0:7);                                                      02886000
BYTE ARRAY SUSERN(*)=SNAMES(0),                                         02888000
           SACCTN(*)=SNAMES(4);                                         02890000
                                                                        02892000
<<SPOOL FILE MGMT>>                                                     02894000
INTEGER FILEN,XDDN,DEVFN;                                               02896000
INTEGER FLINECNT;                                                       02898000
INTEGER ODDN;      <<01.02>>                                   <<01.02>>02900000
DOUBLE SBLINE;                                                          02902000
DOUBLE FLINE,EOFLINE;                                                   02904000
LOGICAL PURGEFLAG;  <<USED FOR OUTPUT>>                       <<00204>> 02906000
DOUBLE START'RECNUM; <<BEGINNING RECORD NUMBER OF FILE>>     <<<<01549>>02908000
                  <<MAY BE NON-ZERO IN EXTENT PURGED CASE>>  <<<<01549>>02910000
                                                                        02912000
<<SPOOL FILE SCAN/LIST>>                                                02914000
DOUBLE FRLINE,TOLINE,LINECNT;                                           02916000
DOUBLE DNUM;                                                            02918000
INTEGER DNUM0=DNUM+0,DNUM1=DNUM+1;                                      02920000
INTEGER FSTRING;                                                        02922000
LOGICAL FSTRALL;                                                        02924000
LOGICAL EOFFLAG;                                               <<B0.01>>02926000
ARRAY FSTR(0:40);                                                       02928000
BYTE ARRAY BFSTR(*)=FSTR;                                               02930000
BYTE POINTER                                                   <<00897>>02932000
     FIRSTPARM,                                                <<00897>>02934000
     SECONDPARM,                                               <<00897>>02936000
     THIRDPARM;                                                <<00897>>02938000
                                                               <<xd.m4>>02940000
EQUATE BENTRIES = 10, BENTRY'SIZE=5;                           <<B0.01>>02942000
ARRAY BLOCKTABLE(0:BENTRIES * BENTRY'SIZE);                    <<B0.01>>02944000
INTEGER POINTER BLOCKCP,BLOCKFP;  <<CURRENT,FIRST POINTER>>    <<B0.01>>02946000
DOUBLE POINTER DBLOCKFP = BLOCKFP;                             <<B0.01>>02948000
DOUBLE POINTER DBLOCKCP=BLOCKCP;                               <<B0.01>>02950000
LOGICAL READ'DIR'FLAG;                                         <<B0.01>>02952000
DOUBLE BLOCKNO;                                                <<B0.01>>02954000
<<NOTE EACH BLOCKTABLE ENTRY IS >>                             <<B0.01>>02956000
<<      BLOCKCOUNT      (DOUBLEWORD)>>                         <<B0.01>>02958000
<<      RECORDCOUNT     (DOUBLEWORD)>>                         <<B0.01>>02960000
<<      PAGECOUNT       (DOUBLEWORD)>>                         <<B0.01>>02962000
                                                                        02964000
<<COPY SPOOLFILE VARIABLES>>                                   <<B0.01>>02966000
INTEGER                                                        <<B0.01>>02968000
        NEW'FILEN,                                             <<B0.01>>02970000
        OLD'PRI,                                               <<xd.m4>>02972000
        NEW'XDDN;                                              <<xd.m4>>02974000
LOGICAL                                                        <<xd.m4>>02976000
   COPY'FILES'FLAG,                                            <<xd.m4>>02978000
   INHIBIT'FOPEN,                                              <<xd.m4>>02980000
   NEW'SPOOLFILE,                                              <<xd.m4>>02982000
   FILE'FORMSMSG,                                              <<xd.m4>>02984000
   APPEND;                                                     <<xd.m4>>02986000
                                                               <<xd.m4>>02988000
INTEGER ARRAY NEW'BUFW(0:128);                                 <<xd.m4>>02990000
                                                               <<xd.m4>>02992000
BYTE ARRAY NEW'BUF(*) = NEW'BUFW;                              <<xd.m4>>02994000
                                                               <<xd.m4>>02996000
BYTE ARRAY                                                     <<xd.m4>>02998000
   NEW'FILENAME(0:28),                                         <<xd.m4>>03000000
   OLD'FILENAME(0:28);                                         <<xd.m4>>03002000
                                                               <<xd.m4>>03004000
INTEGER POINTER NEW'XDDNP = NEW'XDDN;                          <<xd.m4>>03006000
                                                               <<xd.m4>>03008000
EQUATE                                                         <<xd.m4>>03010000
   COPY = 2;                                                   <<xd.m4>>03012000
                      <<END OF COPY VARIABLES>>                <<B0.01>>03014000
<<TAPE FILE MANAGEMENT>>                                                03016000
INTEGER FILET,TCOUNT,REEL;                                              03018000
LOGICAL LASTREEL,EOTMARK,FILEEND;                                       03020000
DOUBLE TIME;                                                            03022000
LOGICAL DATE,TIME1=TIME+0,TIME2=TIME+1;                                 03024000
                                                                        03026000
                                                                        03028000
<<COMMAND BUFFER>>                                                      03030000
EQUATE COMMAND'LENGTH = 40;                                    <<B0.00>>03032000
ARRAY CBUF(0:COMMAND'LENGTH);                                  <<B0.00>>03034000
BYTE ARRAY BCBUF(*)=CBUF;                                               03036000
BYTE POINTER BP;                                                        03038000
                                                                        03040000
<<XDD BUFFER>>                                                          03042000
ARRAY DEVFS(0:63);                                                      03044000
ARRAY XDDBUF(0:SIZE'OF'XDD'SUBENTRY-1);                        <<xd.m4>>03046000
BYTE ARRAY BXDDBUF(*)=XDDBUF;                                  <<xd.m4>>03048000
                                                                        03050000
<<LIST OUTPUT BUFFER>>                                                  03052000
ARRAY OBUF(0:127);                                                      03054000
BYTE ARRAY BOBUF(*)=OBUF;                                               03056000
                                                                        03058000
<<SPOOLFILE BUFFERS>>                                                   03060000
ARRAY SBUF(0:1024);                                                     03062000
BYTE ARRAY BSBUF(*)=SBUF;                                               03064000
POINTER SP;                                                             03066000
                                                                        03068000
<<TAPE LABEL BUFFER>>                                                   03070000
ARRAY TBUF(0:40);                                                       03072000
BYTE ARRAY BTBUF(*)=TBUF;                                               03074000
DEFINE  << label record >>                                     <<xd.m4>>03076000
   L0SPOOKID = TBUF(0)#,                                       <<xd.m4>>03078000
   L0EOF     = TBUF(21)#,                                      <<xd.m4>>03080000
   L0LASTREEL= TBUF(22)#,                                      <<xd.m4>>03082000
   L0REEL    = TBUF(23)#,                                      <<xd.m4>>03084000
   L0DATE    = TBUF(24)#,                                      <<xd.m4>>03086000
   L0TIME1   = TBUF(25)#,                                      <<xd.m4>>03088000
   L0TIME2   = TBUF(26)#,                                      <<xd.m4>>03090000
   L0MPE5    = TBUF(30)#;                                      <<xd.m4>>03092000
LOGICAL                                                        <<xd.m4>>03094000
   MPE5TAPE;                                                   <<xd.m4>>03096000
                                                                        03098000
<<TAPE REPLY BUFFER>>                                                   03100000
ARRAY RBUF(0:1);                                                        03102000
BYTE ARRAY BRBUF(*)=RBUF;                                               03104000
                                                                        03106000
<< spook tape directory >>                                     <<ld.m4>>03108000
EQUATE                                                         <<ld.m4>>03110000
   FDIR'ENTRYSIZE = 12,                                        <<xd.m4>>03112000
   FDIR'RECSIZE   = 1020,                                      <<xd.m4>>03114000
   LDEV'ENTRYSIZE = 3;                                         <<ld.m4>>03116000
   ARRAY NEWLDEVS(0:700);                                      <<xd.m4>>03118000
                                                                        03120000
<<COMMANDS>>                                                            03122000
EQUATE CNUM = 18;                                              <<B0.01>>03124000
EQUATE CSIZE=6;                                                         03126000
BYTE ARRAY COMMAND'LIST(0:CNUM*CSIZE-1):=                      <<B0.00>>03128000
      "DEBUG EXIT  XPLAINSHOW  ",                                       03130000
      "TEXT  LIST  FIND  MODE  ",                                       03132000
      "ALTER PURGE INPUT OUTPUT",                              <<B0.00>>03134000
      "HELP  RUN   KILL  QUIT  ",                              <<B0.01>>03136000
      "COPY  APPEND";                                          <<B0.01>>03138000
                                                                        03140000
<<MODES>>                                                               03142000
EQUATE MNUM=2;                                                          03144000
EQUATE MSIZE=8;                                                         03146000
BYTE ARRAY MMODE(0:15):=                                                03148000
      "WIDTH   CONTROLS";                                               03150000
                                                                        03152000
<<ALTER>>                                                               03154000
EQUATE ANUM=3;                                                          03156000
EQUATE ASIZE=6;                                                         03158000
BYTE ARRAY AALTER(0:ANUM * ASIZE - 1):=                        <<B0.00>>03160000
      "PRI   COPIESDEV   ";                                             03162000
                                                                        03164000
<<STATES>>                                                              03166000
BYTE ARRAY STATES(0:23):=                                               03168000
      "ACTIVEREADY OPEN  LOCKED";                                       03170000
                                                                        03172000
<<HEADINGS>>                                                            03174000
                                                               <<01.02>>03176000
                                                               <<01.02>>03178000
ARRAY TAPEID(0:13):=                                                    03180000
      "SPOOLFILETAPE LABEL-HP/3000.";                                   03182000
ARRAY TAPEMPEV(0:1):=                                          <<xd.m4>>03184000
      "MPEV";                                                  <<xd.m4>>03186000
ARRAY MREEL(0:16):=                                                     03188000
      " CHANGE REELS ON LDEV     ? (Y/N) ";                             03190000
ARRAY EREEL(0:17):=                                                     03192000
      " INCORRECT REEL - TRY AGAIN ? (Y/N) ";                           03194000
ARRAY ABORTP(0:12):=                                           <<xd.m4>>03196000
      "PROGRAM ABORTED BY SYSTEM.";                            <<xd.m4>>03198000
ARRAY MSHOW(0:28):=                                                     03200000
      "#FILE   #JOB    FNAME    STATE  DEV/CL   PR COP RFN OWNER ";     03202000
ARRAY MSHOWS(0:18):=                                                    03204000
      "#FILE   #JOB    FNAME    STATE  OWNER ";                         03206000
ARRAY MIN(0:22):=                                                       03208000
      "#FILE   ===>  #FILE   #JOB    DEV/CL    OWNER ";                 03210000
ARRAY MOUT(0:21):=                                                      03212000
      "#FILE   #JOB    DEV/CL   SECTORS      OWNER ";                   03214000
ARRAY MSHWX(0:28):=                                                     03216000
      "#FILE   LDEV    LABEL      SECTORS       LINES      TIME  ";     03218000
                                                                        03220000
SWITCH SWCOM:=                                                          03222000
      DBUGL,                                                            03224000
      EXITL,                                                            03226000
      XPLAL,                                                            03228000
      SHOWL,                                                            03230000
      TEXTL,                                                            03232000
      LISTL,                                                            03234000
      FINDL,                                                            03236000
      MODEL,                                                            03238000
      ALTEL,                                                            03240000
      PURGL,                                                            03242000
      INL  ,                                                            03244000
      OUTL ,                                                   <<B0.00>>03246000
      HELPL,                                                   <<B0.00>>03248000
      RUNL ,                                                   <<B0.00>>03250000
      KILLL,                                                   <<B0.00>>03252000
      QUITL,                                                   <<B0.01>>03254000
      COPYL,                                                   <<B0.01>>03256000
      APPENDL;                                                 <<B0.01>>03258000
                                                                        03260000
DEFINE DEF'MOVEFROMDSEG=                                       <<01726>>03262000
MOVEFROMDSEG(TARGET,DSTN,OFFSET,COUNT);                        <<01726>>03264000
VALUE TARGET,DSTN,OFFSET,COUNT;                                <<01726>>03266000
LOGICAL TARGET,DSTN,OFFSET,COUNT;                              <<01726>>03268000
BEGIN                                                          <<01726>>03270000
   X:=TOS;     <<SAVE RETURN ADDR>>                            <<01726>>03272000
   ASSEMBLE(MFDS 0);                                           <<01726>>03274000
   TOS:=X;     <<RESTORE RETURN ADDR>>                         <<01726>>03276000
END#,                                                          <<01726>>03278000
                                                               <<01726>>03280000
       DEF'MOVETODSEG=                                         <<01726>>03282000
MOVETODSEG(DSTN,OFFSET,SOURCE,COUNT);                          <<01726>>03284000
VALUE DSTN,OFFSET,SOURCE,COUNT;                                <<01726>>03286000
LOGICAL DSTN,OFFSET,SOURCE,COUNT;                              <<01726>>03288000
BEGIN                                                          <<01726>>03290000
   X:=TOS;                                                     <<01726>>03292000
   ASSEMBLE(MTDS 0);                                           <<01726>>03294000
   TOS:=X;     <<RESTORE RETURN ADDR>>                         <<01726>>03296000
END#;                                                          <<01726>>03298000
                                                               <<01726>>03300000
$PAGE                                                          <<04145>>03302000
                                                               <<04145>>03304000
<<**********************************************************>> <<04145>>03306000
<<    EXPLANATION OF IMPORTANT GLOBAL VARIABLES             >> <<04145>>03308000
<<                                                          >> <<04145>>03310000
<<  DEVF - Device file ID, If the 1st. bit is on, then it is>> <<04145>>03312000
<<         an OUTPUT file, off and INPUT file.  ID number   >> <<04145>>03314000
<<         is the integer portion.                          >> <<04145>>03316000
<<  DEVFN- Device file id of currently texted spoolfile.    >> <<ld.m4>>03318000
<<  FILEF- The file number (AFT entry number) of an open    >> <<ld.m4>>03320000
<<         spool file.                                      >> <<ld.m4>>03322000
<<  FILEN- Currently texted file number.                    >> <<ld.m4>>03324000
<<  DEVFS- Logical array containing all the Device File ID's>> <<04145>>03326000
<<         to be used for the current command.              >> <<04145>>03328000
<<  DEVFC- Number of Device File ID's in the array DEVFS for>> <<04145>>03330000
<<         the current command.                             >> <<04145>>03332000
<< SHOWIO- A logical to show which types of Device ID's we  >> <<ld.m4>>03334000
<<         have encountered .  If bit 15=on Output and/or   >> <<04145>>03336000
<<                                    14=on Input           >> <<04145>>03338000
<<  SHOWF- Flag signifying to show all the file information,>> <<04145>>03340000
<<         eg. show PRI, COP, LDEV, etc.                    >> <<04145>>03342000
<<  XDDC - Number of XDD subentries currently in our stack  >> <<ld.m4>>03344000
<<         (DB- area).                                      >> <<ld.m4>>03346000
<<**********************************************************>> <<04145>>03348000
                                                               <<04145>>03350000
<<**********************************************************>> <<04145>>03352000
                                                               <<04145>>03354000
$PAGE "EXTERNAL PROCEDURES"                                    <<xd.m4>>03356000
                                                                        03358000
PROCEDURE CONTROLYPROC;                                        <<B0.00>>03360000
   OPTION FORWARD;                                             <<B0.00>>03362000
PROCEDURE DEBUG;                                                        03364000
   OPTION EXTERNAL;                                                     03366000
INTEGER PROCEDURE SETCRITICAL;                                          03368000
   OPTION EXTERNAL;                                                     03370000
PROCEDURE RESETCRITICAL(C);                                             03372000
   VALUE   C;                                                           03374000
   INTEGER C;                                                           03376000
   OPTION EXTERNAL;                                                     03378000
INTEGER PROCEDURE GETSIR(S);                                            03380000
   VALUE   S;                                                           03382000
   INTEGER S;                                                           03384000
   OPTION EXTERNAL;                                                     03386000
PROCEDURE RELSIR(S,R);                                                  03388000
   VALUE   S,R;                                                         03390000
   INTEGER S,R;                                                         03392000
   OPTION EXTERNAL;                                                     03394000
INTEGER PROCEDURE EXCHANGEDB(D);                                        03396000
   VALUE   D;                                                           03398000
   INTEGER D;                                                           03400000
   OPTION EXTERNAL;                                                     03402000
LOGICAL PROCEDURE CALENDAR;                                             03404000
   OPTION EXTERNAL;                                                     03406000
DOUBLE PROCEDURE CLOCK;                                                 03408000
   OPTION EXTERNAL;                                                     03410000
INTEGER PROCEDURE GETDEVINFO(D,I);                                      03412000
   INTEGER ARRAY I;                                                     03414000
   BYTE ARRAY D;                                                        03416000
   OPTION EXTERNAL;                                                     03418000
LOGICAL PROCEDURE SPOOLEDDEV(D);                                        03420000
   VALUE   D;                                                           03422000
   INTEGER D;                                                           03424000
   OPTION EXTERNAL;                                                     03426000
PROCEDURE SROOSTER(D);                                                  03428000
   VALUE   D;                                                           03430000
   INTEGER D;                                                           03432000
   OPTION EXTERNAL;                                                     03434000
PROCEDURE SRELINKODD(O,D);                                              03436000
   VALUE   O,D;                                                         03438000
   INTEGER D;                                                           03440000
   INTEGER POINTER O;                                                   03442000
   OPTION EXTERNAL;                                                     03444000
INTEGER PROCEDURE SPUTXDD(ODD,DEV,SUBE,XDDSUBP);                        03446000
   VALUE   ODD,DEV;                                                     03448000
   LOGICAL ODD;                                                         03450000
   INTEGER DEV;                                                         03452000
   INTEGER ARRAY SUBE;                                                  03454000
   INTEGER POINTER XDDSUBP;                                             03456000
   OPTION EXTERNAL;                                                     03458000
PROCEDURE SREMOVEXDD(XDDSUBP);                                          03460000
   VALUE   XDDSUBP;                                                     03462000
   INTEGER POINTER XDDSUBP;                                             03464000
   OPTION EXTERNAL;                                                     03466000
INTEGER PROCEDURE FSOPEN(FD,FO,AO,XD,DV,FM,UL,BF,NB,                    03468000
                           FS,NE,IA,FC);                                03470000
   VALUE   FO,AO,XD,UL,BF,NB,FS,NE,IA,FC;                               03472000
   INTEGER XD,UL,BF,NB,NE,IA,FC;                                        03474000
   LOGICAL FO,AO;                                                       03476000
   DOUBLE  FS;                                                          03478000
   BYTE ARRAY FD,DV,FM;                                                 03480000
   OPTION EXTERNAL,VARIABLE;                                            03482000
PROCEDURE FSCLOSE(FN,D,S);                                              03484000
   VALUE   FN,D,S;                                                      03486000
   INTEGER FN,D,S;                                                      03488000
   OPTION EXTERNAL;                                                     03490000
PROCEDURE ERRORON;                                             <<B0.00>>03492000
   OPTION EXTERNAL;                                            <<B0.00>>03494000
PROCEDURE ERROREXIT(INTRINEXIT,ERRWORD,PARAM);                 <<B0.00>>03496000
   VALUE INTRINEXIT,ERRWORD,PARAM;                             <<B0.00>>03498000
   LOGICAL INTRINEXIT,ERRWORD,PARAM;                           <<B0.00>>03500000
   OPTION EXTERNAL;                                            <<B0.00>>03502000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,M,P1,P2,P3,P4,P5,         <<B0.00>>03504000
         D,R,O,DST,C);                                         <<B0.00>>03506000
   VALUE SETNO,MSGNO,M,P1,P2,P3,P4,P5,D,R,O,DST,C;             <<B0.00>>03508000
   INTEGER SETNO,MSGNO,D,DST;                                  <<B0.00>>03510000
   LOGICAL M,P1,P2,P3,P4,P5,R,O,C;                             <<B0.00>>03512000
   OPTION EXTERNAL,VARIABLE;                                   <<B0.00>>03514000
LOGICAL PROCEDURE NEW'FILE'CLOSE(OLD);                         <<B0.01>>03516000
   VALUE OLD;                                                  <<B0.01>>03518000
   LOGICAL OLD;                                                <<B0.01>>03520000
   OPTION FORWARD;                                             <<B0.01>>03522000
                                                               <<B0.01>>03524000
LOGICAL PROCEDURE SFINDODD(DFID,XDDEP);                        <<B0.01>>03526000
   VALUE DFID;                                                 <<B0.01>>03528000
   INTEGER XDDEP;                                              <<B0.01>>03530000
   INTEGER DFID;                                               <<B0.01>>03532000
   OPTION EXTERNAL;                                            <<B0.01>>03534000
                                                               <<B0.01>>03536000
                                                               <<B0.00>>03538000
LOGICAL PROCEDURE VERIFY'BLOCK'STRUCTURE(BUFFER,INDEX,NUMRECS);<<01726>>03540000
                                                              <<SP.MP4>>03542000
   LOGICAL ARRAY BUFFER;                                      <<SP.MP4>>03544000
   INTEGER INDEX,NUMRECS;                                     <<SP.MP4>>03546000
                                                              <<SP.MP4>>03548000
   OPTION FORWARD;                                             <<01726>>03550000
                                                               <<01726>>03552000
   PROCEDURE READ'RECORD(FILENUM, RECORDNUM, BUFFER, RECP,     <<01726>>03554000
        XDDP,BLOCKNUM, ERRNUM);                                <<01726>>03556000
                                                               <<01726>>03558000
      VALUE RECORDNUM, FILENUM, XDDP;                          <<01726>>03560000
      DOUBLE RECORDNUM, BLOCKNUM;                              <<01726>>03562000
      INTEGER POINTER RECP;                                    <<01726>>03564000
      LOGICAL XDDP;                                            <<01726>>03566000
      INTEGER ERRNUM, FILENUM;                                 <<01726>>03568000
      LOGICAL ARRAY BUFFER;                                    <<01726>>03570000
                                                               <<01726>>03572000
      OPTION FORWARD;                                          <<01726>>03574000
                                                                        03576000
INTRINSIC FOPEN,FCLOSE,FREAD,FWRITE,FCONTROL,FGETINFO,FCHECK;           03578000
INTRINSIC WHO,DLSIZE,READ,PRINT,ASCII,BINARY,PRINTOPREPLY;              03580000
INTRINSIC DASCII,DBINARY;                                               03582000
INTRINSIC XCONTRAP,RESETCONTROL,FERRMSG,FFILEINFO,TERMINATE;   <<04145>>03584000
INTRINSIC ARITRAP;                                             <<01.02>>03586000
                                                                        03588000
INTRINSIC CREATE,FATHER,KILL,ACTIVATE,SUSPEND; <<SUBTASKING>>  <<B0.00>>03590000
INTRINSIC GETPROCID,GETPROCINFO; <<SUBTASKING>>                <<B0.01>>03592000
INTRINSIC COMMAND;                                             <<B0.00>>03594000
INTRINSIC FREADDIR;                                            <<B0.01>>03596000
INTRINSIC FWRITEDIR;                                           <<B0.01>>03598000
INTRINSIC FRENAME;                                             <<B0.01>>03600000
INTRINSIC FREADLABEL, FWRITELABEL;                             <<01886>>03602000
$PAGE "ERROR MESSAGES"                                         <<xd.m4>>03604000
$CONTROL SEGMENT=SPOOK1                                                 03606000
                                                                        03608000
PROCEDURE ERRFORM(ERR,FERR,IX);                                         03610000
   VALUE   ERR,FERR;                                                    03612000
   INTEGER ERR,FERR,IX;                                                 03614000
   BEGIN                                                                03616000
   INTEGER CT,IZ,BEG'MSG;                                      <<04145>>03618000
   LOGICAL F;                                                           03620000
   INTEGER ARRAY MESSAG(*) = PB :=                             <<04151>>03622000
       1,12,"NOT INTERACTIVE SESSION ",                                 03624000
       2, 6,"END OF FILE",                                              03626000
       3, 7,"TOO MANY FILES",                                           03628000
       4,12,"INSUFFICIENT CAPABILITY ",                                 03630000
       5,22,"NO FILES FOUND UNDER USER.ACCOUNT SPECIFIED ",    <<04145>>03632000
      19,13,"IMPOSSIBLE INTERNAL ERROR ",                               03634000
      20,10,"INVALID COMMAND NAME",                                     03636000
      21,10,"COMMAND NAME TOO BIG",                                     03638000
      22, 8,"PROMPT I/O ERROR",                                         03640000
      23, 8,"INPUT I/O ERROR ",                                         03642000
      24,10,"UNABLE TO CLOSE FILE",                                     03644000
      25,10,"UNABLE TO PURGE FILE",                                     03646000
      26, 8,"FILE READ ERROR ",                                         03648000
      27, 8,"FILE WRITE ERROR",                                         03650000
      28, 8,"FILE NOT 'READY'",                                         03652000
      29,10,"UNABLE TO OPEN FILE ",                                     03654000
      30,11,"INPUT FILE NOT ALLOWED",                                   03656000
      31, 7,"FILE NOT FOUND",                                           03658000
      32, 8,"INVALID FILE ID ",                                         03660000
      33,10,"UNEXPECTED CHARACTER",                                     03662000
      34, 9,"USER NAME TOO BIG ",                                       03664000
      35,10,"USER NOT ACCESSIBLE ",                                     03666000
      36,10,"ACCOUNT NAME TOO BIG",                                     03668000
      37,11,"ACCOUNT NOT ACCESSIBLE",                                   03670000
      38,11,"INVALID LINE MNEMONIC ",                                   03672000
      39,10,"INVALID LINE NUMBER ",                                     03674000
      40, 9,"INVALID LINE COUNT",                                       03676000
      41, 9,"INVALID LINE RANGE",                                       03678000
      42,16,"NON TERMINATED CHARACTER STRING ",                         03680000
      43,10,"INVALID OPTION NAME ",                                     03682000
      44,12,"INVALID OPTION SEPARATOR",                                 03684000
      45,12,"INVALID OPTION PARAMETER",                                 03686000
      46, 6,"NO TEXT FILE",                                             03688000
      47,11,"FILE NOT 'READY/OPEN' ",                                   03690000
      48,11,"TEXT FILE NOT ALLOWED ",                                   03692000
      49, 9,"MISSING SEMI-COLON",                                       03694000
      50,12,"UNABLE TO OPEN TAPE FILE",                                 03696000
      51,13,"UNABLE TO CLOSE TAPE FILE ",                               03698000
      52, 9,"INVALID TAPE FILE ",                                       03700000
      53,10,"INVALID TAPE FORMAT ",                                     03702000
      54,10,"TAPE FILE READ ERROR",                                     03704000
      55,11,"TAPE FILE WRITE ERROR ",                                   03706000
      56,12,"USER.ACCOUNT NOT ALLOWED",                                 03708000
      57,10,"NO EQUIVALENT DEVICE",                                     03710000
      58,10,"NO EQUIVALENT CLASS ",                                     03712000
      59,12,"NO ROOM IN DEVICE TABLE ",                                 03714000
      60, 8,"MULTI REEL ABORT",                                         03716000
      61,19,"INVALID LENGTH OF RECORD IN TEXT FILE",           <<B0.00>>03718000
      70,12,"FILE IS NOT PROGRAM FILE",                        <<B0.00>>03720000
      71,14,"NO SON PROCESS TO BE DELETED",                    <<B0.00>>03722000
      72,13,"MISSING PROGRAM FILE NAME ",                      <<B0.00>>03724000
      73,13,"UNABLE TO CLOSE COPY FILE",                       <<B0.01>>03726000
      74,13,"UNABLE TO OPEN COPY FILE ",                       <<B0.01>>03728000
      75,11,"SPOOLFILE CREATE ERROR",                          <<B0.01>>03730000
      76,13,"UNABLE TO RENAME COPY FILE",                      <<B0.01>>03732000
   77,13,"DS COPY NOT YET AVAILABLE",                                   03734000
      78,16,"LINE NUMBER IS IN PURGED EXTENT",               <<<<01549>>03736000
      79,9,"INVALID COPY FILE",                                <<04145>>03738000
      80,14,"MISSING DFID OR USER.ACCOUNT",                    <<04145>>03740000
       0, 0;                                                            03742000
   << >>                                                                03744000
   IF (F := (ERR < 0)) THEN ERR := -ERR;                                03746000
   IF ERR < 16 THEN                                                     03748000
      BEGIN MOVE BOBUF(IX) := "*WARNING="; IX:=IX+9; END                03750000
   ELSE                                                                 03752000
      BEGIN MOVE BOBUF(IX) := "*ERROR="; IX:=IX+7; END;                 03754000
   CT := ASCII(ERR,10,BOBUF(IX));                                       03756000
   IX := IX+CT;                                                         03758000
   IF F AND ERR >= 16 THEN                                              03760000
      BEGIN                                                             03762000
      MOVE BOBUF(IX) := " BYTE=";                                       03764000
      IX := IX+6;                                                       03766000
      CT := ASCII(@BP-@BCBUF(2),10,BOBUF(IX));                          03768000
      IX := IX+CT;                                                      03770000
      END;                                                              03772000
   BOBUF(IX) := "*";                                                    03774000
   IX := (IX+3)&ASR(1);                                                 03776000
   IZ := 0;                                                             03778000
   WHILE MESSAG(IZ)<>0 AND MESSAG(IZ)<>ERR DO                           03780000
      IZ := IZ+2+MESSAG(IZ+1);                                          03782000
   MOVE OBUF(IX) := MESSAG(IZ+2),(MESSAG(IZ+1));                        03784000
   BEG'MSG:=IX;                                                <<04145>>03786000
   IX := IX+MESSAG(IZ+1);                                               03788000
   IX := IX&ASL(1);                                                     03790000
   PRINT(OBUF,-IX,0);                                          <<04145>>03792000
   IF FERR <> NO'FILE'ERROR THEN                               <<04145>>03794000
      BEGIN                                                             03796000
        MOVE BOBUF(0):=" ";                                    <<04145>>03798000
        MOVE BOBUF(1):=BOBUF(0),(254);                         <<04145>>03800000
        FERRMSG(FERR,OBUF(0),CT);                              <<04329>>03802000
        IX:=CT ;                                               <<04329>>03804000
        PRINT(OBUF,-IX,0);                                     <<04145>>03806000
      END;                                                              03808000
   END;                                                                 03810000
                                                                        03812000
$CONTROL SEGMENT=SPOOK1                                                 03814000
                                                                        03816000
PROCEDURE ERRMSG(ERR,FERR);                                             03818000
   VALUE   ERR,FERR;                                                    03820000
   INTEGER ERR,FERR;                                                    03822000
   BEGIN                                                                03824000
   INTEGER IX;                                                          03826000
   << >>                                                                03828000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>03830000
   OBUF := "  ";                                                        03832000
   MOVE OBUF(1) := OBUF,(127);                                          03834000
   IX := 0;                                                             03836000
   ERRFORM(-ERR,FERR,IX);                                               03838000
   CRITFLAG := TRUE;                                           <<B0.00>>03840000
   END;                                                                 03842000
$PAGE "EXPLAIN TEXT"                                           <<xd.m4>>03844000
$CONTROL SEGMENT=SPOOK1                                                 03846000
                                                                        03848000
PROCEDURE EXPLAIN;                                                      03850000
   BEGIN                                                                03852000
   INTEGER IX,IZ;                                                       03854000
   LOGICAL F;                                                           03856000
   INTEGER ARRAY XMESSAG(*)=PB:=                               <<04151>>03858000
    %400, 3,"DEBUG ",                                                   03860000
       1,21,"EXIT  <<TERMINATE IF NOT A SON PROCESS>> ",       <<B0.00>>03862000
       2, 3,"XPLAIN",                                                   03864000
       3,23,"SHOW   [ USER [ .ACCOUNT ] ] [ ; [@] [I] [O] ]",           03866000
       3,21,"SHOW   DEVICEFILEID [ , DEVICEFILEID ]....",               03868000
       4,10,"TEXT   DEVICEFILEID ",                                     03870000
       5, 8,"LIST   [ RANGE ]",                                         03872000
       6,20,"FIND   [ @ ] [ ""STRING"" ] [ , FRANGE ] ",       <<04145>>03874000
       7,16,"MODE   [ OPTION [ , OPTION ]...]",                         03876000
       7,16,"       OPTION = WIDTH / CONTROLS",                         03878000
     %10,28,"ALTER {DFID [,DFID[,...]]} [ ; OPTION [ , OPTION ]....]",  03880000
     %10,28,"ALTER {USER [.ACCOUNT]   } [ ; OPTION [ , OPTION ]....]",  03882000
     %10,17,"       OPTION = PRI / COPIES / DEV",                       03884000
     %11,21,"PURGE  DEVICEFILEID [ , DEVICEFILEID ]....",               03886000
   %1012,20,"INPUT  [ USER [ .ACCOUNT ] ] ; TAPEFILE ",                 03888000
   %1012,26,"INPUT  DEVICEFILEID [ , DEVICEFILEID ].. ; TAPEFILE ",     03890000
%1013,25,"OUTPUT [ USER [ .ACCOUNT ] ] ; TAPEFILE [; PURGE] ",<<00204>> 03892000
%1013,28,"OUTPUT DEVFILEID [, DEVFILEID ] .. ; TAPEFILE [; PURGE] ",    03894000
     %14, 2,"HELP",                                            <<B0.00>>03896000
     %15,23,"RUN    PROGRAMFILENAME [ .GROUP [ .ACCOUNT] ]",   <<B0.00>>03898000
     %16,12,"KILL  << SON PROCESS >>",                         <<B0.00>>03900000
     %17,11,"QUIT  << TERMINATE >> ",                          <<B0.00>>03902000
     %20,13,"COPY   [RANGE] [,FILENAME]",                      <<B0.01>>03904000
     %20,28,"COPY   [DFID [,DFID [,...]] ;] [RANGE [,FILENAME]]     ",  03906000
     %20,24,"COPY   [USER [.ACCOUNT] ;]  [RANGE [,FILENAME]]",          03908000
     %21,13,"APPEND [RANGE [,FILENAME]]",                               03910000
     %20,28,"APPEND [DFID [,DFID [,...]] ;] [RANGE [,FILENAME]]     ",  03912000
     %20,24,"APPEND [USER [.ACCOUNT] ;]  [RANGE [,FILENAME]]",          03914000
     %21, 8,"       [END  ]  ",                               <<00204>> 03916000
     %22,0;                                                    <<B0.01>>03918000
   << >>                                                                03920000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>03922000
   OBUF := "  ";                                                        03924000
   MOVE OBUF(1) := OBUF,(127);                                          03926000
   IZ := 0;                                                             03928000
   WHILE (IX := XMESSAG(IZ+1)) <> 0 DO                                  03930000
      BEGIN                                                             03932000
      F := TRUE;                                                        03934000
      TOS := XMESSAG(IZ).(0:8);                                         03936000
      ASSEMBLE(TBC 15);                                                 03938000
      IF <> THEN IF NOT CAP2.(9:1) THEN F := FALSE;                     03940000
      ASSEMBLE(TBC 14);                                                 03942000
      IF <> THEN IF NOT CAP1.(0:1) THEN F := FALSE;                     03944000
      IF F THEN                                                         03946000
         BEGIN                                                          03948000
         MOVE OBUF := XMESSAG(IZ+2),(IX);                               03950000
         PRINT(OBUF,IX,0);                                              03952000
         END;                                                           03954000
      IZ := IZ+2+IX;                                                    03956000
      END;                                                              03958000
   CRITFLAG := TRUE;                                           <<B0.00>>03960000
   END;                                                                 03962000
$PAGE "* * * LOCKXDD * * *"                                    <<xd.m4>>03964000
$CONTROL SEGMENT=SPOOK2                                                 03966000
                                                                        03968000
PROCEDURE LOCKXDD(XDDI);                                                03970000
   VALUE   XDDI;                                                        03972000
   INTEGER XDDI;                                                        03974000
   BEGIN                                                                03976000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>03978000
   << >>                                                                03980000
   @XDD'SUBENTRY := XDDI.IDNUM;                                <<xd.m4>>03982000
   EXCHANGEDB(IF XDDI<0 THEN ODD'DST ELSE IDD'DST);            <<xd.m4>>03984000
   XDDS'SPOOL'STATE := XDDS'LOCKED;                            <<xd.m4>>03986000
   EXCHANGEDB(0);                                                       03988000
   END;                                                                 03990000
$PAGE "* * * COPYXDD * * *"                                    <<xd.m4>>03992000
                                                               <<xd.m4>>03994000
<<**********************************************************>> <<04145>>03996000
<< COPYXDD is sent a File ID by MOVEFROMXDD,ALTERXDD and    >> <<04145>>03998000
<< SPOOLOPEN to copy a XDD subentry from either the ODD or  >> <<xd.m4>>04000000
<< IDD into XDDBUF.  If the sign bit of FID is on, we search>> <<xd.m4>>04002000
<< the ODD; if it is off, the IDD.  If XDDX is non-zero     >> <<xd.m4>>04004000
<< (pointing to the last subentry accessed), the search     >> <<xd.m4>>04006000
<< starts at the subentry after XDDX in the class or device >> <<xd.m4>>04008000
<< chain.  If XDDX is 0 we search from the beginning, start->> <<xd.m4>>04010000
<< ing with the class chain pointed to by the first head    >> <<xd.m4>>04012000
<< entry, and so on with the device chains through the rest >> <<xd.m4>>04014000
<< of the head entries.                                     >> <<xd.m4>>04016000
<<**********************************************************>> <<04145>>04018000
                                                               <<04145>>04020000
$CONTROL SEGMENT=SPOOK2                                                 04022000
                                                                        04024000
LOGICAL PROCEDURE COPYXDD(FID);                                         04026000
   VALUE   FID;                                                         04028000
   INTEGER FID;                                                         04030000
   BEGIN                                                                04032000
   LOGICAL POINTER                                             <<xd.m4>>04034000
      XDD,                                                     <<xd.m4>>04036000
      XDD'HEAD,                                                <<xd.m4>>04038000
      LAST'HEAD,                                               <<xd.m4>>04040000
      XDD'SUBENTRY,                                            <<xd.m4>>04042000
      USER'ACCT;                                               <<xd.m4>>04044000
   INTEGER                                                     <<xd.m4>>04046000
      N, M,                                                    <<xd.m4>>04048000
      INDEX;                                                   <<xd.m4>>04050000
   LOGICAL                                                     <<xd.m4>>04052000
      UF, AF,                                                  <<xd.m4>>04054000
      MATCH;                                                   <<xd.m4>>04056000
   ARRAY NAME(0:7)=Q;                                                   04058000
   << >>                                                                04060000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<xd.m4>>04062000
<< move global variables to Q-relative before exchanging DB >> <<xd.m4>>04064000
   UF := USERF;                                                         04066000
   AF := ACCTF;                                                         04068000
   MOVE NAME := SNAMES,(8);                                             04070000
   INDEX := XDDX;                                                       04072000
   @XDD := 0;                                                  <<xd.m4>>04074000
   EXCHANGEDB(IF FID.IS'ODD=1 THEN ODD'DST ELSE IDD'DST);      <<xd.m4>>04076000
   IF INDEX = 0 THEN    << start at beginning >>               <<xd.m4>>04078000
   BEGIN                                                       <<xd.m4>>04080000
      @XDD'HEAD := SIZE'OF'XDD0; << addr of first head entry >><<xd.m4>>04082000
      @XDD'SUBENTRY := XDDH'FIRST'SUBENTRY;                    <<xd.m4>>04084000
   END                                                         <<xd.m4>>04086000
   ELSE       << take up where we left off >>                  <<xd.m4>>04088000
   BEGIN                                                       <<xd.m4>>04090000
      @XDD'SUBENTRY := INDEX;  << last subentry accessed >>    <<xd.m4>>04092000
      @XDD'HEAD := XDDS'HEAD'INDEX * 4;                        <<xd.m4>>04094000
      @XDD'SUBENTRY := XDDS'NEXT'SUBENTRY;                     <<xd.m4>>04096000
   END;                                                        <<xd.m4>>04098000
                                                               <<04145>>04100000
   <<*******************************************************>> <<04145>>04102000
   << Main loop to search through the XDD until a qualified >> <<xd.m4>>04104000
   << subentry is found, or we run out.  If a USER.ACCOUNT  >> <<xd.m4>>04106000
   << was entered (USERF & ACCTF are true), compare words 2 >> <<xd.m4>>04108000
   << to 9 with that of NAME. Otherwise, check if the File  >> <<xd.m4>>04110000
   << ID (if non-null) sent matches that in word 18 of the  >> <<xd.m4>>04112000
   << XDD subentry.                                         >> <<xd.m4>>04114000
   <<*******************************************************>> <<04145>>04116000
                                                               <<04145>>04118000
   @LAST'HEAD := XDD0'SUBENTRY'AREA - SIZE'OF'XDD'HEAD;        <<xd.m4>>04120000
   WHILE @XDD'HEAD <= @LAST'HEAD DO                            <<xd.m4>>04122000
   BEGIN                                                       <<xd.m4>>04124000
      WHILE @XDD'SUBENTRY <> XDDS'END'OF'CHAIN DO              <<xd.m4>>04126000
      BEGIN                                                    <<xd.m4>>04128000
         IF (XDDS'DEVICE<>0) AND (XDDS'SPOOFLE'LDEV <> 0) THEN <<xd.m4>>04130000
         BEGIN                                                 <<xd.m4>>04132000
            N := IF UF THEN -1 ELSE 3;                         <<xd.m4>>04134000
            M := IF AF THEN 8 ELSE 4;                          <<xd.m4>>04136000
            @USER'ACCT := @XDDS'USER'NAME;                     <<xd.m4>>04138000
            MATCH := TRUE;                                     <<xd.m4>>04140000
            WHILE ((N := N+1) < M) AND MATCH DO                <<xd.m4>>04142000
               IF NAME(N) <> USER'ACCT(N) THEN MATCH := FALSE; <<xd.m4>>04144000
            IF MATCH THEN                                      <<xd.m4>>04146000
               IF FID.IDNUM = 0 THEN GOTO FOUND                <<xd.m4>>04148000
               ELSE                                            <<xd.m4>>04150000
                  IF LOGICAL(FID) = XDDS'DFID'ALL THEN         <<xd.m4>>04152000
                     GOTO FOUND;                               <<xd.m4>>04154000
         END;                                                  <<xd.m4>>04156000
         @XDD'SUBENTRY := XDDS'NEXT'SUBENTRY;                  <<xd.m4>>04158000
      END;                                                     <<xd.m4>>04160000
      @XDD'HEAD := @XDD'HEAD + SIZE'OF'XDD'HEAD;               <<xd.m4>>04162000
      @XDD'SUBENTRY := XDDH'FIRST'SUBENTRY;                    <<xd.m4>>04164000
   END;                                                        <<xd.m4>>04166000
                                                               <<xd.m4>>04168000
   << XDD subentry not found >>                                <<xd.m4>>04170000
   EXCHANGEDB(0);                                              <<xd.m4>>04172000
   XDDX := 0;                                                  <<xd.m4>>04174000
   GOTO QUICKOUT;                                              <<xd.m4>>04176000
                                                               <<04145>>04178000
<<**********************************************************>> <<04145>>04180000
<< Move the entry from the Data Segment (ODD or IDD segment)>> <<04145>>04182000
<< to the users stack via MFDS.                             >> <<04145>>04184000
<<**********************************************************>> <<04145>>04186000
                                                               <<04145>>04188000
FOUND:                                                         <<xd.m4>>04190000
   EXCHANGEDB(0);                                              <<xd.m4>>04192000
   << offset from beginning of xdd >>                          <<xd.m4>>04194000
   XDDX := @XDD'SUBENTRY;                                      <<xd.m4>>04196000
   MOVEFROMDSEG(@XDDBUF,                                       <<xd.m4>>04198000
                 IF FID.IS'ODD=1 THEN ODD'DST ELSE IDD'DST,    <<xd.m4>>04200000
                 XDDX, SIZE'OF'XDD'SUBENTRY);                  <<xd.m4>>04202000
   COPYXDD := TRUE;                                            <<xd.m4>>04204000
                                                               <<xd.m4>>04206000
                                                               <<xd.m4>>04208000
QUICKOUT:                                                      <<xd.m4>>04210000
   END;                                                                 04212000
$PAGE "* * * SHOWERRORS * * *"                                 <<xd.m4>>04214000
<<**********************************************************>> <<04145>>04216000
<<  SHOWERRORS outputs any errors encountered while access- >> <<04145>>04218000
<< ing or attempting to access an XDD entry.                >> <<04145>>04220000
<<**********************************************************>> <<04145>>04222000
                                                               <<04145>>04224000
                                                                        04226000
$CONTROL SEGMENT=SPOOK2                                                 04228000
                                                                        04230000
PROCEDURE SHOWERRORS(SHOW);                                    <<04145>>04232000
  VALUE SHOW;LOGICAL SHOW;                                     <<04145>>04234000
   BEGIN                                                                04236000
   INTEGER C,IX,DF,ERRN,ERRF;                                  <<04145>>04238000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>04240000
                                                               <<04145>>04242000
   <<*******************************************************>> <<04145>>04244000
   <<  Output DEVFID and error number via ERRFORM.          >> <<04145>>04246000
   <<*******************************************************>> <<04145>>04248000
                                                               <<04145>>04250000
   SUBROUTINE SHOWIT;                                                   04252000
      BEGIN                                                             04254000
      IX := 0;                                                          04256000
      OBUF := "  ";                                                     04258000
      MOVE OBUF(1) := OBUF,(127);                                       04260000
      BOBUF(IX) := "#";                                                 04262000
      BOBUF(IX+1) := IF DF<0 THEN "O" ELSE "I";                         04264000
      ASCII(DF.IDNUM,10,BOBUF(IX+2));                          <<xd.m4>>04266000
      IX := IX+8;                                                       04268000
      IF ERRF = 0 OR ERRF = 255 THEN ERRF := NO'FILE'ERROR;    <<04151>>04270000
      ERRFORM(ERRN,ERRF,IX);                                   <<04145>>04272000
      END;                                                              04274000
   << >>                                                                04276000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>04278000
   ERRN := ERRF := 0;                                          <<04145>>04280000
   C := -1;                                                             04282000
   MOVE OBUF := " "; MOVE OBUF(1):=OBUF,(127);                 <<04145>>04284000
                                                               <<04145>>04286000
   IF NOT FILE'FOUND AND NOT SHOW THEN                         <<04145>>04288000
      BEGIN                                                    <<04145>>04290000
         << no files found under user.acct specified >>        <<ld.m4>>04292000
        ERRN :=  5; ERRF := NO'FILE'ERROR; IX:=0;              <<04145>>04294000
        ERRFORM(ERRN,ERRF,IX);                                 <<04145>>04296000
      END;                                                     <<04145>>04298000
                                                               <<04145>>04300000
   <<*******************************************************>> <<04145>>04302000
   <<  For each DEVFID not used in our array DEVFS (not     >> <<04145>>04304000
   << zeroed out) output an error for that DEVFID.          >> <<04145>>04306000
   <<*******************************************************>> <<04145>>04308000
                                                               <<04145>>04310000
   WHILE (C:=C+1) < DEVFC DO                                            04312000
      IF DEVFS(C) <> 0 THEN                                             04314000
         BEGIN                                                          04316000
         DF := DEVFS(C);                                                04318000
         ERRN := 32;    << invalid file id >>                  <<ld.m4>>04320000
         IF SHOWIO.ODDS AND DF > 0 THEN                        <<xd.m4>>04322000
            ERRN := 30;       << input file not allowed >>     <<ld.m4>>04324000
         SHOWIT;                                                        04326000
         END;                                                           04328000
$PAGE                                                          <<04145>>04330000
                                                               <<04145>>04332000
   <<*******************************************************>> <<04145>>04334000
   <<  For each XDD entried copied into our stack for this  >> <<04145>>04336000
   << command, check XDD(25), which, if non zero, conatins  >> <<04145>>04338000
   << error numbers for ERRN and ERRF, put there as the     >> <<04145>>04340000
   << errors were encountered dealing with the XDD entry.   >> <<04145>>04342000
   <<*******************************************************>> <<04145>>04344000
                                                               <<04145>>04346000
   C := 0;                                                              04348000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>04350000
   WHILE (C:=C+1) <= XDDC DO                                            04352000
      BEGIN                                                             04354000
      @XDD'SUBENTRY := @XDD'SUBENTRY - SIZE'OF'XDD'SUBENTRY;   <<xd.m4>>04356000
      IF (XDDS'DEVICE <> 0) AND (XDDS'SHOW'ERRS <> 0) THEN     <<xd.m4>>04358000
         BEGIN                                                          04360000
         << copy device file id and idd'or'odd bit >>          <<xd.m4>>04362000
         DF := XDDS'DFID'ALL;                                  <<xd.m4>>04364000
         ERRN := XDDS'SPOOK'ERR;                               <<xd.m4>>04366000
         ERRF := XDDS'FILESYS'ERR;                             <<xd.m4>>04368000
         SHOWIT;                                                        04370000
         END;                                                           04372000
      END;                                                              04374000
   CRITFLAG := TRUE;                                           <<B0.00>>04376000
   END;                                                                 04378000
$PAGE "* * * SHOWXDD * * *"                                    <<xd.m4>>04380000
                                                                        04382000
$CONTROL SEGMENT=SPOOK2                                                 04384000
                                                                        04386000
PROCEDURE SHOWXDD(FLAG,DFID);                                           04388000
   VALUE   FLAG,DFID;                                                   04390000
   LOGICAL FLAG;                                                        04392000
   INTEGER DFID;                                                        04394000
   BEGIN                                                                04396000
   INTEGER IX,IY,DEV,CT,JPRIME;                                         04398000
   LOGICAL OUT;                                                         04400000
   LOGICAL POINTER                                             <<ld.m4>>04402000
      LDT,                                                     <<ld.m4>>04404000
      DCT,                                                     <<xd.m4>>04406000
      XDD'SUBENTRY;                                            <<xd.m4>>04408000
   BYTE POINTER XDD'BSUBENTRY;                                 <<xd.m4>>04410000
   DOUBLE POINTER DCTD=DCT;                                    <<ld.m4>>04412000
   ARRAY CL(0:9)=Q;                                                     04414000
   DOUBLE DCL0=CL+0,DCL1=CL+2;                                          04416000
   BYTE POINTER BCL;                                                    04418000
   ARRAY DAYS(0:11)=PB:=                                                04420000
      0,31,60,91,121,152,182,                                           04422000
      213,244,274,305,335;                                              04424000
   << >>                                                                04426000
   SUBROUTINE SHOWSECT;                                                 04428000
      BEGIN                                                             04430000
      TOS := 0;                                                         04432000
      TOS := XDDS'NUMBER'EXTENTS;                              <<xd.m4>>04434000
      IF = THEN TOS := TOS+1;                                           04436000
      << number of sectors / spoofle extent >>                 <<xd.m4>>04438000
      TOS := LOGICAL(TOS-1)**ABSOLUTE(%1104);                           04440000
      TOS := TOS+DOUBLE(XDDS'LAST'EXTENT'SIZE);                <<xd.m4>>04442000
      CT := DASCII(*,10,BCL(4));                                        04444000
      MOVE BOBUF(IX+10-CT-((12-CT)/4)*2) := BCL(4),(CT);                04446000
      IX := IX+11;                                                      04448000
      END;                                                              04450000
   << >>                                                                04452000
   OBUF := "  ";                                                        04454000
   MOVE OBUF(1) := OBUF,(127);                                          04456000
   @XDD'SUBENTRY := @XDDBUF;                                   <<xd.m4>>04458000
   @XDD'BSUBENTRY := @BXDDBUF;                                 <<xd.m4>>04460000
   OUT := XDDS'DFID'IN'OR'OUT;                                 <<xd.m4>>04462000
   IX := 0;                                                             04464000
   @BCL := @CL&LSL(1);                                                  04466000
   IF FLAG.(12:1) THEN                                                  04468000
      BEGIN                                                             04470000
      BOBUF(IX) := "#";                                                 04472000
      BOBUF(IX+1) := IF DFID < 0 THEN "O" ELSE "I";                     04474000
      ASCII(DFID.IDNUM,10,BOBUF(IX+2));                        <<xd.m4>>04476000
      MOVE BOBUF(IX+8) := "===>";                                       04478000
      IX := IX+14;                                                      04480000
      END;                                                              04482000
   BOBUF(IX) := "#";                                                    04484000
   BOBUF(IX+1) := IF OUT THEN "O" ELSE"I";                              04486000
   ASCII(XDDS'DFID'NUMBER,10,BOBUF(IX+2));                     <<xd.m4>>04488000
   IX := IX+8;                                                          04490000
   IF NOT FLAG THEN                                                     04492000
      BEGIN                                                             04494000
      IF XDDS'JOB'NUMBER <> 0 THEN                             <<xd.m4>>04496000
         BEGIN                                                          04498000
         BOBUF(IX) := "#";                                              04500000
         BOBUF(IX+1) := IF XDDS'JOB'TYPE<=1 THEN "S" ELSE"J";  <<xd.m4>>04502000
         JPRIME := 0;                                                   04504000
         IF NOT (1<=integer(XDDS'JOB'TYPE)<=2) THEN            <<xd.m4>>04506000
            BEGIN                                                       04508000
            JPRIME := 1;                                                04510000
            BOBUF(IX+2) := "'";                                         04512000
            END;                                                        04514000
         ASCII(XDDS'JOB'NUMBER,10,BOBUF(IX+2+JPRIME));         <<xd.m4>>04516000
         END;                                                           04518000
      IX := IX+8;                                                       04520000
      IF FLAG.(12:2) = 0 THEN                                           04522000
         BEGIN                                                          04524000
         MOVE BOBUF(IX) := XDDSB'FILE'NAME,(8);                <<xd.m4>>04526000
         IX := IX+9;                                                    04528000
         MOVE BOBUF(IX) := STATES(XDDS'SPOOL'STATE*6),(6);     <<xd.m4>>04530000
         IX := IX+7;                                                    04532000
         END;                                                           04534000
      IF FLAG.(12:3) <> 0 THEN                                          04536000
         BEGIN                                                          04538000
         IF XDDS'CLASS THEN                                    <<xd.m4>>04540000
            BEGIN                                                       04542000
            DEV := -XDDS'DEVICE;                               <<xd.m4>>04544000
            @LDT := 0;                                         <<ld.m4>>04546000
            EXCHANGEDB(LDT'DST);                               <<ld.m4>>04548000
            @DCT := LDT'DCT'BASE;                              <<ld.m4>>04550000
            WHILE (DEV:=DEV+1) < 0 DO                                   04552000
               @DCT := @DCT+integer(DCT'NEXT'ENTRY);           <<ld.m4>>04554000
            DCL0 := DCTD;                                      <<ld.m4>>04556000
            DCL1 := DCTD(1);                                   <<ld.m4>>04558000
            EXCHANGEDB(0);                                              04560000
            MOVE BOBUF(IX) := BCL,(8);                                  04562000
            END                                                         04564000
         ELSE                                                           04566000
            ASCII(XDDS'DEVICE,10,BOBUF(IX));                   <<xd.m4>>04568000
         IX := IX+10;                                                   04570000
         END;                                                           04572000
      IF FLAG.(14:1) THEN                                               04574000
         BEGIN                                                          04576000
         IF OUT THEN                                                    04578000
            BEGIN                                                       04580000
            ASCII(XDDS'OUTPUT'PRIORITY,-10,BOBUF(IX));         <<xd.m4>>04582000
            ASCII(ODDS'NUMBER'COPIES,-10,BOBUF(IX+4));         <<xd.m4>>04584000
            END;                                                        04586000
         IX := IX+6;                                                    04588000
         IF IDDS'RESTART THEN BOBUF(IX) := "R";                <<xd.m4>>04590000
         IF ODDS'FORMS'ON'DEVICE OR ODDS'FORMS'IN'FILE         <<xd.m4>>04592000
            THEN BOBUF(IX+1) := "F";                           <<04145>>04594000
         IF XDDS'SPACED'OUT THEN BOBUF(IX+2) := "N";           <<xd.m4>>04596000
         IX := IX+4;                                                    04598000
         END;                                                           04600000
      IF FLAG.(13:1) THEN                                               04602000
         BEGIN                                                          04604000
         SHOWSECT;                                                      04606000
         IX := IX+1;                                                    04608000
         END;                                                           04610000
      MOVE BOBUF(IX) := XDDSB'USER'NAME,(8);                   <<xd.m4>>04612000
      SCAN BOBUF(IX) UNTIL "  ",1;                                      04614000
      IX := TOS-@BOBUF;                                                 04616000
      BOBUF(IX) := ".";                                                 04618000
      MOVE BOBUF(IX+1) := XDDSB'ACCOUNT'NAME,(8);              <<xd.m4>>04620000
      IX := IX+9;                                                       04622000
      END                                                               04624000
   ELSE                                                                 04626000
      BEGIN                                                             04628000
      CT := ASCII(XDDS'SPOOFLE'LDEV,8,BCL(4));                 <<xd.m4>>04630000
      IF CT = 0 THEN CT := 1;                                           04632000
      BOBUF(IX) := "%";                                                 04634000
      MOVE BOBUF(IX+1) := BCL(10-CT),(CT);                              04636000
      CL := XDDS'MSW'LABEL;                                    <<xd.m4>>04638000
      CL(1) := XDDS'LSW'LABEL;                                 <<xd.m4>>04640000
      CT := DASCII(DCL0,8,BCL(5));                                      04642000
      IF CT = 0 THEN CT := 1;                                           04644000
      CT := CT+1;                                                       04646000
      BCL(16-CT) := "%";                                                04648000
      MOVE BOBUF(IX+4+(12-CT)/2) := BCL(16-CT),(CT);                    04650000
      IX := IX+17;                                                      04652000
      SHOWSECT;                                                         04654000
      TOS := 0;                                                         04656000
      TOS := XDDS'MSW'RECORD'COUNT;                            <<xd.m4>>04658000
      TOS := XDDS'LSW'RECORD'COUNT;                            <<xd.m4>>04660000
      CT := DASCII(*,10,BCL(4));                                        04662000
      MOVE BOBUF(IX+12-CT-((12-CT)/4)*2) := BCL(4),(CT);                04664000
      IX := IX+16;                                                      04666000
      CL(0) := XDD'SUBENTRY(28);     << date >>                <<xd.m4>>04668000
      CL(1) := XDD'SUBENTRY(29);     << time >>                <<xd.m4>>04670000
      IF DCL0 <> 0D THEN                                                04672000
         BEGIN                                                          04674000
         BCL(8) := " ";                                                 04676000
         MOVE BCL(9) := BCL(8),(4);                                     04678000
         ASCII(XDDS'MINUTE,-10,BCL(12));                       <<xd.m4>>04680000
         BCL(10) := ":";                                                04682000
         ASCII(XDDS'HOUR,-10,BCL(9));                          <<xd.m4>>04684000
                                                               <<*time>>04686000
         << shift in last bit of day of year >>                <<*time>>04688000
         DCL0 := DCL0&DLSR(8);                                          04690000
         CL(1) := CL(1)&LSR(7);                                         04692000
         IF CL(0).(14:2) <> 0 AND CL(1) >= 60 THEN                      04694000
            CL(1) := CL(1)+1;    << leap year >>               <<*time>>04696000
                                                               <<*time>>04698000
         << Day of year must be at least 0 >>                  <<*time>>04700000
         IF CL(1) > 0 THEN                                     <<*time>>04702000
            BEGIN                                              <<*time>>04704000
            << now OK to move time in >>                       <<*time>>04706000
            MOVE BOBUF(IX) := BCL(8),(5);                      <<*time>>04708000
            IX := IX+6;                                        <<*time>>04710000
            IY := 12;                                          <<*time>>04712000
            DO IY := IY-1 UNTIL CL(1) > DAYS(IY);              <<*time>>04714000
            CL(1) := CL(1)-DAYS(IY);                           <<*time>>04716000
            IY := IY+1;                                        <<*time>>04718000
            BCL(8) := " ";                                     <<*time>>04720000
            MOVE BCL(9) := BCL(8),(7);                         <<*time>>04722000
            ASCII(CL(0),-10,BCL(15));                          <<*time>>04724000
            BCL(13) := "/";                                    <<*time>>04726000
            ASCII(CL(1),-10,BCL(12));                          <<*time>>04728000
            BCL(10) := "/";                                    <<*time>>04730000
            ASCII(IY,-10,BCL(9));                              <<*time>>04732000
            MOVE BOBUF(IX) := BCL(8),(8);                      <<*time>>04734000
            IX := IX+10;                                       <<*time>>04736000
            END;                                               <<*time>>04738000
         END;                                                  <<*time>>04740000
      END;                                                              04742000
   IF FLAG.(12:2) = 0 THEN  BEGIN   CRITFLAG := FALSE;         <<B0.00>>04744000
      IF CONTROLYFLAG THEN CONTROLYPROC; END;                  <<B0.00>>04746000
   PRINT(OBUF,-IX,0);                                                   04748000
   IF FLAG.(12:2) = 0 THEN CRITFLAG := TRUE;                   <<B0.00>>04750000
   END;                                                                 04752000
$PAGE "COMMAND STRING PARSING ROUTINES"                        <<xd.m4>>04754000
                                                                        04756000
$CONTROL SEGMENT=SPOOK1                                                 04758000
                                                                        04760000
LOGICAL PROCEDURE GETUSAC;                                              04762000
   BEGIN                                                                04764000
   << >>                                                                04766000
   DEVF := 0;                                                           04768000
   USERF := TRUE;                                                       04770000
   ACCTF := TRUE;                                                       04772000
   SNAMES := "  ";                                                      04774000
   MOVE SNAMES(1) := SNAMES,(7);                                        04776000
   IF BP = CR  OR BP = ";" THEN                                <<04145>>04778000
      MOVE SUSERN := USERN,(16)                                         04780000
   ELSE                                                                 04782000
      BEGIN                                                             04784000
      IF BP = "@" THEN                                                  04786000
         BEGIN                                                          04788000
         USERF := FALSE;                                                04790000
         IF CAP1.(0:2)=0 THEN                                           04792000
            BEGIN                                                       04794000
            WARN := 4;                                                  04796000
            MOVE SUSERN := USERN,(8);                                   04798000
            USERF := 1;                                                 04800000
            END;                                                        04802000
         CNT := 1;                                                      04804000
         END                                                            04806000
      ELSE                                                              04808000
         BEGIN                                                          04810000
         MOVE BP := BP WHILE AS,0;                                      04812000
         IF S0 <> @BP THEN MOVE * := * WHILE ANS,0;                     04814000
         CNT := TOS-@BP;                                                04816000
         DEL;                                                           04818000
         IF NOT (1<=CNT<=8) THEN                                        04820000
            << user name too big >>                            <<ld.m4>>04822000
            BEGIN ERRN := 34; GOTO LX; END;                             04824000
         MOVE SUSERN := BP,(CNT);                                       04826000
         IF (CAP1.(0:2)=0) AND (SUSERN<>USERN,(8)) THEN                 04828000
            << user not accessible >>                          <<ld.m4>>04830000
            BEGIN ERRN := 35; GOTO LX; END;                             04832000
         END;                                                           04834000
      @BP := @BP+CNT;                                                   04836000
      IF BP = CR  OR BP = ";" THEN                             <<04145>>04838000
         MOVE SACCTN := ACCTN,(8)                                       04840000
      ELSE                                                              04842000
         BEGIN                                                          04844000
         IF BP <> "." THEN                                              04846000
            << unexpected character >>                         <<ld.m4>>04848000
            BEGIN ERRN := 33; GOTO LX; END;                             04850000
         @BP := @BP+1;                                                  04852000
         IF BP = "@" THEN                                               04854000
            BEGIN                                                       04856000
            ACCTF := FALSE;                                             04858000
            IF CAP1.(0:1)=0 THEN                                        04860000
               BEGIN                                                    04862000
               WARN := 4;                                               04864000
               MOVE SACCTN := ACCTN,(8);                                04866000
               ACCTF := 1;                                              04868000
               END;                                                     04870000
            CNT := 1;                                                   04872000
            END                                                         04874000
         ELSE                                                           04876000
            BEGIN                                                       04878000
            MOVE BP := BP WHILE AS,0;                                   04880000
            IF S0 <> @BP THEN MOVE * := * WHILE ANS,0;                  04882000
            CNT := TOS-@BP;                                             04884000
            DEL;                                                        04886000
            IF NOT (1<=CNT<=8) THEN                                     04888000
               << account name too big >>                      <<ld.m4>>04890000
               BEGIN ERRN := 36; GOTO LX; END;                          04892000
            MOVE SACCTN := BP,(CNT);                                    04894000
            IF (CAP1.(0:1)=0) AND (SACCTN<>ACCTN,(8)) THEN              04896000
               << account not accessible >>                    <<ld.m4>>04898000
               BEGIN ERRN := 37; GOTO LX; END;                          04900000
            END;                                                        04902000
         @BP := @BP+CNT;                                                04904000
         END;                                                           04906000
      END;                                                              04908000
   GETUSAC := TRUE;                                                     04910000
LX:                                                                     04912000
   END;                                                                 04914000
$PAGE                                                          <<xd.m4>>04916000
                                                               <<xd.m4>>04918000
$CONTROL SEGMENT=SPOOK1                                                 04920000
                                                                        04922000
<<**********************************************************>> <<04145>>04924000
<< GETDEVF obtains a device file id from the command string >> <<04145>>04926000
<< and places it in the device file array DEVFS and updates >> <<04145>>04928000
<< the count DEVFC, assuming no errors.                     >> <<04145>>04930000
<<**********************************************************>> <<04145>>04932000
                                                               <<04145>>04934000
LOGICAL PROCEDURE GETDEVF;                                              04936000
   BEGIN                                                                04938000
   INTEGER DEV'CNT;                                            <<04145>>04940000
   LOGICAL OUTPUT,FOUND;                                       <<04145>>04942000
   << >>                                                                04944000
   ERRN := 32;      << assume invalid file id >>               <<ld.m4>>04946000
   DEVF := 0;                                                           04948000
   USERF := TRUE;                                                       04950000
   ACCTF := TRUE;                                                       04952000
   SNAMES := "  ";                                                      04954000
   MOVE SNAMES(1) := SNAMES,(7);                                        04956000
                                                               <<04145>>04958000
   <<*******************************************************>> <<04145>>04960000
   << Check for proper string.  If we have a *, then check  >> <<04145>>04962000
   << if a file has been texted in, (DEVice File Number<>0),>> <<04145>>04964000
   << if not, error condition.                              >> <<04145>>04966000
   <<*******************************************************>> <<04145>>04968000
                                                               <<04145>>04970000
   IF BP = "#" OR BP = "*" OR BP = NUMERIC THEN                         04972000
      BEGIN                                                             04974000
      IF BP = "*" THEN                                                  04976000
         BEGIN                                                          04978000
         IF FILEN = 0 THEN      << no text file >>             <<ld.m4>>04980000
            BEGIN ERRN := 46; GOTO LX; END;                             04982000
         @BP := @BP+1;                                                  04984000
         DEVF := DEVFN;                                                 04986000
         END                                                            04988000
                                                               <<04145>>04990000
      <<****************************************************>> <<04145>>04992000
      << Otherwise we have a device file Id.  If it begins  >> <<04145>>04994000
      << with "#", check Id for "I" or "O" and set FLAG     >> <<04145>>04996000
      << accordingly, TRUE for O, FALSE for I.              >> <<04145>>04998000
      <<****************************************************>> <<04145>>05000000
                                                               <<04145>>05002000
      ELSE                                                              05004000
         BEGIN                                                          05006000
         IF BP = "#" THEN                                               05008000
            BEGIN                                                       05010000
            @BP := @BP+1;                                               05012000
            MOVE BP:=BP WHILE AS; <<UPSHIFT ALPHA         >>   <<01.02>>05014000
            IF BP = "I" THEN OUTPUT := FALSE                   <<04145>>05016000
            ELSE IF BP = "O" THEN OUTPUT := TRUE               <<04145>>05018000
                 ELSE GOTO LX;                                          05020000
                 @BP := @BP+1;                                          05022000
            END                                                         05024000
         ELSE      << must be numeric >>                       <<ld.m4>>05026000
            OUTPUT := TRUE;                                    <<04145>>05028000
$PAGE                                                          <<04145>>05030000
        <<**************************************************>> <<04145>>05032000
        << Get ID number and set top bit of DEVF on for     >> <<04145>>05034000
        << OUTPUT and off for INPUT                         >> <<04145>>05036000
        <<**************************************************>> <<04145>>05038000
                                                               <<04145>>05040000
         MOVE BP := BP WHILE N,1;                                       05042000
         CNT := TOS-@BP;                                                05044000
         DEVF := BINARY(BP,CNT);                                        05046000
         IF <> THEN GOTO LX;                                            05048000
         IF DEVF.IS'ODD <> 0 THEN GOTO LX;                     <<xd.m4>>05050000
         @BP := @BP+CNT;                                                05052000
         DEVF.IS'ODD := OUTPUT;                                <<xd.m4>>05054000
         END;                                                           05056000
                                                               <<04145>>05058000
      <<****************************************************>> <<04145>>05060000
      <<  Check to see if the Dev ID exists already in the  >> <<04145>>05062000
      << array DEVFS (In case of duplicate Device file      >> <<04145>>05064000
      << ID's.) If not, place it in the array at DEVFC and  >> <<04145>>05066000
      << update the count DEVFC by one.                     >> <<04145>>05068000
      <<****************************************************>> <<04145>>05070000
                                                               <<04145>>05072000
      FOUND := FALSE;                                          <<04145>>05074000
      DEV'CNT := -1;                                           <<04145>>05076000
      WHILE (DEV'CNT:=DEV'CNT+1) < DEVFC DO                    <<04145>>05078000
         IF DEVF = INTEGER(DEVFS(DEV'CNT)) THEN FOUND := TRUE; <<04145>>05080000
      IF NOT FOUND THEN                                        <<04145>>05082000
         BEGIN                                                          05084000
         DEVFS(DEVFC) := DEVF;                                          05086000
         DEVFC := DEVFC+1;                                              05088000
         END;                                                           05090000
      MOVE SUSERN := USERN,(16);                                        05092000
      IF CAP1.(0:2) <> 0 THEN USERF := FALSE;                           05094000
      IF CAP1.(0:1) <> 0 THEN ACCTF := FALSE;                           05096000
      GETDEVF := TRUE;                                                  05098000
      ERRN := 0;                                                        05100000
      END;                                                              05102000
LX:                                                                     05104000
   END;                                                                 05106000
                                                                        05108000
$CONTROL SEGMENT=SPOOK1                                                 05110000
                                                                        05112000
<<---------------------------------------------------------->> <<xd.m4>>05114000
<< GETDNUM scans the command string for an ASCII number     >> <<xd.m4>>05116000
<< which it returns as a binary value in DNUM.              >> <<xd.m4>>05118000
<<---------------------------------------------------------->> <<xd.m4>>05120000
                                                               <<xd.m4>>05122000
LOGICAL PROCEDURE GETDNUM;                                              05124000
   BEGIN                                                                05126000
   INTEGER Y,Z;                                                         05128000
   << >>                                                                05130000
   Z := 0;                                                              05132000
   IF BP = "+" OR BP = "-" THEN Z := 1;                                 05134000
   MOVE BP(Z) := BP(Z) WHILE N,1;                                       05136000
   Y := TOS-@BP(Z);                                                     05138000
   IF Y = 0 THEN                                                        05140000
      BEGIN                                                             05142000
      IF Z = 0 THEN GETDNUM := 2;                                       05144000
      GOTO LX;                                                          05146000
      END;                                                              05148000
   DNUM := DBINARY(BP,Z+Y);                                             05150000
   IF <> THEN GOTO LX;                                                  05152000
   @BP := @BP+Z+Y;                                                      05154000
   GETDNUM := TRUE;                                                     05156000
LX:                                                                     05158000
   END;                                                                 05160000
$PAGE                                                          <<infil>>05162000
$CONTROL SEGMENT=SPOOK1                                                 05164000
                                                                        05166000
<<---------------------------------------------------------->> <<xd.m4>>05168000
<< GETLINE is called by LINERANGE to scan the command string>> <<xd.m4>>05170000
<< for a line number.                                       >> <<xd.m4>>05172000
<<---------------------------------------------------------->> <<xd.m4>>05174000
                                                               <<xd.m4>>05176000
LOGICAL PROCEDURE GETLINE(LAST);                                        05178000
   VALUE   LAST;                                                        05180000
   LOGICAL LAST;                                                        05182000
   BEGIN                                                                05184000
   DOUBLE DLINE;                                                        05186000
   LOGICAL RESULT;                                             <<xd.m4>>05188000
   << >>                                                                05190000
   ERRN := 39;    << invalid line number >>                    <<ld.m4>>05192000
   DLINE := IF FLINE = -1D THEN START'RECNUM  ELSE FLINE;     <<<01549>>05194000
   IF BP <> CR  THEN                                           <<04145>>05196000
      BEGIN                                                             05198000
      IF BP = "*" THEN                                                  05200000
         @BP := @BP+1                                                   05202000
      ELSE                                                              05204000
         IF BP = ALPHA THEN                                             05206000
            BEGIN                                                       05208000
            IF BP = "FIRST" THEN                                        05210000
               BEGIN                                                    05212000
               DLINE := START'RECNUM;                        <<<<01549>>05214000
               @BP := @BP+5;                                            05216000
               END                                                      05218000
            ELSE                                                        05220000
               IF BP = "LAST" THEN                                      05222000
                  BEGIN                                                 05224000
                  DLINE := EOFLINE;                                     05226000
                  @BP := @BP+4;                                         05228000
                  END                                                   05230000
            ELSE                                               <<B0.01>>05232000
               IF BP = "EOF" AND LAST THEN                     <<B0.01>>05234000
                  BEGIN                                        <<B0.01>>05236000
                  DLINE := EOFLINE;                            <<B0.01>>05238000
                  EOFFLAG := TRUE;                             <<B0.01>>05240000
                  @BP := @BP + 3;                              <<B0.01>>05242000
                  END                                          <<B0.01>>05244000
               ELSE       << invalid line mnemonic >>          <<ld.m4>>05246000
                  BEGIN ERRN := 38; GOTO LX; END;                       05248000
            END                                                         05250000
         ELSE                                                           05252000
            BEGIN                                                       05254000
            IF (RESULT := GETDNUM) = 0 THEN GOTO LX;           <<xd.m4>>05256000
            IF RESULT THEN DLINE := DNUM;                      <<xd.m4>>05258000
            END;                                                        05260000
      WHILE BP = "+" OR BP = "-" DO                                     05262000
         BEGIN                                                          05264000
         IF NOT GETDNUM THEN GOTO LX;                                   05266000
         DLINE := DLINE+DNUM;                                           05268000
         END;                                                           05270000
      IF DLINE < 0D THEN GOTO LX;                                       05272000
      IF DLINE < START'RECNUM THEN                           <<<<01549>>05274000
      BEGIN                                                  <<<<01549>>05276000
         ERRN := 78; <<LINENUM IN A PURGED EXTENT>>          <<<<01549>>05278000
         GO TO LX;                                           <<<<01549>>05280000
      END;                                                   <<<<01549>>05282000
      IF DLINE > EOFLINE THEN GOTO LX;                                  05284000
      END;                                                              05286000
   IF LAST                                                              05288000
      THEN TOLINE := DLINE                                              05290000
      ELSE FRLINE := DLINE;                                             05292000
   GETLINE := TRUE;                                                     05294000
   ERRN := 0;                                                           05296000
LX:                                                                     05298000
   END;                                                                 05300000
$PAGE                                                          <<04145>>05302000
<<**********************************************************>> <<04145>>05304000
<< GET'NEW'FILE, called by LINERANGE, parses the file to be >> <<04145>>05306000
<< copied to and places it in NEW'FILENAME.  The file must  >> <<04145>>05308000
<< begin with a "*", "$", or a alphabetic character.        >> <<04145>>05310000
<<**********************************************************>> <<04145>>05312000
                                                               <<04145>>05314000
$CONTROL SEGMENT = SPOOK1                                      <<B0.01>>05316000
                                                               <<B0.01>>05318000
LOGICAL PROCEDURE GET'NEW'FILE;                                <<B0.01>>05320000
<<>>                                                           <<B0.01>>05322000
BEGIN                                                          <<B0.01>>05324000
INTEGER TCOUNT,T;                                              <<B0.01>>05326000
<<>>                                                           <<B0.01>>05328000
MOVE OLD'FILENAME := NEW'FILENAME,(29);                        <<B0.01>>05330000
IF BP <> CR  THEN                                              <<04145>>05332000
   BEGIN                                                       <<B0.01>>05334000
   IF BP = "," THEN                                            <<B0.01>>05336000
      BEGIN                                                    <<B0.01>>05338000
      @BP := @BP + 1;                                          <<B0.01>>05340000
     IF BP <> "*" AND BP <> "$" AND BP <> ALPHA THEN           <<04145>>05342000
        BEGIN                                                  <<04145>>05344000
          ERRN := 79;   << invalid copy file >>                <<ld.m4>>05346000
          GO TO LX;                                            <<04145>>05348000
        END;                                                   <<04145>>05350000
      SCAN BP UNTIL %6473,1; <<CR ;>>                          <<B0.01>>05352000
      TCOUNT := TOS;                                           <<B0.01>>05354000
      MOVE NEW'FILENAME := BP,(T:=TCOUNT-@BP+1);               <<B0.01>>05356000
      @BP := @BP+T-1;                                          <<B0.01>>05358000
      IF CARRY THEN GO TO LX1;                                 <<B0.01>>05360000
      END                                                      <<B0.01>>05362000
   ELSE MOVE NEW'FILENAME := "  " ;                            <<B0.01>>05364000
   END                                                         <<B0.01>>05366000
ELSE                                                           <<B0.01>>05368000
   MOVE NEW'FILENAME := "  ";                                  <<B0.01>>05370000
LX1:                                                           <<B0.01>>05372000
   GET'NEW'FILE := TRUE;                                       <<B0.01>>05374000
LX:                                                            <<B0.01>>05376000
   END;                                                        <<B0.01>>05378000
$PAGE                                                          <<04145>>05380000
                                                               <<B0.01>>05382000
<<---------------------------------------------------------->> <<xd.m4>>05384000
<< LINERANGE parses the command string for the range of     >> <<xd.m4>>05386000
<< lines to be used in the command.  FRLINE is the line     >> <<xd.m4>>05388000
<< number of the first line, and TOLINE is the last line of >> <<xd.m4>>05390000
<< of the range.                                            >> <<xd.m4>>05392000
<<---------------------------------------------------------->> <<xd.m4>>05394000
                                                                        05396000
$CONTROL SEGMENT=SPOOK1                                                 05398000
                                                                        05400000
LOGICAL PROCEDURE LINERANGE(SKAN);                                      05402000
   VALUE   SKAN;                                                        05404000
   LOGICAL SKAN;                                                        05406000
   BEGIN                                                                05408000
   << >>                                                                05410000
   IF BP = "ALL" THEN                                                   05412000
      BEGIN                                                             05414000
      @BP := @BP+3;                                                     05416000
      FRLINE := START'RECNUM;                                <<<<01549>>05418000
      TOLINE := EOFLINE;                                                05420000
      LINECNT := EOFLINE+1D;                                            05422000
      END                                                               05424000
   ELSE                                                                 05426000
      BEGIN                                                             05428000
      IF NOT GETLINE(FALSE) THEN GOTO LX;                               05430000
      TOLINE := IF SKAN THEN EOFLINE ELSE FRLINE;                       05432000
      LINECNT := TOLINE-FRLINE+1D;                                      05434000
      IF BP <> CR  THEN                                        <<04145>>05436000
         IF BP = "," THEN                                               05438000
            BEGIN                                                       05440000
            ERRN := 40;    << invalid line count >>            <<ld.m4>>05442000
            @BP := @BP+1;                                               05444000
            IF NOT GETDNUM THEN GOTO LX;                                05446000
            IF (LINECNT := DNUM) <= 0D THEN GOTO LX;                    05448000
            TOLINE := FRLINE+LINECNT-1D;                                05450000
            IF TOLINE > EOFLINE THEN GOTO LX;                           05452000
            ERRN := 0;                                                  05454000
            END                                                         05456000
         ELSE                                                           05458000
            BEGIN                                                       05460000
            IF BP <> "/" THEN   << unexpected character >>     <<ld.m4>>05462000
               BEGIN ERRN := 33; GOTO LX; END;                          05464000
            @BP := @BP+1;                                               05466000
            IF NOT GETLINE(TRUE) THEN GOTO LX;                          05468000
            LINECNT := TOLINE-FRLINE+1D;                                05470000
            IF LINECNT <= 0D THEN                                       05472000
               << invalid line range >>                        <<ld.m4>>05474000
               BEGIN ERRN := 41; GOTO LX; END;                          05476000
            END;                                                        05478000
      END;                                                              05480000
   IF SKAN = COPY THEN <<COPY CALLED PROCEDURE>>               <<B0.01>>05482000
      IF NOT GET'NEW'FILE THEN GO TO LX;                       <<B0.01>>05484000
   IF BP <> CR  THEN   << unexpected character >>              <<ld.m4>>05486000
      BEGIN ERRN := 33; GOTO LX; END;                                   05488000
   LINERANGE := TRUE;                                                   05490000
LX:                                                                     05492000
   END;                                                                 05494000
$PAGE                                                          <<04145>>05496000
$CONTROL SEGMENT=SPOOK1                                                 05498000
                                                                        05500000
LOGICAL PROCEDURE FINDRANGE;                                            05502000
   BEGIN                                                                05504000
   << >>                                                                05506000
   FSTRALL := FALSE;                                                    05508000
   FSTRING := 0;                                                        05510000
   IF BP = "@" THEN                                                     05512000
      BEGIN                                                             05514000
      FSTRALL := TRUE;                                                  05516000
      @BP := @BP+1;                                                     05518000
      END;                                                              05520000
   IF BP = %42 THEN                                                     05522000
      BEGIN                                                             05524000
      @BP := @BP+1;                                                     05526000
      SCAN BP WHILE %6440,1;                                            05528000
      @BP := TOS;                                                       05530000
      SCAN BP(1) UNTIL %6442,1;                                         05532000
      IF CARRY THEN   << non-terminated character string >>    <<ld.m4>>05534000
         BEGIN ERRN := 42; GOTO LX; END;                                05536000
      FSTRING := TOS-@BP;                                               05538000
      @BFSTR := @FSTR&ASL(1);                                           05540000
      MOVE BFSTR := BP,(FSTRING);                                       05542000
      @BP := @BP+FSTRING+1;                                             05544000
      END;                                                              05546000
   IF BP = "," THEN                                                     05548000
      @BP := @BP+1                                                      05550000
   ELSE                                                                 05552000
      IF BP <> CR  THEN   << unexpected character >>           <<ld.m4>>05554000
         BEGIN ERRN := 33; GOTO LX; END;                                05556000
   IF NOT LINERANGE(TRUE) THEN GOTO LX;                                 05558000
   FINDRANGE := TRUE;                                                   05560000
LX:                                                                     05562000
   END;                                                                 05564000
$PAGE                                                          <<xd.m4>>05566000
PROCEDURE SCANBLOCKTAB(ENDLINE,BLOCKNO,RECNO);                 <<B0.01>>05568000
DOUBLE ENDLINE,BLOCKNO,RECNO;                                  <<B0.01>>05570000
<<>>                                                           <<B0.01>>05572000
BEGIN                                                          <<B0.01>>05574000
INTEGER POINTER BLOCKTP;                                       <<B0.01>>05576000
DOUBLE POINTER DBLOCKTP = BLOCKTP;                             <<B0.01>>05578000
INTEGER BCOUNT;                                                <<B0.01>>05580000
<<>>                                                           <<B0.01>>05582000
BCOUNT := 0;                                                   <<B0.01>>05584000
CRITFLAG := FALSE;IF CONTROLYFLAG THEN CONTROLYPROC;           <<B0.01>>05586000
@BLOCKTP := @BLOCKFP;                                          <<B0.01>>05588000
  WHILE (BCOUNT:= BCOUNT + 1) < BENTRIES                       <<B0.01>>05590000
      AND ENDLINE >= DBLOCKTP(1)                     <<B0.01>> <<B0.01>>05592000
      DO BEGIN                                                 <<B0.01>>05594000
      @BLOCKTP := @BLOCKTP + BENTRY'SIZE;                      <<B0.01>>05596000
      IF @BLOCKTP >=  @BLOCKTABLE+BENTRIES * BENTRY'SIZE       <<B0.01>>05598000
         THEN @BLOCKTP := @BLOCKTABLE;                         <<B0.01>>05600000
      END;                                                     <<B0.01>>05602000
IF @BLOCKTP = @BLOCKTABLE THEN                                 <<B0.01>>05604000
   @BLOCKTP := @BLOCKTABLE + (BENTRIES-1)*BENTRY'SIZE          <<B0.01>>05606000
ELSE                                                           <<B0.01>>05608000
   @BLOCKTP := @BLOCKTP - BENTRY'SIZE;                         <<B0.01>>05610000
CRITFLAG := TRUE;                                              <<B0.01>>05612000
BLOCKNO := DBLOCKTP(0);                                        <<B0.01>>05614000
RECNO := DBLOCKTP(1);                                          <<B0.01>>05616000
END;                                                           <<B0.01>>05618000
$PAGE                                                          <<04145>>05620000
$CONTROL SEGMENT=SPOOK2                                        <<B0.01>>05622000
                                                               <<B0.01>>05624000
PROCEDURE COPY'LAST'OPEN;                                      <<B0.01>>05626000
<<>>                                                           <<B0.01>>05628000
BEGIN                                                          <<B0.01>>05630000
INTEGER I;                                                     <<B0.01>>05632000
<<>>                                                           <<B0.01>>05634000
MOVE SBUF(512) := NEW'BUFW,((NEW'BUFW+3)/2);                   <<B0.01>>05636000
SBUF(I:= 512 + (NEW'BUFW+3)/2    ) := -1 ;                     <<B0.01>>05638000
MOVE SBUF(I+1) := SBUF(I),(1024 - I -1);                       <<B0.01>>05640000
FWRITE(NEW'FILEN,SBUF(512),512,0);                             <<B0.01>>05642000
                                                               <<B0.01>>05644000
END;                                                           <<B0.01>>05646000
$CONTROL SEGMENT=SPOOK2                                        <<B0.01>>05648000
                                                               <<B0.01>>05650000
PROCEDURE COMPRESS(BUFFER,BEGINNING,BUFLENGTH);                <<B0.01>>05652000
                                                               <<B0.01>>05654000
VALUE BEGINNING,BUFLENGTH;                                     <<B0.01>>05656000
ARRAY BUFFER;                                                  <<B0.01>>05658000
INTEGER BEGINNING,BUFLENGTH;                                   <<B0.01>>05660000
<<>>                                                           <<B0.01>>05662000
BEGIN                                                          <<B0.01>>05664000
POINTER CP;                                                    <<B0.01>>05666000
INTEGER LEN;                                                   <<B0.01>>05668000
@CP := BEGINNING;                                              <<B0.01>>05670000
MOVE BUFFER := CP,(LEN:=BUFLENGTH-(@CP-@BUFFER));              <<B0.01>>05672000
BUFFER(LEN) :=-1;                                              <<B0.01>>05674000
MOVE BUFFER(LEN+1) := BUFFER(LEN),(BUFLENGTH-LEN-1);           <<B0.01>>05676000
END;                                                           <<B0.01>>05678000
$PAGE                                                          <<04145>>05680000
                                                                        05682000
$CONTROL SEGMENT=SPOOK2                                                 05684000
                                                                        05686000
LOGICAL PROCEDURE SKANTOLINE(SKAN);                                     05688000
   VALUE   SKAN;                                                        05690000
   LOGICAL SKAN;                                                        05692000
   BEGIN                                                                05694000
   INTEGER TEMP;                                                        05696000
   DOUBLE ENDLINE;                                                      05698000
DOUBLE RECNO;                                                  <<B0.01>>05700000
   POINTER P;                                                           05702000
   INTEGER R,Q;                                                <<B0.01>>05704000
   << >>                                                                05706000
SUBROUTINE ADD'BLOCK'ENTRY;                                    <<B0.01>>05708000
BEGIN                                                          <<B0.01>>05710000
<<>>                                                           <<B0.01>>05712000
     @BLOCKCP := @BLOCKCP + BENTRY'SIZE;                       <<B0.01>>05714000
     IF @BLOCKCP - @BLOCKTABLE >=  R:= BENTRIES * BENTRY'SIZE  <<B0.01>>05716000
      THEN BEGIN                                               <<B0.01>>05718000
           @BLOCKCP := @BLOCKTABLE;                            <<B0.01>>05720000
           @BLOCKFP := @BLOCKTABLE + BENTRY'SIZE;              <<B0.01>>05722000
           END                                                 <<B0.01>>05724000
      ELSE                                                     <<B0.01>>05726000
         IF @BLOCKFP <> @BLOCKTABLE THEN                       <<B0.01>>05728000
           @BLOCKFP := IF (Q:=@BLOCKFP+BENTRY'SIZE) >          <<B0.01>>05730000
                @BLOCKTABLE + R THEN @BLOCKTABLE               <<B0.01>>05732000
                ELSE Q;                                        <<B0.01>>05734000
     DBLOCKCP(0) := BLOCKNO;                                   <<B0.01>>05736000
     DBLOCKCP(1) := SBLINE;                                    <<B0.01>>05738000
END;                                                           <<B0.01>>05740000
<<>>  <<END OF ADD'BLOCK'ENTRY>>                               <<B0.01>>05742000
                                                               <<B0.01>>05744000
   ENDLINE := IF SKAN THEN FRLINE ELSE TOLINE;                          05746000
   IF SKAN THEN                                                <<01726>>05748000
   BEGIN  << INCREDIBLY FAST FREADDIR TO RECORD>>              <<01726>>05750000
      READ'RECORD(FILEN,ENDLINE,SBUF,SP,XDDN,BLOCKNO,ERRF);    <<01726>>05752000
      IF <> THEN                                               <<01726>>05754000
      BEGIN <<ERROR, IF CCL THEN BEFORE FIRST EXTENT>>         <<01726>>05756000
         IF < THEN                                             <<01726>>05758000
         BEGIN                                                 <<01726>>05760000
            ERRN := 78; <<BEFORE PURGED EXTENT>>               <<01726>>05762000
            GO TO LX;                                          <<01726>>05764000
         END                                                   <<01726>>05766000
         ELSE                                                  <<01726>>05768000
         IF  > THEN                                            <<01726>>05770000
         BEGIN  << ERROR , IF CCG THEN BEYOND EOF>>            <<01726>>05772000
            ERRN := 41;                                        <<01726>>05774000
            GO TO LX;                                          <<01726>>05776000
         END;                                                  <<01726>>05778000
      END;                                                     <<01726>>05780000
      FLINE := ENDLINE;                                        <<01726>>05782000
      TOS := SBUF(510);                                        <<01726>>05784000
      TOS := SBUF(511);                                        <<01726>>05786000
      SBLINE := TOS;                                           <<01726>>05788000
      GO TO LI;                                                <<01726>>05790000
   END;                                                        <<01726>>05792000
   WHILE FLINE <> ENDLINE DO                                   <<01726>>05794000
      BEGIN                                                             05796000
      IF > THEN                                                         05798000
         BEGIN                                                          05800000
         IF NOT SKAN THEN    << impossible internal error >>   <<ld.m4>>05802000
            BEGIN ERRN := 19; GOTO LX; END;                             05804000
         IF SBLINE > ENDLINE THEN                                       05806000
            BEGIN                                                       05808000
<< NOTE: THE FOLLOWING CODE IS TURNED OFF UNTIL      >>        <<01549>>05810000
<<      FREADDIR WORKS CORRECTLY WITH SPECIAL        >>        <<01549>>05812000
<<      VARIABLE SPOOLFILES.                         >>        <<01549>>05814000
         IF ENDLINE > DBLOCKFP(1) THEN                         <<01549>>05816000
            BEGIN                                              <<01549>>05818000
            SCANBLOCKTAB(ENDLINE,BLOCKNO,RECNO);               <<01549>>05820000
            READ'DIR'FLAG := TRUE;                             <<01549>>05822000
            END                                                <<01549>>05824000
          ELSE BEGIN                                           <<01549>>05826000
               @BLOCKFP := @BLOCKCP := @BLOCKTABLE  ;          <<01549>>05828000
               DBLOCKFP(0) := 0D;                              <<01549>>05830000
               DBLOCKFP(1) := 0D;                              <<01549>>05832000
               BLOCKNO := 0D;                                  <<01549>>05834000
            FCONTROL(FILEN,5,TEMP);                                     05836000
            IF <> THEN      << file read error >>              <<ld.m4>>05838000
               BEGIN ERRN := 26; FCHECK(FILEN,ERRF); GOTO LX; END;      05840000
            FLINE := -1D;                                               05842000
            END;                 <<SEE COMMENT ABOVE>>         <<01549>>05844000
            END                                                         05846000
         ELSE                                                           05848000
            BEGIN                                                       05850000
            @SP := @SBUF;                                               05852000
            FLINE := SBLINE;                                            05854000
            GOTO LI;                                                    05856000
            END;                                                        05858000
         END;                                                           05860000
      IF FLINE >= 0D THEN                                               05862000
         BEGIN                                                 <<B0.01>>05864000
         @P := @SP+INTEGER((SP+3)&ASR(1))                               05866000
                                             ;                 <<B0.01>>05868000
         IF @P > @SBUF + 512 THEN                              <<B0.01>>05870000
            << invalid length of record in text file >>        <<ld.m4>>05872000
            BEGIN ERRN := 61; GO TO LX; END;                   <<B0.01>>05874000
         END                                                   <<B0.01>>05876000
      ELSE                                                              05878000
         BEGIN                                                          05880000
         @P := @SBUF;                                                   05882000
         FREAD(FILEN,SBUF,512); <<GET FIRST BLOCK>>            <<01549>>05884000
         TOS := SBUF(510);                                     <<01549>>05886000
         TOS := SBUF(511);                                     <<01549>>05888000
         FLINE := TOS - 1D;  <<RECORD NUM OF FIRST RECORD>>    <<01549>>05890000
         FCONTROL(FILEN,5,TEMP); <<REWIND FILE>>               <<01549>>05892000
<<>>                                                           <<01549>>05894000
         P := -1;                                                       05896000
         END;                                                           05898000
      WHILE P = -1 DO                                                   05900000
         BEGIN                                                          05902000
         IF NOT READ'DIR'FLAG THEN                             <<B0.01>>05904000
         BEGIN                                                 <<B0.01>>05906000
         FREAD(FILEN,SBUF,512);                                         05908000
         IF <> THEN    << file read error >>                   <<ld.m4>>05910000
            BEGIN ERRN := 26; FCHECK(FILEN,ERRF); GOTO LX; END;         05912000
         SBLINE := FLINE+1D;                                            05914000
         ADD'BLOCK'ENTRY;                                      <<B0.01>>05916000
         BLOCKNO := BLOCKNO + 1D;                              <<B0.01>>05918000
         END                                                   <<B0.01>>05920000
         ELSE BEGIN                                            <<B0.01>>05922000
              READ'DIR'FLAG := FALSE;                          <<B0.01>>05924000
              FREADDIR(FILEN,SBUF,512,BLOCKNO);                <<B0.01>>05926000
              IF <> THEN     << file read error >>             <<ld.m4>>05928000
            BEGIN ERRN:=26; FCHECK(FILEN,ERRF); GO TO LX;END;  <<B0.01>>05930000
              SBLINE := FLINE := RECNO;                        <<B0.01>>05932000
                FLINE := FLINE - 1D;                           <<01549>>05934000
              END;                                             <<B0.01>>05936000
         @P := @SBUF;                                                   05938000
         END;                                                           05940000
      @SP := @P;                                                        05942000
      IF NOT FILE'FORMSMSG THEN                                <<B0.01>>05944000
         IF SP(2) = 3 <<FOPEN>> THEN                           <<B0.01>>05946000
            MOVE NEW'BUFW := SP,((SP+3)/2);                    <<B0.01>>05948000
         IF SP(3) = 4 <<FCLOSE>> AND EOFFLAG THEN              <<B0.01>>05950000
            BEGIN                                              <<B0.01>>05952000
            EOFFLAG := FALSE;                                  <<B0.01>>05954000
            ENDLINE := TOLINE := FLINE + 1D;                   <<B0.01>>05956000
            END;                                               <<B0.01>>05958000
      FLINE := FLINE+1D;                                                05960000
LI:                                                                     05962000
      FLINECNT := SP-8;                                                 05964000
      IF NOT SKAN THEN ENDLINE := FLINE;                                05966000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>05968000
      CRITFLAG := TRUE;                                        <<B0.00>>05970000
      END;                                                              05972000
   SKANTOLINE := TRUE;                                                  05974000
LX:                                                                     05976000
   END;                                                                 05978000
$PAGE                                                          <<04145>>05980000
$CONTROL SEGMENT=SPOOK2                                                 05982000
                                                                        05984000
LOGICAL PROCEDURE LISTRANGE(SKAN);                                      05986000
   VALUE   SKAN;                                                        05988000
   LOGICAL SKAN;                                                        05990000
   BEGIN                                                                05992000
   INTEGER IX,IY,CT,CTL,LSP,NX;                                         05994000
   LOGICAL UNI,FOUND;                                                   05996000
   ARRAY CL(0:7);                                                       05998000
   BYTE POINTER BSP;                                                    06000000
   BYTE POINTER BCL;                                                    06002000
   LOGICAL FDEVCTL;                                            <<01726>>06004000
    INTEGER LENGTH;                                            <<01726>>06006000
   DEFINE FUNC = SP(2)#,                                       <<01726>>06008000
          P1   = SP(3)#,                                       <<01726>>06010000
          P2   = SP(4)#,                                       <<01726>>06012000
          LEN  = SP(0)#;                                       <<01726>>06014000
                                                               <<04145>>06016000
   DEFINE                                                      <<04145>>06018000
      LIST'COMMAND = NOT SKAN#,                                <<04145>>06020000
      FIND'COMMAND =     SKAN#;                                <<04145>>06022000
                                                               <<01726>>06024000
   << >>                                                                06026000
   UNI := TRUE;                                                         06028000
   FDEVCTL := FALSE;                                           <<01726>>06030000
   @BCL := @CL&ASL(1);                                                  06032000
   NX := DASCII(EOFLINE,10,BCL);                                        06034000
   DO                                                                   06036000
      BEGIN                                                             06038000
       FOUND := FALSE;                                         <<04145>>06040000
      IF UNI THEN                                                       06042000
         UNI := FALSE                                                   06044000
      ELSE                                                              06046000
         IF NOT SKANTOLINE(FALSE) THEN GOTO LX;                         06048000
      @BCL := @CL&ASL(1);                                               06050000
      @BSP := @SP(5)&ASL(1);                                            06052000
      LSP := FLINECNT;                                                  06054000
      OBUF := "  ";                                                     06056000
      MOVE OBUF(1) := OBUF,(127);                                       06058000
      IX := 0;                                                          06060000
      CT := DASCII(FLINE,10,BCL);                                       06062000
      MOVE BOBUF(IX+NX-CT) := BCL,(CT);                                 06064000
      IX := IX+NX+1;                                                    06066000
      CTL := SP(3);                                                     06068000
      IF CTL = 1 AND FUNC = 1 THEN                             <<01886>>06070000
         BEGIN                                                          06072000
         CTL := SP(5).(0:8);                                            06074000
         LSP := LSP-1;                                                  06076000
         @BSP := @BSP+1;                                                06078000
         END;                                                           06080000
      IF FALL THEN                                                      06082000
         BEGIN                                                          06084000
          IF FUNC >= %200 THEN                                 <<01726>>06086000
          BEGIN  <<FDEVICECONTROL>>                            <<01726>>06088000
             FDEVCTL := TRUE;                                  <<01726>>06090000
             MOVE BOBUF(IX) := "FDEVICECONTROL FUNC=";         <<01726>>06092000
             IX := IX + 21;                                    <<01726>>06094000
             ASCII(FUNC,10,BCL);                               <<01726>>06096000
             MOVE BOBUF(IX) := BCL   , (3);                    <<01726>>06098000
             IX := IX + 4;                                     <<01726>>06100000
             MOVE BOBUF(IX) := "P1=% ";                        <<01726>>06102000
             IX := IX + 5;                                     <<01726>>06104000
             ASCII(P1,8,BCL);                                  <<01726>>06106000
             MOVE BOBUF(IX) := BCL , (6);                      <<01726>>06108000
             IX := IX + 7;                                     <<01726>>06110000
             MOVE BOBUF(IX) := "P2=% ";                        <<01726>>06112000
             IX := IX + 5;                                     <<01726>>06114000
             ASCII(P2,8,BCL);                                  <<01726>>06116000
             MOVE BOBUF(IX) := BCL , (6);                      <<01726>>06118000
             IX := IX + 7;                                     <<01726>>06120000
             MOVE BOBUF(IX) := "LEN= ";                        <<01726>>06122000
             IX := IX + 5;                                     <<01726>>06124000
             LENGTH := ASCII(LEN,10,BCL);                      <<01726>>06126000
             MOVE BOBUF(IX) := BCL   , (LENGTH);               <<01726>>06128000
             IX := IX + 7;                                     <<01726>>06130000
                                                               <<01726>>06132000
             CASE FUNC - 128 OF                                <<01726>>06134000
             BEGIN                                             <<01726>>06136000
                   <<128>>                                     <<01726>>06138000
                MOVE BOBUF(IX) :=                              <<01726>>06140000
                    "Select Primary/Secondary Character Set";  <<01726>>06142000
                   <<129>>                                     <<01726>>06144000
                MOVE BOBUF(IX) :=                              <<01726>>06146000
                    "Select Logical Pages/Forms            ";  <<01726>>06148000
                   <<130>>                                     <<01726>>06150000
                MOVE BOBUF(IX) :=                              <<01726>>06152000
                    "Move Pen Relative                     ";  <<01726>>06154000
                   <<131>>                                     <<01726>>06156000
                MOVE BOBUF(IX) :=                              <<01726>>06158000
                    "Move Pen Absolute                     ";  <<01726>>06160000
                   <<132>>                                     <<01726>>06162000
                MOVE BOBUF(IX) :=                              <<01726>>06164000
                    "Define Job Characteristics            ";  <<01726>>06166000
                   <<133>>                                     <<01726>>06168000
                MOVE BOBUF(IX) :=                              <<01726>>06170000
                    "Download Physical Page Definition     ";  <<01726>>06172000
                   <<134>>                                     <<01726>>06174000
                MOVE BOBUF(IX) :=                              <<01726>>06176000
                    "Download/Delete Character Set         ";  <<01726>>06178000
                   <<135>>                                     <<01726>>06180000
                MOVE BOBUF(IX) :=                              <<01726>>06182000
                    "Download/Delete Forms                 ";  <<01726>>06184000
                   <<136>>                                     <<01726>>06186000
                MOVE BOBUF(IX) :=                              <<01726>>06188000
                    "Download Logical Page Table           ";  <<01726>>06190000
                   <<137>>                                     <<01726>>06192000
                MOVE BOBUF(IX) :=                              <<01726>>06194000
                    "Download Multi-Copy Form Overlay Table";  <<01726>>06196000
                   <<138>>                                     <<01726>>06198000
                MOVE BOBUF(IX) :=                              <<01726>>06200000
                    "Download/Delete VFC                   ";  <<01726>>06202000
            END;  <<CASE>>                                     <<01726>>06204000
            IX := IX + 39;                                     <<01726>>06206000
        END                                                    <<01726>>06208000
        ELSE                                                   <<01726>>06210000
        BEGIN                                                  <<01726>>06212000
         ASCII(CTL,8,BCL);                                              06214000
         CASE SP(2) OF                                                  06216000
            BEGIN                                                       06218000
            <<0>>                                                       06220000
            MOVE BOBUF(IX) := "W";                                      06222000
            <<1>>                                                       06224000
               BEGIN                                                    06226000
               MOVE BOBUF(IX) := "W";                                   06228000
               IF CTL <> 0 THEN                                         06230000
                  BEGIN                                                 06232000
                  BOBUF(IX+1) := "%";                                   06234000
                  MOVE BOBUF(IX+2) := BCL(3),(3);                       06236000
                  END;                                                  06238000
               END;                                                     06240000
            <<2>>                                                       06242000
               BEGIN                                                    06244000
               MOVE BOBUF(IX) := "C";                                   06246000
               IF CTL <> 0 THEN                                         06248000
                  BEGIN                                                 06250000
                  BOBUF(IX+1) := "%";                                   06252000
                  MOVE BOBUF(IX+2) := BCL(3),(3);                       06254000
                  END;                                                  06256000
               END;                                                     06258000
            <<3>>                                                       06260000
            MOVE BOBUF(IX) := "FOPEN";                                  06262000
            <<4>>                                                       06264000
            MOVE BOBUF(IX) := "FCLOSE";                                 06266000
            END;                                                        06268000
         IX := IX+7;                                                    06270000
                           END;                                <<01726>>06272000
         END;                                                           06274000
         IF LSP > 256 OR LSP < 0 THEN                          <<01326>>06276000
         BEGIN  <<INVALID LENGTH>>                             <<01326>>06278000
            ERRN := 61;                                        <<01326>>06280000
            GO TO LX;                                          <<01326>>06282000
         END;                                                  <<01326>>06284000
      IF FDEVCTL THEN LSP := 0                                 <<01726>>06286000
      ELSE                                                     <<01726>>06288000
      MOVE BOBUF(IX) := BSP,(LSP);                                      06290000
      FDEVCTL := FALSE;                                        <<01726>>06292000
      CT := LSP+IX;                                                     06294000
      IF FIND'COMMAND THEN                                     <<04145>>06296000
         BEGIN                                                          06298000
         BOBUF(CT+1) := CR ;                                   <<04145>>06300000
         SCAN BOBUF(IX) WHILE %6440,1;                                  06302000
         IX := TOS-@BOBUF;                                              06304000
         BOBUF(CT+1) := " ";                                            06306000
         IY := IX;                                                      06308000
         WHILE IY <= (CT+1-FSTRING) DO                                  06310000
            BEGIN                                                       06312000
            IF BFSTR = BOBUF(IY),(FSTRING) THEN                         06314000
               BEGIN                                                    06316000
               FOUND := TRUE;                                           06318000
               TOLINE := FLINE;                                <<04459>>06320000
               IY := CT+1;                                              06322000
               END;                                                     06324000
            IF NOT FSTRALL THEN IY := CT+1;                    <<04459>>06326000
            IY := IY+1;                                                 06328000
            END;                                                        06330000
         END;                                                           06332000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>06334000
      IF LIST'COMMAND OR FOUND THEN                            <<04145>>06336000
         BEGIN                                                          06338000
         IF FWIDTH <> 0 THEN                                            06340000
            IF CT > FWIDTH THEN CT := FWIDTH;                           06342000
         IF CT > 256 OR CT < 0 THEN                            <<B0.01>>06344000
            << invalid record length in text file >>           <<ld.m4>>06346000
            BEGIN ERRN := 61; GO TO LX; END;                   <<B0.01>>06348000
         IY := -1;                                                      06350000
         WHILE (IY:=IY+1) < CT DO                                       06352000
            IF NOT (%40<=INTEGER(BOBUF(IY))<=%176) THEN        <<B0.01>>06354000
               BOBUF(IY) := ".";                                        06356000
         PRINT(OBUF,-CT,0);                                             06358000
         IF FIND'COMMAND AND NOT FSTRALL                       <<04145>>06360000
            THEN TOLINE := FLINE;                              <<04145>>06362000
         END;                                                           06364000
      CRITFLAG := TRUE;                                        <<B0.00>>06366000
      END                                                               06368000
   UNTIL FLINE >= TOLINE;                                               06370000
   IF TOLINE < EOFLINE THEN                                    <<04145>>06372000
      BEGIN                                                             06374000
      TOLINE := TOLINE+1D;                                              06376000
      IF NOT SKANTOLINE(FALSE) THEN GOTO LX;                            06378000
      END;                                                              06380000
   LISTRANGE := TRUE;                                                   06382000
LX:                                                                     06384000
   END;                                                                 06386000
$PAGE                                                          <<04145>>06388000
$CONTROL SEGMENT=SPOOK2                                        <<B0.00>>06390000
                                                               <<B0.00>>06392000
LOGICAL PROCEDURE SHIFTUPPER(STRING,COUNT);                    <<B0.00>>06394000
                                                               <<04145>>06396000
<<*************************************************>>          <<04145>>06398000
<< THIS PROCEDURE UPSHIFTS ALPHANUMERIC STRING     >>          <<04145>>06400000
<< EXCEPT FOR QUANTITIES ENCLOSED IN QUOTES.       >>          <<04145>>06402000
<< IF A QUOTE OCCURS WITHIN THE STRING IT MUST     >>          <<04145>>06404000
<< BE A DOUBLE QUOTE:                              >>          <<04145>>06406000
<< FOR EXAMPLE "STRING IS QUOTE = "" IS ALLOWED "  >>          <<B0.00>>06408000
<<*************************************************>>          <<04145>>06410000
                                                               <<04145>>06412000
<<>>                                                           <<B0.00>>06414000
                                                               <<B0.00>>06416000
BYTE ARRAY STRING;                                             <<B0.00>>06418000
INTEGER COUNT;                                                 <<B0.00>>06420000
                                                               <<B0.00>>06422000
BEGIN                                                          <<B0.00>>06424000
INTEGER I, FIRSTQUOTE,SECONDQUOTE,DIFF;                        <<B0.00>>06426000
EQUATE QUOTE = %42;                                            <<B0.00>>06428000
EQUATE CRQUOTE = %6442;                                        <<B0.00>>06430000
<<>>                                                           <<B0.00>>06432000
SHIFTUPPER := TRUE;                <<INITIALIZE>>              <<B0.00>>06434000
I := 0;                                                        <<B0.00>>06436000
DO                                                             <<B0.00>>06438000
  BEGIN  <<UPSHIFT ALPHANUMERICS >>                            <<B0.00>>06440000
    MOVE STRING(I) := STRING(I) WHILE ANS,1;                   <<B0.00>>06442000
    ASSEMBLE(DUP);                                             <<B0.00>>06444000
    IF STRING(I := TOS - @STRING) = QUOTE THEN                 <<B0.00>>06446000
         <<LOOK FOR QUOTE IF >>                                <<B0.00>>06448000
      BEGIN               << NOT ALPHANUMERIC>>                <<B0.00>>06450000
        FIRSTQUOTE := TOS;             <<WE FOUND FIRST QUOTE>><<B0.00>>06452000
SCAN1:  SCAN STRING(I := I+1) UNTIL CRQUOTE,1;                 <<B0.00>>06454000
        SECONDQUOTE := TOS;           <<WE FOUND SECOND QUOTE>><<B0.00>>06456000
        IF CARRY THEN                  <<IF END OF STRING>>    <<B0.00>>06458000
          BEGIN                <<UNDELIMITED STRING>>          <<B0.00>>06460000
            ERRN := 42; SHIFTUPPER := FALSE;                   <<B0.00>>06462000
          END                                                  <<B0.00>>06464000
        ELSE                                                   <<B0.00>>06466000
          BEGIN                                                <<B0.00>>06468000
            DIFF := SECONDQUOTE - FIRSTQUOTE;                  <<B0.00>>06470000
            I := I + DIFF;                                     <<B0.00>>06472000
            IF  STRING(I) = QUOTE THEN                         <<B0.00>>06474000
               BEGIN    << IF ANOTHER QUOTE >>                 <<B0.00>>06476000
           << IMMEDIATELY FOLLOWS THEN KEEP SCANNING>>         <<B0.00>>06478000
                 I := I+1;  <<FOR TERMINAL QUOTE>>             <<B0.00>>06480000
                 IF STRING(I) = CR THEN  <<UNLESS LAST QUOTE>> << GLO >>06482000
                   BEGIN  << LAST QUOTE IN STRING, NOT PAIRED>><< GLO >>06484000
                     ERRN := 42;  <<UNDELIMITED STRING>>       << GLO >>06486000
                     SHIFTUPPER := FALSE;                      << GLO >>06488000
                   END                                         << GLO >>06490000
                 ELSE                                          << GLO >>06492000
                   GO TO SCAN1;                                << GLO >>06494000
               END;                                            <<B0.00>>06496000
          END;                                                 <<B0.00>>06498000
      END;                                                     <<B0.00>>06500000
  END                                                          <<B0.00>>06502000
UNTIL (I := I + 1) >= COUNT;   <<STOP AT CARRIAGE RETURN>>     <<B0.00>>06504000
                                                               <<B0.00>>06506000
                                                               <<B0.00>>06508000
END;                                                           <<B0.00>>06510000
$PAGE "* * * SPOOLOPEN * * *"                                 <<<xd.m4>>06512000
$CONTROL SEGMENT=SPOOK2                                                 06514000
                                                                        06516000
<<---------------------------------------------------------->> <<xd.m4>>06518000
<< Logical procedure SPOOLOPEN returns true if it success-  >> <<xd.m4>>06520000
<< fully opens the old spoolfile described in DEVF.  It re- >> <<xd.m4>>06522000
<< turns (in FILEF) the AFT entry number of the opened      >> <<xd.m4>>06524000
<< spoofle.  The relevant XDD subentry is placed in XDDBUF. >> <<xd.m4>>06526000
<< The spoofle is checked to see if it is present and ready.>> <<xd.m4>>06528000
<< If so, the spool state is set to locked and the spoofle  >> <<xd.m4>>06530000
<< is opened.  The record number of the first non-purged    >> <<xd.m4>>06532000
<< extent is saved in FLINE.  The file is rewound.          >> <<xd.m4>>06534000
<<---------------------------------------------------------->> <<xd.m4>>06536000
                                                               <<xd.m4>>06538000
LOGICAL PROCEDURE SPOOLOPEN(DEVF,FILEF);                       <<B0.01>>06540000
   VALUE DEVF;                                                 <<B0.01>>06542000
   INTEGER DEVF,FILEF;                                         <<B0.01>>06544000
                                                               <<B0.01>>06546000
   BEGIN                                                                06548000
   LOGICAL POINTER                                             <<xd.m4>>06550000
      XDD'SUBENTRY;                                            <<xd.m4>>06552000
   INTEGER                                                     <<xd.m4>>06554000
      TEMP,                                                    <<xd.m4>>06556000
      SAVE'XDD'SIR;                                            <<xd.m4>>06558000
   << >>                                                                06560000
   SAVE'XDD'SIR := GETSIR(IF DEVF<0 THEN ODD'SIR ELSE IDD'SIR);<<xd.m4>>06562000
   @XDD'SUBENTRY := @XDDBUF;                                   <<xd.m4>>06564000
   XDDX := 0;                                                           06566000
   IF COPYXDD(DEVF) THEN                                                06568000
      BEGIN                                                             06570000
      XDDX.IS'ODD := DEVF.IS'ODD;                              <<xd.m4>>06572000
      IF XDDS'SPOOL'STATE = XDDS'READY THEN                    <<xd.m4>>06574000
         LOCKXDD(XDDX);                                        <<xd.m4>>06576000
      END;                                                              06578000
   RELSIR(IF DEVF<0 THEN ODD'SIR ELSE IDD'SIR,SAVE'XDD'SIR);   <<xd.m4>>06580000
   IF XDDX = 0 THEN                                                     06582000
      << file not found >>                                     <<ld.m4>>06584000
      BEGIN ERRN := 31; GOTO LX; END;                                   06586000
   IF NOT (XDDS'SPOOL'STATE) THEN                              <<xd.m4>>06588000
      << file not ready >>                                     <<ld.m4>>06590000
      BEGIN ERRN := 28; GOTO LX; END;                                   06592000
                                                               <<xd.m4>>06594000
<< Open the spoolfile with the following:                   >> <<xd.m4>>06596000
<<    FOPTIONS - ASCII, old permanent                       >> <<xd.m4>>06598000
<<    AOPTIONS - NOBUF, read only                           >> <<xd.m4>>06600000
                                                               <<xd.m4>>06602000
   FILEF := FSOPEN(,%305,%400,XDDX);                                    06604000
   IF <> THEN                                                           06606000
      << unable to open file >>                                <<ld.m4>>06608000
      BEGIN ERRN := 29; FCHECK(FILEF,ERRF); GOTO LX; END;               06610000
   FREAD(FILEF,SBUF,512); <<READ FIRST BLOCK>>                 <<01549>>06612000
   <<STORE RECNUM OF FIRST NON-PURGED EXTENT IN>>              <<01549>>06614000
   <<FLINE FOR FUTURE USE AND THEN REWIND FILE>>               <<01549>>06616000
   TOS := SBUF(510);                                           <<01549>>06618000
   TOS  := SBUF(511);                                          <<01549>>06620000
   FLINE := TOS - 1D;  <<RECNUM OF BEGINNING OF FILE>>         <<01549>>06622000
   FCONTROL(FILEF,5,TEMP);  <<REWIND FILE>>                    <<01549>>06624000
   SPOOLOPEN := TRUE;                                                   06626000
LX:                                                                     06628000
   END;                                                                 06630000
$PAGE "* * * GETMODE * * *"                                    <<xd.m4>>06632000
$CONTROL SEGMENT=SPOOK1                                                 06634000
                                                                        06636000
LOGICAL PROCEDURE GETMODE;                                              06638000
   BEGIN                                                                06640000
   INTEGER TW,TC;                                                       06642000
   INTEGER CT,Z,NUM;                                                    06644000
   LOGICAL FLAG;                                                        06646000
   << >>                                                                06648000
   TW := FWIDTH;                                                        06650000
   TC := FALL;                                                          06652000
   WHILE BP <> CR  DO                                          <<04145>>06654000
      BEGIN                                                             06656000
      ERRN := 43;   << invalid option name >>                  <<ld.m4>>06658000
      MOVE BP := BP WHILE AS,1;                                         06660000
      CT := TOS-@BP;                                                    06662000
      IF NOT (1<=CT<=MSIZE) THEN GOTO LX;                               06664000
      Z := 0;                                                           06666000
      WHILE (Z<MNUM) AND (BP<>MMODE(Z*MSIZE),(CT)) DO                   06668000
         Z := Z+1;                                                      06670000
      IF Z = MNUM THEN GOTO LX;                                         06672000
      IF BP(CT) <> "=" THEN                                             06674000
         << invalid option separator >>                        <<ld.m4>>06676000
         BEGIN ERRN := 44; GOTO LX; END;                                06678000
      @BP := @BP+CT+1;                                                  06680000
      ERRN := 45;    << invalid option parameter >>            <<ld.m4>>06682000
      FLAG := FALSE;                                                    06684000
      NUM := -1;                                                        06686000
      IF BP = ALPHA THEN                                                06688000
         BEGIN                                                          06690000
         IF BP = "ON" THEN                                              06692000
            BEGIN                                                       06694000
            FLAG := TRUE;                                               06696000
            @BP := @BP+2;                                               06698000
            END                                                         06700000
         ELSE                                                           06702000
            IF BP = "OFF" THEN                                          06704000
               BEGIN                                                    06706000
               FLAG := FALSE;                                           06708000
               @BP := @BP+3;                                            06710000
               END                                                      06712000
            ELSE                                                        06714000
               GOTO LX;                                                 06716000
         END                                                            06718000
      ELSE                                                              06720000
         BEGIN                                                          06722000
         IF NOT GETDNUM THEN GOTO LX;                                   06724000
         IF DNUM < 0D THEN                                              06726000
            DNUM := -DNUM                                               06728000
         ELSE                                                           06730000
            DNUM := DNUM&DASL(1);                                       06732000
         IF DNUM0 <> 0 THEN GOTO LX;                                    06734000
         NUM := DNUM1;                                                  06736000
         END;                                                           06738000
      CASE Z OF                                                         06740000
         BEGIN                                                          06742000
         <<0>>                                                          06744000
         IF NUM >= 0 THEN                                               06746000
            TW := NUM                                                   06748000
         ELSE                                                           06750000
            IF NOT FLAG THEN                                            06752000
               TW := 0                                                  06754000
            ELSE GOTO LX;                                               06756000
         <<1>>                                                          06758000
         IF NUM < 0 THEN                                                06760000
            TC := FLAG                                                  06762000
         ELSE                                                           06764000
            GOTO LX;                                                    06766000
         END;                                                           06768000
      ERRN := 0;                                                        06770000
      IF BP = "," THEN @BP := @BP+1;                                    06772000
      END;                                                              06774000
   FWIDTH := TW;                                                        06776000
   FALL := TC;                                                          06778000
   GETMODE := TRUE;                                                     06780000
LX:                                                                     06782000
   END;                                                                 06784000
$PAGE "* * * GETALTER * * *"                                   <<xd.m4>>06786000
$CONTROL SEGMENT=SPOOK1                                                 06788000
<<---------------------------------------------------------->> <<ld.m4>>06790000
<< GETALTER is called by the main command loop to parse the >> <<ld.m4>>06792000
<< parameters specified in the command string of an ALTER   >> <<ld.m4>>06794000
<< command.  Options are: PRI, COPIES, and DEV.             >> <<ld.m4>>06796000
<< Note that GETDEVINFO is called to return information     >> <<xd.m4>>06798000
<< about a device (BP) in array INFO.  INFO(0) contains the >> <<xd.m4>>06800000
<< numerical value of ldev or the DCT index of a class, and >> <<xd.m4>>06802000
<< is the parameter that SPOOLEDDEV is called with to re-   >> <<xd.m4>>06804000
<< trieve spooling information.                             >> <<xd.m4>>06806000
<<---------------------------------------------------------->> <<xd.m4>>06808000
                                                                        06810000
LOGICAL PROCEDURE GETALTER;                                             06812000
   BEGIN                                                                06814000
   INTEGER CT,Z;                                                        06816000
   INTEGER ARRAY INFO(0:12);                                   <<xd.m4>>06818000
   << >>                                                                06820000
   PRI := 0;                                                            06822000
   COPIES := 0;                                                         06824000
   CLASS := 0;                                                 <<xd.m4>>06826000
   DEVICE := 0;                                                <<xd.m4>>06828000
   WHILE BP <> CR  DO                                          <<04145>>06830000
      BEGIN                                                             06832000
      ERRN := 43;     << invalid option name >>                <<ld.m4>>06834000
      MOVE BP := BP WHILE AS,1;                                         06836000
      CT := TOS-@BP;                                                    06838000
      IF NOT (1<=CT<=ASIZE) THEN GOTO LX;                               06840000
      Z := 0;                                                           06842000
      WHILE (Z<ANUM) AND (BP<>AALTER(Z*ASIZE),(CT)) DO                  06844000
         Z := Z+1;                                                      06846000
      IF Z = ANUM THEN GOTO LX;                                         06848000
      IF BP(CT) <> "=" THEN                                             06850000
         << invalid option separator >>                        <<ld.m4>>06852000
         BEGIN ERRN := 44; GOTO LX; END;                                06854000
      @BP := @BP+CT+1;                                                  06856000
      ERRN := 45;   << invalid option parameter >>             <<ld.m4>>06858000
      CASE Z OF                                                         06860000
         BEGIN                                                          06862000
         <<0>>       << priority >>                            <<ld.m4>>06864000
            BEGIN                                                       06866000
            IF NOT GETDNUM THEN GOTO LX;                                06868000
            IF DNUM < 0D THEN GOTO LX;                                  06870000
            IF DNUM0 <> 0 THEN GOTO LX;                                 06872000
            IF NOT (1<=DNUM1<=13) THEN GOTO LX;                         06874000
            PRI := DNUM1;                                               06876000
            END;                                                        06878000
         <<1>>       << number of copies >>                    <<ld.m4>>06880000
            BEGIN                                                       06882000
            IF NOT GETDNUM THEN GOTO LX;                                06884000
            IF DNUM < 0D THEN GOTO LX;                                  06886000
            IF DNUM0 <> 0 THEN GOTO LX;                                 06888000
            IF NOT (1<=DNUM1<=127) THEN GOTO LX;                        06890000
            COPIES := DNUM1;                                            06892000
            END;                                                        06894000
         <<2>>       << device >>                              <<ld.m4>>06896000
            BEGIN                                                       06898000
            IF (GETDEVINFO(BP,INFO) <> 0) THEN                 <<xd.m4>>06900000
               GOTO LX;   << unknown or virtual ldev >>        <<xd.m4>>06902000
            IF SPOOLEDDEV(INFO).(14:2) = 0 THEN                <<xd.m4>>06904000
               GOTO LX;   <<spoolQ's shut, not output spooler>><<xd.m4>>06906000
            IF BP = "+" OR BP = "-" THEN @BP := @BP+1;                  06908000
            MOVE BP := BP WHILE ANS,1;                                  06910000
            @BP := TOS;                                                 06912000
            IF INFO < 0 THEN <<device is class index into DCT>><<xd.m4>>06914000
               BEGIN                                           <<xd.m4>>06916000
               DEVICE := -INFO;                                <<xd.m4>>06918000
               CLASS := 1;                                     <<xd.m4>>06920000
               END                                             <<xd.m4>>06922000
            ELSE                                               <<xd.m4>>06924000
               DEVICE := INFO;                                 <<xd.m4>>06926000
            END;                                                        06928000
         END;                                                           06930000
      ERRN := 0;                                                        06932000
      IF BP = "," THEN @BP := @BP+1;                                    06934000
      END;                                                              06936000
   GETALTER := TRUE;                                                    06938000
LX:                                                                     06940000
   END;                                                                 06942000
$PAGE "* * * ALTERXDD * * *"                                   <<xd.m4>>06944000
$CONTROL SEGMENT=SPOOK2                                                 06946000
                                                                        06948000
<<******************A L T E R X D D ************************>> <<04145>>06950000
<< ALTERXDD is sent a device file id.  It calls COPYXDD to  >> <<04145>>06952000
<< copy an XDD entry into stack.  If then changes one to all>> <<04145>>06954000
<< of the following before copying the entry back into the  >> <<04145>>06956000
<< XDD: number of copies, priority, and device.             >> <<04145>>06958000
<<**********************************************************>> <<04145>>06960000
                                                               <<04145>>06962000
LOGICAL PROCEDURE ALTERXDD(DEVF);                              <<B0.01>>06964000
   VALUE DEVF;                                                 <<B0.01>>06966000
   INTEGER DEVF;                                               <<B0.01>>06968000
                                                               <<B0.01>>06970000
   BEGIN                                                                06972000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>06974000
   LOGICAL RLINK;                                                       06976000
   INTEGER                                                     <<ld.m4>>06978000
      SAVE'LDT'SIR,                                            <<xd.m4>>06980000
      SAVE'XDD'SIR,                                            <<xd.m4>>06982000
      CLASS'DEV;                                               <<xd.m4>>06984000
   << >>                                                                06986000
SUBROUTINE DEF'MOVETODSEG;                                     <<xd.m4>>06988000
   RLINK := FALSE;                                                      06990000
   @XDD'SUBENTRY := @XDDBUF;                                   <<xd.m4>>06992000
   XDDX := 0;                                                           06994000
   SAVE'LDT'SIR := GETSIR(LDT'SIR);                            <<ld.m4>>06996000
   SAVE'XDD'SIR := GETSIR(IF DEVF<0 THEN ODD'SIR ELSE IDD'SIR);<<xd.m4>>06998000
                                                               <<04145>>07000000
   <<*******************************************************>> <<04145>>07002000
   << Copy the XDD entry onto stack and change the local    >> <<04145>>07004000
   << values to COPIES, PRI or CLDEV if specified.          >> <<04145>>07006000
   <<*******************************************************>> <<04145>>07008000
                                                               <<04145>>07010000
   IF NOT COPYXDD(DEVF) THEN                                            07012000
      << file not found >>                                     <<ld.m4>>07014000
      BEGIN ERRN := 31; GOTO LX; END;                                   07016000
   IF XDDS'SPOOL'STATE = XDDS'ACTIVE THEN                      <<xd.m4>>07018000
      << file not ready/open >>                                <<ld.m4>>07020000
      BEGIN ERRN := 47; GOTO LX; END;                                   07022000
   IF COPIES <> 0 THEN                                                  07024000
      ODDS'NUMBER'COPIES := COPIES;                            <<xd.m4>>07026000
   IF PRI <> 0 THEN                                                     07028000
      BEGIN                                                             07030000
      OLD'PRI := XDDS'OUTPUT'PRIORITY; << save old priority >> <<xd.m4>>07032000
      XDDS'OUTPUT'PRIORITY := PRI;                             <<xd.m4>>07034000
      RLINK := TRUE;                                                    07036000
      END;                                                              07038000
   IF DEVICE <> 0 THEN                                         <<xd.m4>>07040000
      BEGIN                                                             07042000
      XDDS'CLASS := CLASS;                                     <<xd.m4>>07044000
      XDDS'DEVICE := DEVICE;                                   <<xd.m4>>07046000
      RLINK := TRUE;                                                    07048000
      END;                                                              07050000
                                                               <<04145>>07052000
   <<*******************************************************>> <<04145>>07054000
   << If we have changed the device of an ODD entry, then   >> <<04145>>07056000
   << we must relink the ODD via SRELINKODD because the ODD >> <<04145>>07058000
   << is ordered by LDEV and Class name.                    >> <<04145>>07060000
   <<*******************************************************>> <<04145>>07062000
                                                               <<04145>>07064000
                                                               <<04145>>07066000
   <<*******************************************************>> <<04145>>07068000
   << Now copy the changed XDD entry back to the ODD or IDD.>> <<04145>>07070000
   << The offset of the entry in the XDD is pointed to by   >> <<04145>>07072000
   << XDDX, set by COPYXDD, and the stack array is pointed  >> <<04145>>07074000
   << to by XDD, set in the calling procedure.              >> <<04145>>07076000
   <<*******************************************************>> <<04145>>07078000
                                                               <<04145>>07080000
   MOVETODSEG (IF DEVF < 0 THEN ODD'DST ELSE IDD'DST,          <<xd.m4>>07082000
               XDDX, @XDDBUF, SIZE'OF'XDD'SUBENTRY);           <<xd.m4>>07084000
                                                               <<xd.m4>>07086000
   IF RLINK AND DEVF < 0 THEN                                  <<xd.m4>>07088000
      BEGIN                                                    <<xd.m4>>07090000
      @XDD'SUBENTRY := XDDX;                                   <<xd.m4>>07092000
      EXCHANGEDB(ODD'DST);                                     <<xd.m4>>07094000
      CLASS'DEV := XDDS'DEVICE;                                <<xd.m4>>07096000
      IF XDDS'CLASS THEN                                       <<xd.m4>>07098000
         CLASS'DEV := -CLASS'DEV;                              <<xd.m4>>07100000
      SRELINKODD(XDD'SUBENTRY, CLASS'DEV);                     <<xd.m4>>07102000
      EXCHANGEDB(0);                                           <<xd.m4>>07104000
      RELSIR(ODD'SIR,SAVE'XDD'SIR);   << RELEASE SIR >>        <<xd.m4>>07106000
      SROOSTER(CLASS'DEV);                                     <<xd.m4>>07108000
   ALTERXDD := TRUE;                                           <<01.02>>07110000
   GO TO LX1;     <<BYPASS REPEAT OF RELSIR>>                  <<01.02>>07112000
<<  >>                                                         <<01.02>>07114000
      END;                                                              07116000
   ALTERXDD := TRUE;                                                    07118000
LX:                                                                     07120000
   RELSIR(IF DEVF<0 THEN ODD'SIR ELSE IDD'SIR,SAVE'XDD'SIR);   <<xd.m4>>07122000
LX1:                                                           <<01.02>>07124000
   RELSIR(LDT'SIR,SAVE'LDT'SIR);                               <<ld.m4>>07126000
   END;                                                                 07128000
$PAGE "* * * FINDODD * * *"                                    <<xd.m4>>07130000
$CONTROL SEGMENT=SPOOK2                                        <<01.02>>07132000
INTEGER PROCEDURE FINDODD(XDDNUM);                             <<01.02>>07134000
VALUE XDDNUM;                                                  <<01.02>>07136000
INTEGER XDDNUM;                                                <<01.02>>07138000
BEGIN                                                          <<01.02>>07140000
<<  >>                                                         <<01.02>>07142000
      << PROCEDURE ADDED 6/20/77         >>                    <<01.02>>07144000
   LOGICAL POINTER                                             <<xd.m4>>07146000
      XDD'SUBENTRY;                                            <<xd.m4>>07148000
                                                               <<xd.m4>>07150000
   @XDD'SUBENTRY := XDDNUM.IDNUM;                              <<xd.m4>>07152000
   EXCHANGEDB(ODD'DST);                                        <<xd.m4>>07154000
   TOS:=XDDS'DEVICE;                                           <<xd.m4>>07156000
      IF XDDS'CLASS THEN TOS:=-TOS;                            <<xd.m4>>07158000
      EXCHANGEDB(0);                                           <<01.02>>07160000
      FINDODD:=TOS;                                            <<01.02>>07162000
      END;                                                     <<01.02>>07164000
$PAGE "* * * GETFILES * * *"                                   <<xd.m4>>07166000
                                                               <<xd.m4>>07168000
<<**********************************************************>> <<04145>>07170000
<<  GETFILES obtains the device files from the command      >> <<04145>>07172000
<< string and sets up the array DEVFS via GETDEVF.  The     >> <<04145>>07174000
<< value of SHW depends on what is allowed and what type of >> <<04145>>07176000
<< file ID we are dealing with, Input or Output.  SHOWIO is >> <<04145>>07178000
<< set in this procedure and it signifies what types of     >> <<04145>>07180000
<< files we are dealing with.  If bit 15 of SHOWIO is on,   >> <<04145>>07182000
<< we have at least one OUTPUT Dev. ID, if 14 is on we have >> <<04145>>07184000
<< at least one INPUT Dev. ID.                              >> <<04145>>07186000
<<                                                          >> <<04145>>07188000
<<    Command        SHW            Allowed        Type     >> <<04145>>07190000
<<   SHOW             1     DFID,USER.ACCOUNT,*    I & O    >> <<04145>>07192000
<<   OUTPUT & COPY    2     DFID,USER.ACCOUNT,*    O only   >> <<04145>>07194000
<<   PURGE            3     DFID,*                 O only   >> <<04145>>07196000
<<   ALTER            4     DFID,USER.ACCOUNT,*    O only   >> <<04145>>07198000
<<   INPUT            0     DFID,USER.ACCOUNT      O only   >> <<04145>>07200000
<<**********************************************************>> <<04145>>07202000
                                                               <<04145>>07204000
$CONTROL SEGMENT=SPOOK1                                                 07206000
                                                                        07208000
LOGICAL PROCEDURE GETFILES(SHW);                                        07210000
   VALUE   SHW;                                                         07212000
   LOGICAL SHW;                                                         07214000
   BEGIN                                                                07216000
     LOGICAL NOFILES;                                          <<04145>>07218000
   << >>                                                                07220000
   DEVFC := 0;                                                          07222000
                                                               <<04145>>07224000
   <<*******************************************************>> <<04145>>07226000
   << If the command sting gives a list of device ID's or a >> <<04145>>07228000
   << "*", then obtain all the device ID's in the list.     >> <<04145>>07230000
   <<*******************************************************>> <<04145>>07232000
                                                               <<04145>>07234000
   IF BP = "#" OR BP = "*" OR BP = NUMERIC THEN                         07236000
      BEGIN                                                             07238000
      << set both odds and idds bits to 0 >>                   <<xd.m4>>07240000
      SHOWIO := 0;                                                      07242000
      DO                                                                07244000
         BEGIN                                                          07246000
         IF INTEGER(SHW)=0 AND BP="*" THEN                              07248000
            << text file not allowed >>                        <<ld.m4>>07250000
            BEGIN ERRN:=48; GOTO LX; END;                               07252000
         IF NOT GETDEVF THEN GOTO LX;                                   07254000
         TOS := IF DEVF < 0 THEN 1 ELSE 2;                              07256000
         SHOWIO := SHOWIO LOR TOS;                                      07258000
         NOFILES:=TRUE;                                        <<04145>>07260000
         IF BP = "," THEN                                               07262000
            BEGIN                                                       07264000
            NOFILES:=FALSE;                                    <<04145>>07266000
            @BP := @BP+1;                                               07268000
            END;                                                        07270000
         END                                                            07272000
      UNTIL NOFILES;                                           <<04145>>07274000
      SHOWF := TRUE;                                                    07276000
      END                                                               07278000
$PAGE                                                          <<04145>>07280000
                                                               <<04145>>07282000
   <<*******************************************************>> <<04145>>07284000
   <<  If the string gives a USER.ACCOUNT obtains it via    >> <<04145>>07286000
   << GETUSAD. (3 is sent by PURGE, USER.ACCOUNT is illegal >> <<04145>>07288000
   << for PURGE.)  Then, if we have the SHOW command (SHW   >> <<04145>>07290000
   << has value 1) and a ";" follows, look for "@","O" and/ >> <<04145>>07292000
   << or "I".  "@" signifies show all information and the   >> <<04145>>07294000
   << flag SHOWF is set to TRUE.  If no USER.ACCOUNT is     >> <<04145>>07296000
   << specified and we have ALTER command, return error.    >> <<04145>>07298000
   <<*******************************************************>> <<04145>>07300000
                                                               <<04145>>07302000
   ELSE                                                                 07304000
      BEGIN                                                             07306000
      IF SHW = 3 THEN                                                   07308000
         << user.account not allowed for purge >>              <<ld.m4>>07310000
         BEGIN ERRN := 56; GOTO LX; END;                                07312000
      IF (BP = ";" OR BP = CR) AND SHW = 4 THEN                <<04145>>07314000
         << missing dfid or user.account >>                    <<ld.m4>>07316000
         BEGIN ERRN := 80; GOTO LX; END;                       <<04145>>07318000
      IF NOT GETUSAC THEN GOTO LX;                                      07320000
      SHOWIO := IF SHW THEN 3 ELSE 1;                                   07322000
      SHOWF := FALSE;                                                   07324000
      IF SHW AND BP = ";" THEN                                          07326000
         BEGIN                                                          07328000
         DO                                                             07330000
            BEGIN                                                       07332000
            @BP := @BP+1;                                               07334000
            IF BP = "@" THEN SHOWF := TRUE                              07336000
            ELSE IF BP = "I" THEN SHOWIO := SHOWIO LAND 2               07338000
                 ELSE IF BP = "O" THEN SHOWIO := SHOWIO LAND 1          07340000
                      ELSE IF BP <> CR  THEN                   <<04145>>07342000
                              << unexpected character >>       <<ld.m4>>07344000
                              BEGIN ERRN:=33; GOTO LX; END;             07346000
            END                                                         07348000
         UNTIL BP = CR ;                                       <<04145>>07350000
         IF SHOWIO = 0 THEN SHOWIO := 3;                                07352000
         END;                                                           07354000
      END;                                                              07356000
                                                               <<04145>>07358000
   <<*******************************************************>> <<04145>>07360000
   << Set SHOWIO to output only  unless we are using the    >> <<04145>>07362000
   << "SHOW" command, the only one that uses INPUT Dev. ID's>> <<04145>>07364000
   <<*******************************************************>> <<04145>>07366000
                                                               <<04145>>07368000
   IF INTEGER(SHW) <> 1 THEN SHOWIO := 1;                               07370000
   GETFILES := TRUE;                                                    07372000
LX:                                                                     07374000
   END;                                                                 07376000
                                                                        07378000
$PAGE "* * * MOVEFROMXDD * * *"                                <<xd.m4>>07380000
<<**********************************************************>> <<04145>>07382000
<< MOVEFROMXDD moves all the significant entries for the    >> <<04145>>07384000
<< OUTPUT and/or INPUT DEVICE DIRECTORIES into the area be- >> <<04145>>07386000
<< tween DB-2048 and DL(expanding it via DLSIZE as needed), >> <<04145>>07388000
<< or DB-0 and DL, depending on the command being executed. >> <<04145>>07390000
<< It finds the entries that have Device ID's in the array  >> <<04145>>07392000
<< DEVFS or qualify via our USER.ACCOUNT in SNAMES.  Based  >> <<04145>>07394000
<< on SHOWIO, it will search the IDD and/or ODD.  The XDD   >> <<04145>>07396000
<< entries are stored as follows:                           >> <<04145>>07398000
<<           DL----->----------                             >> <<04145>>07400000
<<                   |        |                             >> <<04145>>07402000
<<                   ~        ~                             >> <<04145>>07404000
<<                   |--------|<-----DB-INITXDDP-90         >> <<04145>>07406000
<<                   |  XDD3  |                             >> <<04145>>07408000
<<                   |--------|<-----DB-INITXDDP-60         >> <<04145>>07410000
<<                   |  XDD2  |                             >> <<04145>>07412000
<<                   |--------|<-----DB-INITXDDP-30         >> <<04145>>07414000
<<                   |  XDD1  |                             >> <<04145>>07416000
<<     INITXDDP----->|--------|                             >> <<04145>>07418000
<< (DB-2048 or DB-0) ~        ~                             >> <<04145>>07420000
<<                   |        |                             >> <<04145>>07422000
<<           DB----->|--------|                             >> <<04145>>07424000
<<                                                          >> <<04145>>07426000
<<  We search the array DEVFS for ODD's in the first pass,  >> <<xd.m4>>07428000
<<  and IDD's in the second pass.  1 or 2 passes will be    >> <<xd.m4>>07430000
<<  executed, depending on the value of SHOWIO.             >> <<xd.m4>>07432000
<<                                                          >> <<04145>>07434000
<<   SHOWIO        Passes executed                          >> <<xd.m4>>07436000
<<  %2(11) I&O       Passes 1 & 2                           >> <<xd.m4>>07438000
<<     01  O only    Pass 1 only                            >> <<xd.m4>>07440000
<<     10  I only    Pass 2 only                            >> <<xd.m4>>07442000
<<                                                          >> <<04145>>07444000
<<  First obtain proper SIR. Turn to bit of DEVF on for O   >> <<04145>>07446000
<<  and off for I.                                          >> <<04145>>07448000
<<**********************************************************>> <<04145>>07450000
                                                               <<04145>>07452000
$CONTROL SEGMENT=SPOOK2                                                 07454000
                                                                        07456000
LOGICAL PROCEDURE MOVEFROMXDD;                                 <<04145>>07458000
   BEGIN                                                                07460000
   INTEGER COUNT;                                              <<04145>>07462000
   INTEGER                                                     <<xd.m4>>07464000
      SAVE'XDD'SIR,                                            <<xd.m4>>07466000
      PASS;                                                    <<xd.m4>>07468000
   LOGICAL                                                     <<xd.m4>>07470000
      ERROR,                                                   <<xd.m4>>07472000
      MORE'XDDS,                                               <<xd.m4>>07474000
      COPY'IT,                                                 <<xd.m4>>07476000
      FOUND=MOVEFROMXDD;  <<Signify at least one found >>      <<xd.m4>>07478000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>07480000
   << >>                                                                07482000
   MOVEFROMXDD := FALSE;                                       <<04145>>07484000
   FILE'FOUND := TRUE;                                         <<04145>>07486000
   PASS := 1;                                                  <<xd.m4>>07488000
   XDDC := 0;                                                           07490000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>07492000
   ERROR := FALSE;                                             <<04145>>07494000
   WHILE (PASS <= 2) AND (NOT ERROR) DO                        <<xd.m4>>07496000
      BEGIN                                                             07498000
     << search for ODD's in first pass, IDD's in second pass >><<xd.m4>>07500000
      IF (PASS=1 LAND SHOWIO.ODDS) LOR                         <<xd.m4>>07502000
         (PASS=2 LAND SHOWIO.IDDS) THEN                        <<xd.m4>>07504000
         BEGIN                                                 <<xd.m4>>07506000
         SAVE'XDD'SIR := GETSIR(IF PASS=1 THEN ODD'SIR         <<xd.m4>>07508000
                                          ELSE IDD'SIR);       <<xd.m4>>07510000
         DEVF.IS'ODD := IF PASS=1 THEN 1 ELSE 0;               <<xd.m4>>07512000
         COUNT := -1;                                          <<xd.m4>>07514000
                                                               <<xd.m4>>07516000
      <<****************************************************>> <<04145>>07518000
      << DO UNTIL and ERROR or UNTIL there are still Device >> <<04145>>07520000
      << ID's in the array DEVFS for which to copy thier XDD>> <<04145>>07522000
      << entry (done via COPYXDD).                          >> <<04145>>07524000
      <<****************************************************>> <<04145>>07526000
                                                               <<04145>>07528000
      DO                                                                07530000
         BEGIN                                                          07532000
         MORE'XDDS := (DEVFC <> 0);                            <<xd.m4>>07534000
         COPY'IT := TRUE;                                      <<xd.m4>>07536000
         IF MORE'XDDS THEN                                     <<xd.m4>>07538000
            BEGIN                                                       07540000
            COPY'IT := FALSE;                                  <<xd.m4>>07542000
            WHILE (NOT COPY'IT) AND (COUNT+1 < DEVFC) DO       <<xd.m4>>07544000
               BEGIN                                                    07546000
               COUNT := COUNT + 1;                             <<xd.m4>>07548000
               DEVF := DEVFS(COUNT);                           <<xd.m4>>07550000
               IF (DEVF<0 LAND PASS=1) LOR   << want ODD's >>  <<xd.m4>>07552000
                  (DEVF>0 LAND PASS=2) THEN  << want IDD's >>  <<xd.m4>>07554000
                  COPY'IT := TRUE;                             <<xd.m4>>07556000
               END;                                            <<xd.m4>>07558000
            MORE'XDDS := COPY'IT;                              <<xd.m4>>07560000
            END;   << if more'xdds >>                          <<xd.m4>>07562000
         XDDX := 0;                                                     07564000
         WHILE COPY'IT DO                                      <<xd.m4>>07566000
            BEGIN                                                       07568000
            TOS := COPYXDD(DEVF);                                       07570000
            IF NOT TOS THEN                                             07572000
               COPY'IT := FALSE                                <<xd.m4>>07574000
            ELSE    << successfully copied xdd >>              <<xd.m4>>07576000
               BEGIN                                                    07578000
               XDDC := XDDC+1;                                          07580000
               @XDD'SUBENTRY := @XDD'SUBENTRY -                <<xd.m4>>07582000
                                 SIZE'OF'XDD'SUBENTRY;         <<xd.m4>>07584000
                                                               <<04145>>07586000
         <<*************************************************>> <<04145>>07588000
         <<  If, after updating the address of the XDD en-  >> <<04145>>07590000
         << tries (XDDPoint), it is set before DL (DL>@XDDP)>> <<04145>>07592000
         << then expand DL via DLSIZE and check for errors. >> <<04145>>07594000
         <<*************************************************>> <<04145>>07596000
                                                               <<04145>>07598000
         LL:                                                            07600000
               PUSH(DL);                                                07602000
               IF S0 > @XDD'SUBENTRY THEN                      <<xd.m4>>07604000
                  BEGIN                                                 07606000
                  DLSIZE(S0-512);                                       07608000
                  IF = THEN                                             07610000
                     BEGIN                                              07612000
                     DEL;                                               07614000
                     GOTO LL;                                           07616000
                     END                                                07618000
                  ELSE    << error in expanding DL area >>     <<xd.m4>>07620000
                     BEGIN                                              07622000
                     WARN := 3;                                         07624000
                     ERROR := TRUE;                            <<04145>>07626000
                     COPY'IT := FALSE;                         <<xd.m4>>07628000
                     XDDC := XDDC-1;                                    07630000
                     @XDD'SUBENTRY := @XDD'SUBENTRY +          <<xd.m4>>07632000
                                      SIZE'OF'XDD'SUBENTRY;    <<xd.m4>>07634000
                     END;                                               07636000
                  END;   << if S0 > @xdd'subentry >>           <<xd.m4>>07638000
               DEL;                                                     07640000
               END;                                                     07642000
                                                               <<04145>>07644000
             <<*********************************************>> <<04145>>07646000
             << If we copied an XDD entry, blank out the    >> <<04145>>07648000
             << link pointer, then zero out the entry in    >> <<xd.m4>>07650000
             << our DEVFS array.                            >> <<xd.m4>>07652000
             <<*********************************************>> <<04145>>07654000
                                                               <<04145>>07656000
            IF COPY'IT THEN                                    <<xd.m4>>07658000
              BEGIN                                            <<xd.m4>>07660000
              XDDBUF(XD'ERRS) := 0;                            <<xd.m4>>07662000
              MOVE XDD'SUBENTRY:=XDDBUF,(SIZE'OF'XDD'SUBENTRY);<<xd.m4>>07664000
              DEVFS(COUNT) := 0;                               <<xd.m4>>07666000
              MOVEFROMXDD := TRUE;                             <<xd.m4>>07668000
              END;                                             <<xd.m4>>07670000
            IF MORE'XDDS THEN COPY'IT := FALSE;                <<xd.m4>>07672000
            END;    << while copy'it do >>                     <<xd.m4>>07674000
         END     << do >>                                      <<xd.m4>>07676000
      UNTIL NOT MORE'XDDS OR ERROR;                            <<xd.m4>>07678000
      RELSIR(IF PASS=1 THEN ODD'SIR ELSE IDD'SIR,SAVE'XDD'SIR);<<xd.m4>>07680000
      END;      << if pass=1 and odds, or pass=2 and idds >>   <<xd.m4>>07682000
      PASS := PASS + 1;                                        <<xd.m4>>07684000
   END;     << while pass <= 2 and not error >>                <<xd.m4>>07686000
                                                               <<04145>>07688000
   IF FOUND                                                    <<04145>>07690000
      THEN USERF := ACCTF := FALSE                             <<04145>>07692000
      ELSE IF USERF OR ACCTF                                   <<04145>>07694000
           THEN FILE'FOUND := FALSE;                           <<04145>>07696000
                                                               <<04145>>07698000
   END;                                                                 07700000
$PAGE "* * * SHOWFILES * * *"                                  <<xd.m4>>07702000
                                                                        07704000
$CONTROL SEGMENT=SPOOK2                                                 07706000
                                                                        07708000
PROCEDURE SHOWFILES;                                                    07710000
   BEGIN                                                                07712000
   INTEGER C;                                                           07714000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>07716000
   << >>                                                                07718000
   IF XDDC > 0 THEN                                                     07720000
      BEGIN                                                             07722000
      SHOWP := FALSE;                                                   07724000
      DO                                                                07726000
         BEGIN                                                          07728000
         IF SHOWP THEN PRINT(MSHWX,29,0)                                07730000
         ELSE IF SHOWF THEN PRINT(MSHOW,29,0)                           07732000
                       ELSE PRINT(MSHOWS,19,0);                         07734000
         C := 0;                                                        07736000
         @XDD'SUBENTRY := INITXDDP;                            <<xd.m4>>07738000
         WHILE (C:=C+1) <= XDDC DO                                      07740000
            BEGIN                                                       07742000
            @XDD'SUBENTRY :=@XDD'SUBENTRY-SIZE'OF'XDD'SUBENTRY;<<xd.m4>>07744000
            MOVE XDDBUF := XDD'SUBENTRY,(SIZE'OF'XDD'SUBENTRY);<<xd.m4>>07746000
            TOS := 0;                                                   07748000
            IF SHOWP THEN TOS.(15:1) := 1;                              07750000
            IF SHOWF THEN TOS.(14:1) := 1;                              07752000
            SHOWXDD(*,0);                                               07754000
            END;                                                        07756000
         SHOWP := SHOWP+1;                                              07758000
         END                                                            07760000
      UNTIL NOT SHOWP OR NOT SHOWF;                                     07762000
      END;                                                              07764000
   END;                                                                 07766000
$PAGE "* * * OPENTAPE * * *"                                   <<xd.m4>>07768000
                                                               <<xd.m4>>07770000
<<**********************************************************>> <<04145>>07772000
<< OPENTAPE is called by the INPUT and OUTPUT commands to   >> <<04145>>07774000
<< open the tape file to read from or write to.  OUT=1 for  >> <<04145>>07776000
<< the OUTPUT command and 0 for the INPUT command.  Note    >> <<xd.m4>>07778000
<< that "FILET" is the file number (AFT entry number) of    >> <<xd.m4>>07780000
<< the opened tape file.                                    >> <<xd.m4>>07782000
<<**********************************************************>> <<04145>>07784000
                                                               <<04145>>07786000
$CONTROL SEGMENT=SPOOK3                                                 07788000
                                                                        07790000
LOGICAL PROCEDURE OPENTAPE(OUT);                                        07792000
   VALUE   OUT;                                                         07794000
   LOGICAL OUT;                                                         07796000
   BEGIN                                                                07798000
   INTEGER C,P;                                                         07800000
   INTEGER F,A,R,D,B;                                                   07802000
   INTEGER FX,AX,RX,DX,BX,LD;                                           07804000
   INTEGER SDISC;                                              <<B0.00>>07806000
   << >>                                                                07808000
   SUBROUTINE EOFIN;                                                    07810000
      BEGIN                                                             07812000
      FREAD(FILET,SBUF,1);                                              07814000
      IF < THEN GOTO CLOSET;                                   <<xd.m4>>07816000
      IF = THEN GOTO BADFMT;                                   <<xd.m4>>07818000
      END;                                                              07820000
   << >>                                                                07822000
   SUBROUTINE EOFOUT;                                                   07824000
      BEGIN                                                             07826000
      FCONTROL(FILET,6,P);   << write eof >>                   <<xd.m4>>07828000
      IF <> THEN GOTO CLOSET;                                  <<xd.m4>>07830000
      END;                                                              07832000
   << >>                                                                07834000
                                                               <<04145>>07836000
   <<*******************************************************>> <<04145>>07838000
   << FOPEN the tape file with the following parms:         >> <<04145>>07840000
   << FOPTION - Undef. recs,ASCII, No labled tapes, Domain= >> <<04145>>07842000
   <<           New file for OUT, Old Perm. for INPUT.      >> <<04145>>07844000
   << AOPTION - NOBUF, EXCLUSIVE, Read for IN, Write for OUT>> <<04145>>07846000
   << Record size - 1024 words.                             >> <<04145>>07848000
   <<*******************************************************>> <<04145>>07850000
                                                               <<04145>>07852000
   ERRN := 0;                                                  <<xd.m4>>07854000
   F:= IF OUT THEN %204 ELSE %205;                            <<B0.00>> 07856000
   A := OUT LOR %500;                                                   07858000
   R := 1024;                                                           07860000
   D := 24;                                                             07862000
   SDISC := 31;    <<SERIAL DISC>>                             <<B0.00>>07864000
   B := 1024;                                                           07866000
   IF BP = CR  THEN                                            <<04145>>07868000
      << invalid tape file >>                                  <<ld.m4>>07870000
      BEGIN ERRN := 52; GOTO QUICKOUT; END;                    <<xd.m4>>07872000
   FILET := FOPEN(BP,F,A,R);                                            07874000
   IF <> THEN                                                           07876000
      << unable to open tape file >>                           <<ld.m4>>07878000
      BEGIN ERRN := 50; FCHECK(FILET,ERRF); GOTO QUICKOUT; END;<<xd.m4>>07880000
$PAGE                                                          <<04145>>07882000
                                                               <<04145>>07884000
   <<*******************************************************>> <<04145>>07886000
   << Since a FILE command can over-ride the above parms,   >> <<04145>>07888000
   << check for compatibility.                              >> <<04145>>07890000
   <<  REC. and Block size - convert to words.              >> <<04145>>07892000
   <<*******************************************************>> <<04145>>07894000
                                                               <<04145>>07896000
   FGETINFO(FILET,,FX,AX,RX,DX,LD,,,,,,,,BX);                           07898000
   IF RX < 0 THEN RX := (-RX)&ASR(1);                                   07900000
   IF BX < 0 THEN BX := (-BX)&ASR(1);                                   07902000
                                                               <<04145>>07904000
   <<*******************************************************>> <<04145>>07906000
   << Now check for FOPTION,AOPTION,REC. and BLOCK size     >> <<04145>>07908000
   << compatibiltiy.  Also, check for proper type, 24 for   >> <<04145>>07910000
   << mag tape or 31 for serial disc.                       >> <<04145>>07912000
   <<*******************************************************>> <<04145>>07914000
                                                               <<04145>>07916000
   IF F<>FX OR A<>AX OR R<>RX OR B<>BX                         <<B0.00>>07918000
      OR NOT((D=DX.(8:8)) LOR (SDISC = DX.(8:8))) THEN         <<00897>>07920000
      << invalid tape file >>                                  <<ld.m4>>07922000
      BEGIN ERRN := 52; GOTO CLOSET; END;                      <<xd.m4>>07924000
   MREEL(11) := "  ";                                                   07926000
   MREEL(12) := "  ";                                                   07928000
   ASCII(LD,10,MREEL(11));                                              07930000
   REEL := 1;                                                           07932000
   EOTMARK := FALSE;                                                    07934000
   LASTREEL := FALSE;                                                   07936000
   FILEEND := TRUE;                                                     07938000
                                                               <<04145>>07940000
   <<*******************************************************>> <<04145>>07942000
   << For INPUT, first skip over 2 EOF's via EOFIN.  Next,  >> <<04145>>07944000
   << read 40 word Label Record.  Compare reel number on    >> <<04145>>07946000
   << tape with REEL and check words 0-13 for TAPEID. Lastly>> <<04145>>07948000
   << obtain DATE and TIME and skip over next EOF.          >> <<04145>>07950000
   <<*******************************************************>> <<04145>>07952000
                                                               <<04145>>07954000
   IF NOT OUT THEN                                                      07956000
      BEGIN                                                             07958000
      EOFIN;                                                            07960000
      EOFIN;                                                            07962000
      TCOUNT := FREAD(FILET,TBUF,41);                                   07964000
      IF <> THEN GOTO BADREAD;                                 <<xd.m4>>07966000
      IF TCOUNT <> 40 THEN GOTO BADFMT;                        <<xd.m4>>07968000
      IF INTEGER(L0REEL) <> REEL THEN GOTO BADFMT;             <<xd.m4>>07970000
      C := -1;                                                          07972000
      WHILE (C:=C+1)<14 DO                                     <<xd.m4>>07974000
         IF TBUF(C) <> TAPEID(C) THEN GOTO BADFMT;             <<xd.m4>>07976000
      DATE := L0DATE;                                          <<xd.m4>>07978000
      TIME1 := L0TIME1;                                        <<xd.m4>>07980000
      TIME2 := L0TIME2;                                        <<xd.m4>>07982000
      MPE5TAPE := TRUE;                                        <<xd.m4>>07984000
      C := -1;                                                 <<xd.m4>>07986000
      WHILE (C:=C+1) < 2 DO                                    <<xd.m4>>07988000
         IF TBUF(C+30) <> TAPEMPEV(C) THEN MPE5TAPE := FALSE;  <<xd.m4>>07990000
      EOFIN;                                                            07992000
      END                                                               07994000
$PAGE                                                          <<04145>>07996000
                                                               <<04145>>07998000
   <<*******************************************************>> <<04145>>08000000
   << For OUTPUT, we set up the beginnig of the tape:       >> <<04145>>08002000
   <<      EOF,EOF,                                         >> <<04145>>08004000
   <<      Label Record contains:                           >> <<04145>>08006000
   <<          Words 0-13: "SPOOLFILETAPE LABEL-HP3000."    >> <<04145>>08008000
   <<          Word   23 : Reel number (1 to last)          >> <<04145>>08010000
   <<          Word   24 : DATE                             >> <<04145>>08012000
   <<          Words 25-26: TIME                            >> <<04145>>08014000
   <<          Words 30-31: "MPEV" if it's a MPE5 Spook tape>> <<xd.m4>>08016000
   <<      All other words zero.                            >> <<04145>>08018000
   <<*******************************************************>> <<04145>>08020000
                                                               <<04145>>08022000
   ELSE                                                                 08024000
      BEGIN                                                             08026000
      TBUF := 0;                                                        08028000
      MOVE TBUF(1) := TBUF,(39);                                        08030000
      MOVE L0SPOOKID := TAPEID,(14);                           <<xd.m4>>08032000
      L0REEL := REEL;                                          <<xd.m4>>08034000
      DATE := CALENDAR;                                                 08036000
      TIME := CLOCK;                                                    08038000
      L0DATE := DATE;                                          <<xd.m4>>08040000
      L0TIME1:= TIME1;                                         <<xd.m4>>08042000
      L0TIME2:= TIME2;                                         <<xd.m4>>08044000
      IF LDT'MPE'VERSION = 5 THEN                              <<xd.m4>>08046000
         MOVE L0MPE5 := TAPEMPEV, (2);                         <<xd.m4>>08048000
      EOFOUT;                                                           08050000
      EOFOUT;                                                           08052000
      FWRITE(FILET,TBUF,40,0);                                          08054000
      IF <> THEN GOTO BADWRITE;                                <<xd.m4>>08056000
      EOFOUT;                                                           08058000
      END;                                                              08060000
                                                               <<xd.m4>>08062000
   OPENTAPE := TRUE;                                                    08064000
   GOTO QUICKOUT;                                              <<xd.m4>>08066000
BADFMT:                                                        <<xd.m4>>08068000
   << invalid tape format >>                                   <<ld.m4>>08070000
   ERRN := 53;                                                          08072000
   GOTO CLOSET;                                                <<xd.m4>>08074000
BADREAD:   << tape file read error >>                          <<xd.m4>>08076000
   ERRN := 54;                                                 <<xd.m4>>08078000
   GOTO CLOSET;                                                <<xd.m4>>08080000
BADWRITE:  << tape file write error >>                         <<xd.m4>>08082000
   ERRN := 55;                                                 <<xd.m4>>08084000
CLOSET:                                                        <<xd.m4>>08086000
   FCLOSE(FILET,1,0);                                          <<02724>>08088000
   FILET := 0;                                                          08090000
QUICKOUT:                                                      <<xd.m4>>08092000
   END;                                                                 08094000
$PAGE "* * * INDIRECTORY * * *"                                <<xd.m4>>08096000
$CONTROL SEGMENT=SPOOK3                                                 08098000
                                                                        08100000
<<----------------------------------------------------------->><<ld.m4>>08102000
<< INDIRECTORY is called by the main loop when an INPUT com- >><<ld.m4>>08104000
<< mand is encountered in the command string.  It reads in   >><<ld.m4>>08106000
<< the file directory entries from the SPOOK tape for the    >><<ld.m4>>08108000
<< files to be input.  I don't know what else it's doing...  >><<ld.m4>>08110000
<<----------------------------------------------------------->><<ld.m4>>08112000
                                                               <<ld.m4>>08114000
LOGICAL PROCEDURE INDIRECTORY;                                          08116000
   BEGIN                                                                08118000
   INTEGER                                                     <<ld.m4>>08120000
      LPDT'INDEX,                                              <<ld.m4>>08122000
      LDT'INDEX,                                               <<ld.m4>>08124000
      LDEV,                                                    <<ld.m4>>08126000
      HITS,                                                    <<xd.m4>>08128000
      NEW'LDEV,                                                <<xd.m4>>08130000
      MAX'HITS,                                                <<xd.m4>>08132000
      NUM'DEVS,                                                <<ld.m4>>08134000
      DEV'TYPE,                                                <<ld.m4>>08136000
      DEV'COUNT,                                               <<ld.m4>>08138000
      ENTRY'SIZE,                                              <<xd.m4>>08140000
      N, M,                                                    <<infil>>08142000
      I, IX;                                                   <<ld.m4>>08144000
   LOGICAL NO'MORE;                                            <<xd.m4>>08146000
      LOGICAL MATCH;                                           <<infil>>08148000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>08150000
   INTEGER POINTER DCP;                                                 08152000
   INTEGER POINTER DPTR;                                       <<02686>>08154000
   LOGICAL POINTER                                             <<ld.m4>>08156000
      LDT,                                                     <<ld.m4>>08158000
      DCT;                                                     <<ld.m4>>08160000
   BYTE POINTER DCT'B;                                         <<ld.m4>>08162000
   INTEGER ARRAY ADVC(*)=Q;  <<LAST DECL>>                              08164000
   << >>                                                                08166000
$PAGE                                                          <<xd.m4>>08168000
<<----------------------------------------------------------->><<ld.m4>>08170000
<< TEST'LDEV checks to see how the current logical device    >><<ld.m4>>08172000
<< entry in the system LDT compares with the logical device  >><<ld.m4>>08174000
<< entry in the spook tape directory.  The return value of   >><<ld.m4>>08176000
<< TEST'LDEV depends on how many of the following fields     >><<ld.m4>>08178000
<< match:  device type, subtype, and record width.           >><<ld.m4>>08180000
<< (Assuming this is a real device).                         >><<ld.m4>>08182000
<< Note:  DB is at LDT'DST when this subroutine is called.   >><<ld.m4>>08184000
<<----------------------------------------------------------->><<ld.m4>>08186000
                                                               <<ld.m4>>08188000
   INTEGER SUBROUTINE TEST'LDEV;                               <<ld.m4>>08190000
      BEGIN                                                             08192000
      LDT'INDEX := LDEV * SIZE'OF'LDT'ENTRY;                   <<ld.m4>>08194000
      LPDT'INDEX := LDEV * SIZE'OF'LPDT'ENTRY;                 <<ld.m4>>08196000
      IF ADVC(2).(10:6)=INTEGER(LDT'DEVICE'TYPE) THEN          <<ld.m4>>08198000
         BEGIN                                                 <<ld.m4>>08200000
         TEST'LDEV := 1;                                       <<ld.m4>>08202000
         IF ADVC(1).(0:8)=INTEGER(LPDT'SUBTYPE) THEN           <<ld.m4>>08204000
            BEGIN                                                       08206000
            TEST'LDEV := 2;                                    <<ld.m4>>08208000
            IF ADVC(2).(0:8)=INTEGER(LDT'RECORD'WIDTH) THEN    <<ld.m4>>08210000
               TEST'LDEV := 3;                                 <<ld.m4>>08212000
            END;                                                        08214000
         END;                                                           08216000
      IF LPDT'VIRTUAL'DEVICE OR (LPDT'DIT'PTR = 0)  THEN       <<ld.m4>>08218000
            TEST'LDEV := 0;  <<ILLEGAL OR VIRTUAL>>            <<ld.m4>>08220000
      END;                                                              08222000
   << >>                                                                08224000
$PAGE                                                          <<xd.m4>>08226000
<<----------------------------------------------------------->><<ld.m4>>08228000
<< TEST'CLASS is given an DCT entry.  For each ldev in the   >><<ld.m4>>08230000
<< DCT entry, it looks up its device type in the system LDT, >><<ld.m4>>08232000
<< and searches for a matching device type in the array ADVC.>><<ld.m4>>08234000
<< The return value of TEST'CLASS depends on how many of the >><<ld.m4>>08236000
<< device characteristics matched:                           >><<ld.m4>>08238000
<<        0:  nothing matched                                >><<ld.m4>>08240000
<<        1:  only type matched                              >><<ld.m4>>08242000
<<        2:  type and class name matched                    >><<ld.m4>>08244000
<< Note:  DB is at LDT'DST here.                             >><<ld.m4>>08246000
<<----------------------------------------------------------->><<ld.m4>>08248000
                                                               <<ld.m4>>08250000
   INTEGER SUBROUTINE TEST'CLASS;                              <<ld.m4>>08252000
      BEGIN                                                             08254000
      @DCT'B := @DCT&LSL(1) + DCT'FIRST'LDEV - 1;              <<ld.m4>>08256000
      HITS := 0;                                               <<xd.m4>>08258000
      DEV'COUNT := 1;                                          <<ld.m4>>08260000
      WHILE DEV'COUNT <= integer(DCT'NUM'DEVICES) DO           <<ld.m4>>08262000
         BEGIN                                                          08264000
         LDEV := integer(DCT'B(DEV'COUNT));                    <<ld.m4>>08266000
         LDT'INDEX := LDEV * SIZE'OF'LDT'ENTRY;                <<ld.m4>>08268000
         DEV'TYPE := LDT'DEVICE'TYPE;                          <<ld.m4>>08270000
         NUM'DEVS := ADVC(7);                                  <<ld.m4>>08272000
         WHILE (NUM'DEVS := NUM'DEVS-1) >= 0 DO                <<ld.m4>>08274000
            IF ADVC(8+NUM'DEVS) = DEV'TYPE THEN                <<ld.m4>>08276000
               HITS := HITS + 1;                               <<xd.m4>>08278000
         DEV'COUNT := DEV'COUNT+1;                             <<ld.m4>>08280000
         END;                                                           08282000
      IF HITS <> 0 THEN                                        <<xd.m4>>08284000
         BEGIN   << try to match class name >>                 <<ld.m4>>08286000
         HITS := 0;                                            <<xd.m4>>08288000
         DEV'COUNT := 4;                                       <<ld.m4>>08290000
         WHILE (DEV'COUNT:=DEV'COUNT-1) >= 0 DO                <<ld.m4>>08292000
           IF integer(DCT(DEV'COUNT)) <> ADVC(2+DEV'COUNT) THEN<<ld.m4>>08294000
               HITS := HITS + 1;                               <<xd.m4>>08296000
      TEST'CLASS := IF HITS = 0 THEN 2 ELSE 1;                 <<xd.m4>>08298000
         END;                                                           08300000
      END;                                                              08302000
   << >>                                                       <<02686>>08304000
$PAGE                                                          <<xd.m4>>08306000
<<----------------------------------------------------------->><<ld.m4>>08308000
<< GETTYPE is given an ldev number (LDEV) which is an entry  >><<ld.m4>>08310000
<< within the device class entry of the SPOOK tape directory.>><<ld.m4>>08312000
<< It then searches the logical device entries in the same   >><<ld.m4>>08314000
<< directory to find the matching ldev, and returns its      >><<ld.m4>>08316000
<< device type.                                              >><<ld.m4>>08318000
<<----------------------------------------------------------->><<ld.m4>>08320000
                                                               <<ld.m4>>08322000
   INTEGER SUBROUTINE GETTYPE;                                 <<02686>>08324000
      BEGIN                                                    <<02686>>08326000
      GETTYPE:=0;                                              <<02686>>08328000
      @DPTR:=INITXDDP;                                         <<02686>>08330000
      WHILE DPTR<>0 DO                                         <<02686>>08332000
         BEGIN                                                 <<02686>>08334000
         IF DPTR=LDEV THEN                                     <<ld.m4>>08336000
            BEGIN                                              <<02686>>08338000
            GETTYPE:=DPTR(2).(10:6);                           <<02686>>08340000
            RETURN;                                            <<02686>>08342000
            END;                                               <<02686>>08344000
         IF DPTR > 0 THEN   << ldev entry >>                   <<xd.m4>>08346000
            @DPTR := @DPTR + LDEV'ENTRYSIZE                    <<xd.m4>>08348000
         ELSE               << class entry >>                  <<xd.m4>>08350000
            @DPTR := @DPTR + DPTR(1);                          <<xd.m4>>08352000
         END;                                                  <<02686>>08354000
      END;                                                     <<02686>>08356000
                                                               <<ld.m4>>08358000
$PAGE                                                          <<xd.m4>>08360000
   << begin procedure INDIRECTORY >>                           <<ld.m4>>08362000
   XDDC := 0;                                                           08364000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>08366000
   FILE'MATCH := FALSE;                                        <<infil>>08368000
   FILE'FOUND := TRUE;                                         <<04329>>08370000
   NO'MORE := FALSE;                                           <<xd.m4>>08372000
                                                               <<ld.m4>>08374000
<<---------------------------------------------------------->> <<xd.m4>>08376000
<< File directory entries are 12 words long, and are padded >> <<xd.m4>>08378000
<< into as many 1020-word records as necessary.  They will  >> <<xd.m4>>08380000
<< be read into the DB- area.  Each 12 word entry will be   >> <<xd.m4>>08382000
<< placed into a XDD subentry size slot (30 or 32 words).   >> <<xd.m4>>08384000
<< This is to reserve space for the XDD subentries which    >> <<xd.m4>>08386000
<< will overlay them later in procedure INFILES.            >> <<xd.m4>>08388000
<<---------------------------------------------------------->> <<xd.m4>>08390000
   DO                                                                   08392000
      BEGIN                                                             08394000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 08396000
      IF < THEN GOTO BADREAD;                                  <<ld.m4>>08398000
      IF > THEN GOTO BADFMT;                                   <<ld.m4>>08400000
      IF TCOUNT <> FDIR'RECSIZE THEN                           <<xd.m4>>08402000
         NO'MORE := TRUE                                       <<xd.m4>>08404000
      ELSE                                                              08406000
         BEGIN                                                          08408000
         IX := 0;                                                       08410000
         DO                                                             08412000
            BEGIN                                                       08414000
            IF SBUF(IX) = 0 THEN                                        08416000
               NO'MORE := TRUE                                 <<xd.m4>>08418000
            ELSE                                                        08420000
               BEGIN                                                    08422000
               XDDC := XDDC+1;                                          08424000
               @XDD'SUBENTRY := @XDD'SUBENTRY -                <<xd.m4>>08426000
                                 SIZE'OF'XDD'SUBENTRY;         <<xd.m4>>08428000
         LL:                                                            08430000
               PUSH(DL);                                                08432000
               IF S0 > @XDD'SUBENTRY THEN                      <<xd.m4>>08434000
                  BEGIN                                                 08436000
                  DLSIZE(S0-512);                                       08438000
                  IF = THEN                                             08440000
                     BEGIN                                              08442000
                     DEL;                                               08444000
                     GOTO LL;                                           08446000
                     END                                                08448000
                  ELSE                                                  08450000
                     BEGIN                                              08452000
                     WARN := 3;                                         08454000
                     NO'MORE := TRUE;                          <<xd.m4>>08456000
                     XDDC := XDDC-1;                                    08458000
                     @XDD'SUBENTRY := @XDD'SUBENTRY +          <<xd.m4>>08460000
                                       SIZE'OF'XDD'SUBENTRY;   <<xd.m4>>08462000
                     END;                                               08464000
                  END;                                                  08466000
               DEL;                                                     08468000
$PAGE                                                          <<infil>>08470000
<<---------------------------------------------------------->> <<infil>>08472000
<< As the file directory entries are being read in, we com- >> <<infil>>08474000
<< pare it to the dfid's in the array DEVFS or a matching   >> <<infil>>08476000
<< user.acct.  FILE'MATCH is set to true if we find at      >> <<infil>>08478000
<< least one spoolfile that we're looking for on this tape. >> <<infil>>08480000
<< If not, we don't scan through the tape later in procedure>> <<infil>>08482000
<< INFILES.                                                 >> <<infil>>08484000
<<---------------------------------------------------------->> <<infil>>08486000
                                                               <<infil>>08488000
               IF NOT NO'MORE THEN                             <<xd.m4>>08490000
                  BEGIN                                        <<infil>>08492000
                  MOVE XDD'SUBENTRY:=SBUF(IX),(FDIR'ENTRYSIZE);<<xd.m4>>08494000
                  IF NOT FILE'MATCH THEN                       <<infil>>08496000
                     IF DEVFC <> 0 THEN                        <<infil>>08498000
                        BEGIN                                  <<infil>>08500000
                        I := -1;                               <<infil>>08502000
                        WHILE (I:=I+1) < DEVFC DO              <<infil>>08504000
                           IF XDD'SUBENTRY = DEVFS(I) THEN     <<infil>>08506000
                              FILE'MATCH := TRUE;              <<infil>>08508000
                        END                                    <<infil>>08510000
                     ELSE                                      <<infil>>08512000
                        BEGIN                                  <<infil>>08514000
                        MATCH := TRUE;                         <<infil>>08516000
                        N := IF USERF THEN -1 ELSE 3;          <<infil>>08518000
                        M := IF ACCTF THEN 8 ELSE 4;           <<infil>>08520000
                        WHILE (N:=N+1) < M DO                  <<infil>>08522000
                         IF XDD'SUBENTRY(4+N) <> SNAMES(N) THEN<<infil>>08524000
                           MATCH := FALSE;                     <<infil>>08526000
                        IF MATCH THEN FILE'MATCH := TRUE;      <<infil>>08528000
                        END;                                   <<infil>>08530000
                  END;                                         <<infil>>08532000
               END;                                                     08534000
            END                                                         08536000
         UNTIL NO'MORE OR                                      <<xd.m4>>08538000
           (IX := IX+FDIR'ENTRYSIZE) >= FDIR'RECSIZE;          <<xd.m4>>08540000
         END;                                                           08542000
      END                                                               08544000
   UNTIL NO'MORE;                                              <<xd.m4>>08546000
                                                               <<ld.m4>>08548000
   << The last 1020 word record may be padded with 0's at   >> <<xd.m4>>08550000
   << the end.  This loop skips over the 0's portion.       >> <<xd.m4>>08552000
                                                               <<xd.m4>>08554000
   WHILE TCOUNT = FDIR'RECSIZE DO                              <<xd.m4>>08556000
      BEGIN                                                             08558000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 08560000
      IF < THEN GOTO BADREAD;                                  <<ld.m4>>08562000
      IF > THEN GOTO BADFMT;                                   <<ld.m4>>08564000
      END;                                                              08566000
                                                               <<ld.m4>>08568000
   << We should now be at the start of the device and class >> <<xd.m4>>08570000
   << directory, which is contained in one 1024-word record.>> <<xd.m4>>08572000
                                                               <<xd.m4>>08574000
   IF TCOUNT <> 1024 THEN GOTO BADFMT;                         <<ld.m4>>08576000
   @DCP := INITXDDP;                                                    08578000
   MOVE DCP := SBUF,(1024);                                             08580000
                                                               <<xd.m4>>08582000
   << read in first 2 spoofle blocks >>                        <<xd.m4>>08584000
   TCOUNT := FREAD(FILET,SBUF,1024);                                    08586000
   IF < THEN GOTO BADREAD;                                     <<ld.m4>>08588000
   IF = THEN                                                            08590000
      BEGIN                                                             08592000
      IF TCOUNT <> 1024 THEN GOTO BADFMT;                      <<ld.m4>>08594000
      MOVE DCP(1024) := SBUF,(1024);                                    08596000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 08598000
      IF < THEN GOTO BADREAD;                                  <<ld.m4>>08600000
      IF = THEN GOTO BADFMT;                                   <<ld.m4>>08602000
      END;                                                              08604000
                                                               <<ld.m4>>08606000
   @DCP := INITXDDP;                                                    08608000
   IX := 0;                                                    <<xd.m4>>08610000
   WHILE DCP <> 0 DO                                                    08612000
      BEGIN                                                             08614000
      IF DCP > 0 THEN                                          <<xd.m4>>08616000
         ENTRY'SIZE := LDEV'ENTRYSIZE                          <<xd.m4>>08618000
      ELSE                                                     <<xd.m4>>08620000
         ENTRY'SIZE := DCP(1);                                 <<xd.m4>>08622000
      TOS := ENTRY'SIZE;                                       <<xd.m4>>08624000
      ASSEMBLE(ADDS 0);                                                 08626000
                                                               <<ld.m4>>08628000
      << Move in an entry into ADVC from the device and class>><<ld.m4>>08630000
      << directory.  It can be a logical device entry or a   >><<ld.m4>>08632000
      << device class entry.                                 >><<ld.m4>>08634000
                                                               <<ld.m4>>08636000
      MOVE ADVC := DCP, (ENTRY'SIZE);                          <<xd.m4>>08638000
      NEW'LDEV := 0;                                           <<xd.m4>>08640000
      MAX'HITS := 0;                                           <<xd.m4>>08642000
      IF ADVC > 0 THEN     << it's a ldev entry >>             <<ld.m4>>08644000
         BEGIN                                                          08646000
         @LDT := 0;                                            <<ld.m4>>08648000
         EXCHANGEDB(LDT'DST);                                  <<ld.m4>>08650000
         LDEV := 1;                                            <<ld.m4>>08652000
                                                               <<ld.m4>>08654000
         << Try to find an ldev in the system LDT that      >> <<xd.m4>>08656000
         << matches as closely as possible the original     >> <<xd.m4>>08658000
         << ldev the spool file was created for.            >> <<xd.m4>>08660000
                                                               <<xd.m4>>08662000
         DO                                                             08664000
            BEGIN                                                       08666000
            HITS := TEST'LDEV;                                 <<xd.m4>>08668000
            IF HITS > MAX'HITS OR                              <<xd.m4>>08670000
              (HITS = MAX'HITS LAND LDEV=ADVC) THEN            <<xd.m4>>08672000
            BEGIN                                              <<xd.m4>>08674000
               MAX'HITS := HITS;                               <<xd.m4>>08676000
               NEW'LDEV := LDEV;                               <<xd.m4>>08678000
            END;                                               <<xd.m4>>08680000
            END                                                         08682000
         UNTIL (LDEV := LDEV+1) > INTEGER(LDT'NUM'ENTRIES);    <<ld.m4>>08684000
         END                                                   <<xd.m4>>08686000
      ELSE    << it's a device class entry >>                  <<ld.m4>>08688000
         BEGIN                                                          08690000
         IF MPE5TAPE THEN DEV'COUNT := ADVC(7)                 <<xd.m4>>08692000
                     ELSE DEV'COUNT := ADVC(7).(0:8);          <<xd.m4>>08694000
         TOS := DEV'COUNT + 8 - ENTRY'SIZE;                    <<xd.m4>>08696000
         ASSEMBLE(ADDS 0);                                              08698000
         ADVC(1) := DEV'COUNT + 8;   << size of ADVC entry  >> <<xd.m4>>08700000
         NUM'DEVS := DEV'COUNT;                                <<ld.m4>>08702000
                                                               <<ld.m4>>08704000
         << find a matching ldev entry in the device and    >> <<xd.m4>>08706000
         << class directory.                                >> <<xd.m4>>08708000
                                                               <<ld.m4>>08710000
         WHILE NUM'DEVS > 0 DO                                 <<ld.m4>>08712000
            BEGIN                                              <<xd.m4>>08714000
            IF MPE5TAPE THEN                                   <<xd.m4>>08716000
               LDEV := ADVC(7+NUM'DEVS)                        <<xd.m4>>08718000
            ELSE   << mpe4 spook tape >>                       <<xd.m4>>08720000
               LDEV := IF LOGICAL(NUM'DEVS) THEN               <<xd.m4>>08722000
                          ADVC(7+(NUM'DEVS/2)).(8:8)           <<xd.m4>>08724000
                       ELSE ADVC(7+(NUM'DEVS/2)).(0:8);        <<xd.m4>>08726000
                                                               <<infil>>08728000
            << replace ldev#'s in the device class entry with>><<infil>>08730000
            << the corresponding device type found in the    >><<infil>>08732000
            << logical device entry.                         >><<infil>>08734000
                                                               <<infil>>08736000
            ADVC(7+NUM'DEVS) := GETTYPE;                       <<ld.m4>>08738000
            NUM'DEVS := NUM'DEVS-1;                            <<ld.m4>>08740000
            END;                                                        08742000
         ADVC(7) := DEV'COUNT;                                 <<ld.m4>>08744000
         @LDT := 0;                                            <<ld.m4>>08746000
         EXCHANGEDB(LDT'DST);                                  <<ld.m4>>08748000
         @DCT := LDT'DCT'BASE;                                 <<ld.m4>>08750000
         I := 0;                                               <<ld.m4>>08752000
         WHILE (I:=I+1) <= integer(LDT'NUM'DCT'ENTRIES) DO     <<ld.m4>>08754000
            BEGIN                                                       08756000
            HITS := TEST'CLASS;                                <<xd.m4>>08758000
            IF HITS > MAX'HITS THEN                            <<xd.m4>>08760000
               BEGIN MAX'HITS := HITS; NEW'LDEV := I; END;     <<xd.m4>>08762000
            @DCT := @DCT + integer(DCT'NEXT'ENTRY);            <<ld.m4>>08764000
            END;                                                        08766000
         END;                                                           08768000
      EXCHANGEDB(0);                                                    08770000
      TOS := ENTRY'SIZE;                                       <<xd.m4>>08772000
      ASSEMBLE(SUBS 0);                                                 08774000
      NEWLDEVS(IX) := IF MAX'HITS=0 THEN 0 ELSE NEW'LDEV;      <<xd.m4>>08776000
      @DCP := @DCP + ENTRY'SIZE;                               <<xd.m4>>08778000
      IX := IX + 1;                                            <<xd.m4>>08780000
      END;   << while DCP <> 0 >>                              <<xd.m4>>08782000
   INDIRECTORY := TRUE;                                                 08784000
                                                               <<04329>>08786000
   << If USER.ACCOUNT was specified, and no files found,    >> <<04329>>08788000
   << then FILE'FOUND  signifies this.  Used in SHOWERRORS. >> <<04329>>08790000
                                                               <<04329>>08792000
   IF (NOT FILE'MATCH) AND (USERF OR ACCTF)                    <<infil>>08794000
      THEN FILE'FOUND := FALSE;   << No files found U.A     >> <<04329>>08796000
                                                               <<04329>>08798000
   GOTO QUICKOUT;                                              <<ld.m4>>08800000
BADFMT:      << invalid tape format >>                         <<ld.m4>>08802000
   ERRN := 53;                                                          08804000
   GOTO CLOSEOUT;                                              <<ld.m4>>08806000
BADREAD:      << unable to open tape file >>                   <<ld.m4>>08808000
   ERRN := 54;                                                          08810000
CLOSEOUT:                                                      <<ld.m4>>08812000
   FCLOSE(FILET,1,0);                                          <<02724>>08814000
   FILET := 0;                                                          08816000
QUICKOUT:                                                      <<ld.m4>>08818000
   END;                                                                 08820000
$PAGE "* * * OUTDIRECTORY * * *"                               <<xd.m4>>08822000
$CONTROL SEGMENT=SPOOK3                                                 08824000
                                                                        08826000
<<----------------------------------------------------------->><<ld.m4>>08828000
<< OUTDIRECTORY is called by the main loop when an OUTPUT    >><<ld.m4>>08830000
<< command is encountered in the commmand string.  It creates>><<ld.m4>>08832000
<< entries in the SPOOK tape directory for the spoofles to   >><<ld.m4>>08834000
<< be output to tape.                                        >><<ld.m4>>08836000
<<----------------------------------------------------------->><<ld.m4>>08838000
                                                               <<ld.m4>>08840000
LOGICAL PROCEDURE OUTDIRECTORY;                                         08842000
   BEGIN                                                                08844000
   INTEGER                                                     <<ld.m4>>08846000
      LPDT'INDEX,                                              <<ld.m4>>08848000
      LDT'INDEX,                                               <<ld.m4>>08850000
      LDEV,                                                    <<ld.m4>>08852000
      LIMIT,                                                   <<ld.m4>>08854000
      DEV'COUNT,                                               <<ld.m4>>08856000
      P,                                                       <<ld.m4>>08858000
      C, IX;                                                   <<ld.m4>>08860000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>08862000
   LOGICAL POINTER                                             <<ld.m4>>08864000
      LDT,                                                     <<ld.m4>>08866000
      DCT;                                                     <<ld.m4>>08868000
   INTEGER POINTER DCP,DP;                                              08870000
   BYTE POINTER                                                <<ld.m4>>08872000
      DCP'B;                                                   <<ld.m4>>08874000
   << >>                                                                08876000
$PAGE                                                          <<xd.m4>>08878000
   <<------------------------------------------------------->> <<ld.m4>>08880000
   << GOT'LDCL searches through the device and class direc- >> <<ld.m4>>08882000
   << tory, and returns true if it finds a matching ldev or >> <<ld.m4>>08884000
   << device class.  It is called to avoid placing duplicate>> <<xd.m4>>08886000
   << entries in the directory.                             >> <<xd.m4>>08888000
   <<------------------------------------------------------->> <<xd.m4>>08890000
                                                               <<xd.m4>>08892000
   LOGICAL SUBROUTINE GOT'LDCL;                                <<ld.m4>>08894000
      BEGIN                                                             08896000
      IX := 0;                                                 <<ld.m4>>08898000
      @DP := INITXDDP;                                                  08900000
      WHILE (IX:=IX+1) <= DEV'COUNT DO                         <<ld.m4>>08902000
        BEGIN                                                           08904000
        IF DP = LDEV THEN GOT'LDCL := TRUE;                    <<ld.m4>>08906000
      IF DP > 0 THEN                                           <<xd.m4>>08908000
         @DP := @DP + LDEV'ENTRYSIZE                           <<xd.m4>>08910000
      ELSE                                                     <<xd.m4>>08912000
         @DP := @DP + DP(1);                                   <<xd.m4>>08914000
        END;                                                            08916000
      END;                                                              08918000
   << >>                                                                08920000
$PAGE                                                          <<xd.m4>>08922000
   <<------------------------------------------------------->> <<ld.m4>>08924000
   << PUT'LDEV creates a new logical device entry in the    >> <<ld.m4>>08926000
   << SPOOK tape directory.  It extracts the device subtype >> <<ld.m4>>08928000
   << from the LPDT, and the record width and device type   >> <<ld.m4>>08930000
   << from the LDT.  The format of the Logical Device Entry >> <<ld.m4>>08932000
   << is:                                                   >> <<ld.m4>>08934000
   <<                                                       >> <<ld.m4>>08936000
   <<    Word 0:  logical device number                     >> <<ld.m4>>08938000
   <<                                                       >> <<ld.m4>>08940000
   <<    Word 1:  Bits 0:8, device subtype                  >> <<ld.m4>>08942000
   <<             Bits 8:8, 3=length of this entry in words >> <<ld.m4>>08944000
   <<                                                       >> <<ld.m4>>08946000
   <<    Word 2:  device type                               >> <<ld.m4>>08948000
   <<------------------------------------------------------->> <<ld.m4>>08950000
                                                               <<ld.m4>>08952000
   SUBROUTINE PUT'LDEV;                                        <<ld.m4>>08954000
      BEGIN                                                             08956000
      DCP := LDEV;                                             <<ld.m4>>08958000
      LPDT'INDEX := LDEV * SIZE'OF'LPDT'ENTRY;                 <<ld.m4>>08960000
      DCP(1).(0:8) := LPDT'SUBTYPE;                            <<ld.m4>>08962000
      DCP(1).(8:8) := LDEV'ENTRYSIZE;                          <<ld.m4>>08964000
      @LDT := 0;                                               <<ld.m4>>08966000
      LDT'INDEX := LDEV * SIZE'OF'LDT'ENTRY;                   <<ld.m4>>08968000
      EXCHANGEDB(LDT'DST);                                     <<ld.m4>>08970000
      TOS := LDT(LDT'INDEX+2);                                 <<ld.m4>>08972000
      EXCHANGEDB(0);                                                    08974000
                                                               <<ld.m4>>08976000
      << set bits off for CS device, special forms >>          <<ld.m4>>08978000
      TOS.(8:2) := 0;                                                   08980000
      DCP(2) := TOS;                                                    08982000
      @DCP := @DCP+LDEV'ENTRYSIZE;                             <<ld.m4>>08984000
      DEV'COUNT := DEV'COUNT+1;                                <<ld.m4>>08986000
      END;                                                              08988000
   << >>                                                                08990000
$PAGE                                                          <<xd.m4>>08992000
   <<------------------------------------------------------->> <<ld.m4>>08994000
   << PUT'CLASS creates a new device class entry in the     >> <<ld.m4>>08996000
   << SPOOK tape directory.  It copies the entire entry for >> <<ld.m4>>08998000
   << that class from the Device Class Table.  The format   >> <<ld.m4>>09000000
   << of the Device Class Entry is:                         >> <<ld.m4>>09002000
   <<                                                       >> <<ld.m4>>09004000
   <<    Word     0:  Device class number (negated).  This  >> <<ld.m4>>09006000
   <<                 is the number of the entry of this    >> <<ld.m4>>09008000
   <<                 device class in the system's DCT.     >> <<ld.m4>>09010000
   <<                                                       >> <<ld.m4>>09012000
   <<    Word     1:  Total number of words in this entry.  >> <<ld.m4>>09014000
   <<                                                       >> <<ld.m4>>09016000
   <<    Words 2 on:  The entire contents of the DCT entry  >> <<ld.m4>>09018000
   <<                 for this device class.                >> <<ld.m4>>09020000
   <<------------------------------------------------------->> <<ld.m4>>09022000
                                                               <<ld.m4>>09024000
    SUBROUTINE PUT'CLASS;                                      <<ld.m4>>09026000
      BEGIN                                                             09028000
      DCP := LDEV;                                             <<ld.m4>>09030000
      @LDT := 0;                                               <<ld.m4>>09032000
      EXCHANGEDB(LDT'DST);                                     <<ld.m4>>09034000
      @DCT := LDT'DCT'BASE;                                    <<ld.m4>>09036000
      WHILE (LDEV:=LDEV+1) < 0 DO                              <<ld.m4>>09038000
         @DCT := @DCT + integer(DCT'NEXT'ENTRY);               <<ld.m4>>09040000
                                                               <<ld.m4>>09042000
      << copy the entire DCT entry onto TOS, starting >>       <<ld.m4>>09044000
      << from the back                                >>       <<ld.m4>>09046000
                                                               <<ld.m4>>09048000
      LIMIT := DCT'NEXT'ENTRY - 1;                             <<ld.m4>>09050000
      IX := LIMIT;                                             <<ld.m4>>09052000
      DO TOS := DCT(IX) UNTIL (IX:=IX-1) < 0;                  <<ld.m4>>09054000
                                                               <<ld.m4>>09056000
      << Now copy DCT entry from stack into DCP, starting   >> <<ld.m4>>09058000
      << at DCP(2).  Comes out in original sequence, as it  >> <<ld.m4>>09060000
      << was put in backwards.  The wonders of stack        >> <<ld.m4>>09062000
      << architecture....                                   >> <<ld.m4>>09064000
                                                               <<ld.m4>>09066000
      EXCHANGEDB(0);                                                    09068000
      IX := 0;                                                          09070000
      DO DCP(IX+2) := TOS UNTIL (IX:=IX+1) > LIMIT;            <<ld.m4>>09072000
      DCP(1) := LIMIT+3;   << total no. of words in entry >>   <<ld.m4>>09074000
                                                               <<ld.m4>>09076000
      << For each ldev in the DCT entry, see if a logical    >><<ld.m4>>09078000
      << device entry already exists in the SPOOK directory  >><<ld.m4>>09080000
      << (by calling GOT'LDCL).  If not, create one by       >><<ld.m4>>09082000
      << calling PUT'LDEV.                                   >><<ld.m4>>09084000
                                                               <<ld.m4>>09086000
      << points to "#devices in class" field in DCT entry >>   <<ld.m4>>09088000
      @DCP'B := @DCP&LSL(1)+DCT'FIRST'LDEV+3;                  <<ld.m4>>09090000
      @DCP := @DCP+LIMIT+3;                                    <<ld.m4>>09092000
      DEV'COUNT := DEV'COUNT+1;                                <<ld.m4>>09094000
      LIMIT := integer(DCP'B); <<no. of devices in DCT entry>> <<ld.m4>>09096000
      IX := 1;                                                          09098000
      DO                                                                09100000
         BEGIN                                                          09102000
         LDEV := integer(DCP'B(IX));                           <<ld.m4>>09104000
         IF NOT GOT'LDCL THEN PUT'LDEV;                        <<ld.m4>>09106000
         END                                                            09108000
      UNTIL (IX:=IX+1) > LIMIT;                                <<ld.m4>>09110000
      END;                                                              09112000
   << >>                                                                09114000
$PAGE                                                          <<xd.m4>>09116000
   << Start of procedure OUTDIRECTORY >>                       <<ld.m4>>09118000
                                                               <<ld.m4>>09120000
<<----------------------------------------------------------->><<ld.m4>>09122000
<< The file directory portion of the SPOOK directory is set  >><<ld.m4>>09124000
<< up here.  It contains one entry for each spoolfile on the >><<ld.m4>>09126000
<< tape.  Each entry is 12 words, and entries are packed into>><<ld.m4>>09128000
<< as many 1020-word records as needed.  The last record will>><<ld.m4>>09130000
<< be padded with zeros if necessary.  The entry format is:  >><<ld.m4>>09132000
<<                                                           >><<ld.m4>>09134000
<<   Word     0: Device file id number (if bit 0 on, output  >><<ld.m4>>09136000
<<                                      spoolfile)           >><<ld.m4>>09138000
<<   Words  1-3: zero                                        >><<ld.m4>>09140000
<<   Words  4-7: User Name                                   >><<ld.m4>>09142000
<<   Words 8-11: Account Name                                >><<ld.m4>>09144000
<<----------------------------------------------------------->><<ld.m4>>09146000
                                                               <<ld.m4>>09148000
   IX := 0;                                                             09150000
   C := 0;                                                              09152000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>09154000
   WHILE (C:=C+1) <= XDDC DO                                            09156000
      BEGIN                                                             09158000
      @XDD'SUBENTRY := @XDD'SUBENTRY-SIZE'OF'XDD'SUBENTRY;     <<xd.m4>>09160000
      IF IX = 0 THEN                                                    09162000
         BEGIN                                                          09164000
         SBUF := 0;                                                     09166000
         MOVE SBUF(1) := SBUF,(1023);                                   09168000
         END;                                                           09170000
      IF XDD'SUBENTRY > 0 THEN                                 <<xd.m4>>09172000
         BEGIN                                                          09174000
                                                               <<xd.m4>>09176000
         << Set up file directory entry:                    >> <<xd.m4>>09178000
         <<   Copy idd'or'odd bit, and device file id number>> <<xd.m4>>09180000
         <<   Move user name and account name               >> <<xd.m4>>09182000
                                                               <<xd.m4>>09184000
         SBUF(IX) := XDDS'DFID'ALL;                            <<xd.m4>>09186000
         MOVE SBUF(IX+4) := XDDS'USER'NAME,(8);                <<xd.m4>>09188000
         IX := IX+FDIR'ENTRYSIZE;                              <<xd.m4>>09190000
         END;                                                           09192000
      IF IX >= FDIR'RECSIZE THEN                               <<xd.m4>>09194000
         BEGIN                                                          09196000
         FWRITE(FILET,SBUF,FDIR'RECSIZE,0);                    <<xd.m4>>09198000
         IF <> THEN GOTO BADWRITE;                             <<ld.m4>>09200000
         IX := 0;                                                       09202000
         END;                                                           09204000
      END;                                                              09206000
   IF IX > 0 THEN                                                       09208000
      BEGIN                                                             09210000
      FWRITE(FILET,SBUF,FDIR'RECSIZE,0);                       <<xd.m4>>09212000
      IF <> THEN GOTO BADWRITE;                                <<ld.m4>>09214000
      END;                                                              09216000
$PAGE                                                          <<xd.m4>>09218000
<<----------------------------------------------------------->><<ld.m4>>09220000
<< The Device and Class Directory is generated here.  It is  >><<ld.m4>>09222000
<< contained in one 1024-word record.  No EOF separates this >><<ld.m4>>09224000
<< record from the File Directory.  It contains one entry for>><<ld.m4>>09226000
<< each logical device or device class linked to the spool-  >><<ld.m4>>09228000
<< files on the tape.  Also, there is an entry for each      >><<ld.m4>>09230000
<< logical device in each class in the directory, whether or >><<ld.m4>>09232000
<< not that ldev was directly referenced by a spoolfile.     >><<ld.m4>>09234000
<< Entries are packed into the tape record one after another >><<ld.m4>>09236000
<< in no particular order.                                   >><<ld.m4>>09238000
<<----------------------------------------------------------->><<ld.m4>>09240000
                                                               <<ld.m4>>09242000
   C := 0;                                                              09244000
   DEV'COUNT := 0;                                             <<ld.m4>>09246000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>09248000
   @DCP := INITXDDP;                                                    09250000
   WHILE (C:=C+1) <= XDDC DO                                            09252000
      BEGIN                                                             09254000
      @XDD'SUBENTRY := @XDD'SUBENTRY-SIZE'OF'XDD'SUBENTRY;     <<xd.m4>>09256000
      IF XDD'SUBENTRY > 0 THEN                                 <<xd.m4>>09258000
         BEGIN                                                          09260000
         LDEV := XDDS'DEVICE;                                  <<xd.m4>>09262000
         IF XDDS'CLASS=1 THEN LDEV := -LDEV;                   <<xd.m4>>09264000
         IF NOT GOT'LDCL THEN  << entry not already there >>   <<xd.m4>>09266000
            IF LDEV > 0 THEN PUT'LDEV                          <<ld.m4>>09268000
                        ELSE PUT'CLASS;                        <<ld.m4>>09270000
         END;                                                           09272000
      END;                                                              09274000
   DCP := 0;                                                            09276000
   LIMIT := @DCP-INITXDDP+1;                                   <<ld.m4>>09278000
   @DCP := INITXDDP;                                                    09280000
   FWRITE(FILET,DCP,1024,0);                                            09282000
   IF <> THEN GOTO BADWRITE;                                   <<ld.m4>>09284000
   IF LIMIT > 1024 THEN                                        <<ld.m4>>09286000
      BEGIN                                                             09288000
      FWRITE(FILET,DCP(1024),1024,0);                                   09290000
      IF <> THEN GOTO BADWRITE;                                <<ld.m4>>09292000
      END;                                                              09294000
   FCONTROL(FILET,6,P);     << write EOF >>                    <<xd.m4>>09296000
   IF <> THEN GOTO BADWRITE;                                   <<ld.m4>>09298000
   OUTDIRECTORY := TRUE;                                                09300000
   GOTO QUICKOUT;                                              <<ld.m4>>09302000
BADWRITE:                                                      <<ld.m4>>09304000
   ERRN := 55;    << tape file write error >>                  <<ld.m4>>09306000
   FCLOSE(FILET,1,0);                                          <<02724>>09308000
   FILET := 0;                                                          09310000
QUICKOUT:                                                      <<ld.m4>>09312000
   END;                                                                 09314000
$PAGE "* * * VERIFY'BLOCK'STRUCTURE * * *"                     <<xd.m4>>09316000
$CONTROL SEGMENT=SPOOK3                                       <<<01549>>09318000
                                                              <<<01549>>09320000
<<---------------------------------------------------------->> <<xd.m4>>09322000
<< VERIFY'BLOCK'STRUCTURE check to see that the variable-   >> <<xd.m4>>09324000
<< length records in a spool file block are laid out pro-   >> <<xd.m4>>09326000
<< perly.  It counts the number of words in each record, and>> <<xd.m4>>09328000
<< verifies that the end of the data in the block does not  >> <<xd.m4>>09330000
<< extend into the count information (words 510-511).       >> <<xd.m4>>09332000
<<---------------------------------------------------------->> <<xd.m4>>09334000
                                                               <<xd.m4>>09336000
LOGICAL PROCEDURE VERIFY'BLOCK'STRUCTURE(BUFFER,INDEX,NUMRECS);<<01726>>09338000
                                                              <<SP.MP4>>09340000
   LOGICAL ARRAY BUFFER;                                      <<SP.MP4>>09342000
   INTEGER INDEX,NUMRECS;                                     <<SP.MP4>>09344000
                                                              <<SP.MP4>>09346000
   BEGIN                                                      <<<01549>>09348000
                                                              <<<01549>>09350000
      INTEGER SCOUNT := 0;                                    <<<01549>>09352000
      INTEGER REC'LEN;                                         <<xd.m4>>09354000
      EQUATE END'OF'DATA = 509;                               <<<01549>>09356000
                                                              <<<01549>>09358000
      VERIFY'BLOCK'STRUCTURE := TRUE;                         <<<01549>>09360000
      NUMRECS := 0; <<NUMBER OF RECORDS IN BLOCK>>             <<01726>>09362000
      DO                                                      <<<01549>>09364000
      BEGIN                                                   <<<01549>>09366000
         REC'LEN := BUFFER(SCOUNT);                           <<<01549>>09368000
         INDEX := SCOUNT;                                     <<<01549>>09370000
         SCOUNT := SCOUNT + (REC'LEN + 3)&ASR(1);             <<<01549>>09372000
         NUMRECS := NUMRECS + 1;                               <<01726>>09374000
      END                                                     <<<01549>>09376000
      UNTIL (SCOUNT > END'OF'DATA) OR                         <<<01549>>09378000
         (INTEGER(BUFFER(SCOUNT)) = -1);                      <<<01549>>09380000
      IF SCOUNT > END'OF'DATA THEN                            <<<01549>>09382000
         VERIFY'BLOCK'STRUCTURE := FALSE;                     <<<01549>>09384000
   END; <<VERIFY'BLOCK'STRUCTURE>>                            <<<01549>>09386000
$PAGE "* * * REWRITE'BLOCK * * *"                              <<xd.m4>>09388000
                                                              <<<01549>>09390000
$CONTROL SEGMENT=SPOOK3                                       <<<01549>>09392000
                                                              <<<01549>>09394000
LOGICAL PROCEDURE REWRITE'BLOCK(FILENUM,BUFFER,INDEX);        <<<01549>>09396000
                                                              <<<01549>>09398000
   VALUE FILENUM;                                             <<<01549>>09400000
   LOGICAL ARRAY BUFFER;                                      <<<01549>>09402000
   INTEGER INDEX,FILENUM;                                     <<<01549>>09404000
                                                              <<<01549>>09406000
   BEGIN                                                      <<<01549>>09408000
                                                              <<<01549>>09410000
      LOGICAL I,J,K;                                          <<<01549>>09412000
                                                              <<<01549>>09414000
      REWRITE'BLOCK := TRUE;                                  <<<01549>>09416000
      I := BUFFER(INDEX);                                     <<<01549>>09418000
      BUFFER(INDEX) := -1;  <<END OF BLOCK>>                  <<<01549>>09420000
      J := BUFFER(510); <<STORE LAST 2 WORDS BEFORE>>         <<<01549>>09422000
      K := BUFFER(511); <<FILE SYS OVERLAYS WITH >>           <<<01549>>09424000
                        <<RECORD COUNT>>                      <<<01549>>09426000
                                                              <<<01549>>09428000
      FWRITE(FILENUM,BUFFER,512,0); <<WRITE BUFFER UP TO>>    <<<01549>>09430000
       IF <> THEN REWRITE'BLOCK := FALSE;                     <<<01549>>09432000
                                    <<LAST RECORD THAT FITS>> <<<01549>>09434000
      BUFFER(INDEX) := I;                                     <<<01549>>09436000
      BUFFER(510) := J;                                       <<<01549>>09438000
      BUFFER(511) := K;                                       <<<01549>>09440000
                                                              <<<01549>>09442000
      MOVE BUFFER := BUFFER(INDEX), (512-INDEX);              <<<01549>>09444000
   END;  <<REWRITE'BLOCK>>                                    <<<01549>>09446000
$PAGE "* * * INFILES * * *"                                    <<xd.m4>>09448000
$CONTROL SEGMENT=SPOOK3                                                 09450000
                                                                        09452000
<<---------------------------------------------------------->> <<xd.m4>>09454000
<< Procedure INFILES reads in the specified files from the  >> <<xd.m4>>09456000
<< input SPOOK tape.  For each file, a new spoolfile is     >> <<xd.m4>>09458000
<< created and an ODD entry is linked into the table.       >> <<xd.m4>>09460000
<<---------------------------------------------------------->> <<xd.m4>>09462000
                                                               <<xd.m4>>09464000
LOGICAL PROCEDURE INFILES;                                              09466000
   BEGIN                                                                09468000
   INTEGER C,I,P,D,N,M,DFID;                                   <<xd.m4>>09470000
   INTEGER LDEV,NER,FER,CNTX;                                  <<xd.m4>>09472000
   LOGICAL DELETE,FILE'END,MATCH,GOT,GOTX;                     <<xd.m4>>09474000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>09476000
   INTEGER POINTER XDDSUBP;                                             09478000
   DOUBLE POINTER XDD'DSUBENTRY = XDD'SUBENTRY;                <<xd.m4>>09480000
   INTEGER POINTER DCP;                                                 09482000
   INTEGER INDEX,NUMRECS;                                      <<xd.m4>>09484000
   LOGICAL DONE;                                               <<xd.m4>>09486000
   INTEGER NUMSPULABS,J;                                       <<01886>>09488000
   LOGICAL PAST'ULABS;                                         <<01886>>09490000
   << >>                                                                09492000
$PAGE                                                          <<infil>>09494000
   SUBROUTINE DEF'MOVEFROMDSEG;                                <<xd.m4>>09496000
   SUBROUTINE NEXTREEL;                                                 09498000
      BEGIN                                                             09500000
      REEL := REEL+1;                                                   09502000
      L0REEL := REEL;                                          <<xd.m4>>09504000
      I := PRINTOPREPLY(MREEL,17,0,RBUF,-1);                            09506000
      IF BRBUF = "N" THEN GOTO MRABORT;                        <<xd.m4>>09508000
   RL:                                                                  09510000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 09512000
      IF < THEN GOTO BADREAD;                                  <<xd.m4>>09514000
      IF > OR TCOUNT<>40 OR BTBUF<>BSBUF,(80) THEN                      09516000
         BEGIN                                                          09518000
         FCONTROL(FILET,9,P);                                           09520000
         IF <> THEN GOTO BADREAD;                              <<xd.m4>>09522000
         I := PRINTOPREPLY(EREEL,18,0,RBUF,-1);                         09524000
         IF BRBUF = "N" THEN GOTO MRABORT;                     <<xd.m4>>09526000
         GOTO RL;                                                       09528000
         END;                                                           09530000
      FREAD(FILET,SBUF,1024);                                           09532000
      IF <= THEN GOTO BADFMT;                                  <<xd.m4>>09534000
      END;                                                              09536000
$PAGE                                                          <<xd.m4>>09538000
   << >>                                                                09540000
<<---------------------------------------------------------->> <<xd.m4>>09542000
<< Subroutine READTAPE does the actual reading of the tape  >> <<xd.m4>>09544000
<< into buffer SBUF.  If READ1ST is true, a 1024-word record>> <<xd.m4>>09546000
<< is read.  If it's false, we skip to the end of the cur-  >> <<xd.m4>>09548000
<< rent file before reading.  If a trailer label is encoun- >> <<xd.m4>>09550000
<< tered, NEXTREEL is called to do a reelswitch.            >> <<xd.m4>>09552000
<<---------------------------------------------------------->> <<xd.m4>>09554000
                                                               <<xd.m4>>09556000
   SUBROUTINE READTAPE(READ1ST);                               <<xd.m4>>09558000
      VALUE READ1ST;                                           <<xd.m4>>09560000
      LOGICAL READ1ST;                                         <<xd.m4>>09562000
                                                               <<xd.m4>>09564000
      BEGIN                                                             09566000
      IF LASTREEL THEN GOTO BADFMT;                            <<xd.m4>>09568000
   DO                                                          <<xd.m4>>09570000
   BEGIN                                                       <<xd.m4>>09572000
      DONE := TRUE;                                            <<xd.m4>>09574000
      IF READ1ST THEN                                          <<xd.m4>>09576000
         BEGIN                                                          09578000
         IF GOTX THEN                                                   09580000
            << we did a previous read to fill up the buffer >> <<xd.m4>>09582000
            << just retrieve saved byte/word count          >> <<xd.m4>>09584000
            BEGIN                                                       09586000
            GOTX := FALSE;                                              09588000
            TCOUNT := CNTX;                                             09590000
            GOTO OUT;                                          <<xd.m4>>09592000
            END;                                                        09594000
         TCOUNT := FREAD(FILET,SBUF,1024);                              09596000
         IF < THEN GOTO BADREAD;                               <<xd.m4>>09598000
         IF = THEN GOTO OUT;  << still reading in mid-file >>  <<xd.m4>>09600000
         END                                                            09602000
      ELSE   << skip to end of this file >>                    <<xd.m4>>09604000
         BEGIN                                                          09606000
         GOTX := FALSE;                                                 09608000
         FCONTROL(FILET,7,P);   << forward to tape mark >>     <<xd.m4>>09610000
         IF <> THEN GOTO BADREAD;                              <<xd.m4>>09612000
         END;                                                           09614000
                                                               <<xd.m4>>09616000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 09618000
      IF <> THEN GOTO BADREAD;                                 <<xd.m4>>09620000
      IF TCOUNT <> 40 THEN  << reading next file >>            <<xd.m4>>09622000
         BEGIN                                                          09624000
         FILEEND := TRUE;                                               09626000
         GOTX := TRUE;                                                  09628000
         CNTX := TCOUNT;                                                09630000
         END                                                            09632000
      ELSE    << at trailer label >>                           <<xd.m4>>09634000
         BEGIN                                                          09636000
         FILEEND := (SBUF(21) = 1);                                     09638000
         LASTREEL := (SBUF(22) = 1);                                    09640000
         FCONTROL(FILET,9,P);   << rewind/offline >>           <<xd.m4>>09642000
         IF <> THEN GOTO BADREAD;                              <<xd.m4>>09644000
         IF NOT LASTREEL THEN                                           09646000
            BEGIN                                                       09648000
            NEXTREEL;                                                   09650000
            IF NOT FILEEND THEN DONE := FALSE;                 <<xd.m4>>09652000
            END;                                                        09654000
         END;                                                           09656000
   END                                                         <<xd.m4>>09658000
   UNTIL DONE;                                                 <<xd.m4>>09660000
      TCOUNT := 0;                                                      09662000
OUT:                                                           <<xd.m4>>09664000
      END;                                                              09666000
   << >>                                                                09668000
   SUBROUTINE ERRORSET;                                                 09670000
      BEGIN                                                             09672000
      DELETE := TRUE;                                          <<xd.m4>>09674000
      XDDS'SPOOK'ERR := NER;                                   <<xd.m4>>09676000
      XDDS'FILESYS'ERR := FER;                                 <<xd.m4>>09678000
      READTAPE(FALSE);                                                  09680000
      FILE'END := TRUE;                                        <<xd.m4>>09682000
      END;                                                              09684000
   << >>                                                                09686000
   SUBROUTINE ERRORFILE(A);                                             09688000
      VALUE   A;                                                        09690000
      INTEGER A;                                                        09692000
      BEGIN                                                             09694000
      NER := A;                                                         09696000
      FCHECK(FILEF,FER);                                                09698000
            ERRF := FER;                                       <<01326>>09700000
      ERRORSET;                                                         09702000
      END;                                                              09704000
   << >>                                                                09706000
   SUBROUTINE ERRORIN;                                                  09708000
      BEGIN                                                             09710000
      NER := SBUF;                                                      09712000
      FER := SBUF(1);                                                   09714000
      ERRORSET;                                                         09716000
      END;                                                              09718000
   << >>                                                                09720000
$PAGE                                                          <<xd.m4>>09722000
<<---------------------------------------------------------->> <<xd.m4>>09724000
<< Subroutine OPEN'NEWSP first takes the XDD subentry image >> <<xd.m4>>09726000
<< from the spoolfile being input from tape and modifies    >> <<xd.m4>>09728000
<< several fields.  It then checks to make sure that a ldev >> <<xd.m4>>09730000
<< approximately similar to the one the spoolfile was       >> <<xd.m4>>09732000
<< created on was found on the host system.  SPUTXDD is then>> <<xd.m4>>09734000
<< called to link the new XDD subentry into the appropriate >> <<xd.m4>>09736000
<< device or class chain.  The new spoolfile is then opened.>> <<xd.m4>>09738000
<<---------------------------------------------------------->> <<xd.m4>>09740000
                                                               <<xd.m4>>09742000
   SUBROUTINE OPEN'NEWSP;                                      <<xd.m4>>09744000
      BEGIN                                                             09746000
      << If the system the SPOOK tape was created on and the>> <<xd.m4>>09748000
      << one it is being input to are running on different  >> <<xd.m4>>09750000
      << versions of MPE, the XDD image must be converted.  >> <<xd.m4>>09752000
                                                               <<xd.m4>>09754000
      IF MPE5TAPE THEN                                         <<xd.m4>>09756000
         BEGIN                                                 <<xd.m4>>09758000
         MOVE XDD'SUBENTRY := SBUF, (19);                      <<xd.m4>>09760000
         XDDS'COPY'INFO := SBUF(26);                           <<xd.m4>>09762000
         XDDS'SHOW'ERRS := SBUF(27);                           <<xd.m4>>09764000
         TOS := SBUF(30);                                      <<xd.m4>>09766000
         TOS := SBUF(31);                                      <<xd.m4>>09768000
         XDDSD'READY'TIME := TOS;                              <<xd.m4>>09770000
         LDEV := SBUF(20);                                     <<xd.m4>>09772000
         END                                                   <<xd.m4>>09774000
      ELSE    << system versions match >>                      <<xd.m4>>09776000
         BEGIN                                                 <<xd.m4>>09778000
         MOVE XDD'SUBENTRY := SBUF, (SIZE'OF'XDD'SUBENTRY);    <<xd.m4>>09780000
         LDEV := XDDS'DEVICE;                                  <<xd.m4>>09782000
         END;                                                  <<xd.m4>>09784000
                                                               <<xd.m4>>09786000
      DFID := XDDS'DFID'ALL;                                   <<xd.m4>>09788000
      IF XDDS'JOB'TYPE > 1 THEN                                <<xd.m4>>09790000
         XDDS'JOB'TYPE := XDDS'JOB'                            <<xd.m4>>09792000
      ELSE                                                     <<xd.m4>>09794000
         XDDS'JOB'TYPE := XDDS'SESSION';                       <<xd.m4>>09796000
      XDDSD'DISC'LABEL := 0D;                                  <<xd.m4>>09798000
      XDDS'NUMBER'EXTENTS := 0;                                <<xd.m4>>09800000
      XDDS'VIRTUAL'LDEV := 0;                                  <<xd.m4>>09802000
      XDDS'LAST'EXTENT'SIZE := 0;                              <<xd.m4>>09804000
      XDDSD'RECORD'COUNT := 0D;                                <<xd.m4>>09806000
      IF XDDS'CLASS THEN LDEV := -LDEV;                        <<xd.m4>>09808000
      @DCP := INITXDDP;                                                 09810000
      I := 0;                                                  <<xd.m4>>09812000
      WHILE DCP <> 0 AND DCP <> LDEV DO                        <<xd.m4>>09814000
         BEGIN                                                 <<xd.m4>>09816000
         IF DCP > 0 THEN                                       <<xd.m4>>09818000
            @DCP := @DCP + LDEV'ENTRYSIZE                      <<xd.m4>>09820000
         ELSE                                                  <<xd.m4>>09822000
            @DCP := @DCP + DCP(1);                             <<xd.m4>>09824000
         I := I+1;                                             <<xd.m4>>09826000
         END;                                                  <<xd.m4>>09828000
      LDEV := NEWLDEVS(I);                                     <<xd.m4>>09830000
      IF DCP = 0 OR LDEV = 0 THEN                              <<xd.m4>>09832000
         BEGIN                                                          09834000
         NER := IF DCP >= 0 THEN 57  << no equiv device >>     <<xd.m4>>09836000
                            ELSE 58; << no equiv class >>      <<xd.m4>>09838000
         ERRORSET;                                                      09840000
         END                                                            09842000
      ELSE                                                              09844000
         BEGIN                                                          09846000
         XDD'SUBENTRY.(2:1) := 0; << 2nd bit of spool state >> <<xd.m4>>09848000
         XDDS'DEVICE := LDEV;                                  <<xd.m4>>09850000
         XDDS'CLASS := IF DCP < 0 THEN 1 ELSE 0;               <<xd.m4>>09852000
         IF DCP < 0 THEN LDEV := -LDEV;                        <<xd.m4>>09854000
         IF SPUTXDD(1,LDEV,XDD'SUBENTRY,XDDSUBP) <> 0 THEN     <<xd.m4>>09856000
            BEGIN                                              <<xd.m4>>09858000
            NER := 59;    << no room in device table >>        <<xd.m4>>09860000
            ERRORSET;                                          <<xd.m4>>09862000
            END                                                <<xd.m4>>09864000
         ELSE                                                  <<xd.m4>>09866000
            BEGIN                                              <<xd.m4>>09868000
            FILEF := FSOPEN(,%304,%501,@XDDSUBP);              <<xd.m4>>09870000
            IF < THEN                                          <<xd.m4>>09872000
               BEGIN                                           <<xd.m4>>09874000
               ERRORFILE(29);                                  <<xd.m4>>09876000
               SREMOVEXDD(XDDSUBP);                            <<xd.m4>>09878000
               FILEF := 0;                                     <<xd.m4>>09880000
               END                                             <<xd.m4>>09882000
            ELSE    << spoofle opened OK >>                    <<xd.m4>>09884000
               BEGIN                                           <<xd.m4>>09886000
               MOVEFROMDSEG(@XDD'SUBENTRY, ODD'DST,            <<xd.m4>>09888000
                            @XDDSUBP.IDNUM,                    <<xd.m4>>09890000
                            SIZE'OF'XDD'SUBENTRY);             <<xd.m4>>09892000
               XDDS'SHOW'ERRS := 0;                            <<xd.m4>>09894000
               END;                                            <<xd.m4>>09896000
            END;                                               <<xd.m4>>09898000
         END;                                                  <<xd.m4>>09900000
      END;                                                     <<xd.m4>>09902000
                                                               <<xd.m4>>09904000
$PAGE                                                          <<infil>>09906000
   << >>                                                                09908000
                                                               <<01886>>09910000
   SUBROUTINE READUSERLABELS;                                  <<01886>>09912000
      BEGIN                                                    <<01886>>09914000
         PAST'ULABS := FALSE;                                  <<01886>>09916000
         READTAPE(TRUE);                                       <<01886>>09918000
         IF SBUF(2) = 3 <<FOPEN>> AND SBUF(4) <> 0 <<NUMULABS>><<01930>>09920000
            AND SBUF((SBUF+3)&ASR(1)) = -1 <<END OF BLOCK>>    <<01930>>09922000
            THEN                                               <<01930>>09924000
         BEGIN <<THERE ARE USERLABELS>>                        <<01886>>09926000
            NUMSPULABS := SBUF(4);                             <<01930>>09928000
           J := 1;                                             <<01930>>09930000
            DO                                                 <<01886>>09932000
            BEGIN                                              <<01886>>09934000
               TCOUNT := FREAD(FILET,SBUF,1024);               <<01930>>09936000
               IF < THEN GOTO BADREAD;                         <<xd.m4>>09938000
               FWRITELABEL(FILEF,SBUF(128),,J-1);              <<01930>>09940000
               IF J < NUMSPULABS - 1 THEN                      <<01930>>09942000
               FWRITELABEL(FILEF,SBUF(128*2),,J);              <<01930>>09944000
               IF J+1 < NUMSPULABS - 1 THEN                    <<01930>>09946000
               FWRITELABEL(FILEF,SBUF(128*3),,J+1);            <<01930>>09948000
               IF J+2 < NUMSPULABS - 1 THEN                    <<01930>>09950000
               FWRITELABEL(FILEF,SBUF(512+128),,J+2);          <<01930>>09952000
               IF J+3 < NUMSPULABS - 1 THEN                    <<01930>>09954000
               FWRITELABEL(FILEF,SBUF(512+(128*2)),,J+3);      <<01930>>09956000
               IF J+4 < NUMSPULABS - 1 THEN                    <<01930>>09958000
               FWRITELABEL(FILEF,SBUF(512+(128*3)),,J+4);      <<01930>>09960000
            END                                                <<01930>>09962000
            UNTIL (J := J + 6) > NUMSPULABS;                   <<01930>>09964000
         END                                                   <<01886>>09966000
         ELSE                                                  <<01886>>09968000
             PAST'ULABS := TRUE;                               <<01886>>09970000
       END; <<SUBROUTINE READUSERLABELS>>                      <<01886>>09972000
$PAGE                                                          <<xd.m4>>09974000
<<>>                                                           <<01886>>09976000
<< procedure INFILES starts here >>                            <<xd.m4>>09978000
                                                               <<01886>>09980000
   C := 0;                                                              09982000
   GOTX := FALSE;                                                       09984000
   GOT := FALSE;                                                        09986000
   FILEF := 0;                                                          09988000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>09990000
   PRINT(MIN,23,0);                                                     09992000
                                                               <<infil>>09994000
   << if FILE'MATCH is true, then there is at least one     >> <<infil>>09996000
   << spoolfile on this tape that we want.  Otherwise, we   >> <<infil>>09998000
   << skip scanning through this entire tape.               >> <<infil>>10000000
                                                               <<infil>>10002000
   IF FILE'MATCH THEN                                          <<infil>>10004000
   WHILE (C:=C+1) <= XDDC DO                                            10006000
      BEGIN                                                             10008000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>10010000
      CRITFLAG := TRUE;                                        <<B0.00>>10012000
                                                               <<xd.m4>>10014000
      <<---------------------------------------------------->> <<xd.m4>>10016000
      << We're not actually accessing a XDD subentry here,  >> <<xd.m4>>10018000
      << but the file directory entry placed in the DB-     >> <<xd.m4>>10020000
      << area by procedure INFILES.  It serves as a place-  >> <<xd.m4>>10022000
      << holder for the real thing which is generated in    >> <<xd.m4>>10024000
      << OPEN'NEWSP.  Forgive me for calling it XDD'SUBENTRY>> <<xd.m4>>10026000
      << but it does refer to the same location in memory...>> <<xd.m4>>10028000
      <<---------------------------------------------------->> <<xd.m4>>10030000
                                                               <<xd.m4>>10032000
      @XDD'SUBENTRY := @XDD'SUBENTRY-SIZE'OF'XDD'SUBENTRY;     <<xd.m4>>10034000
      FILE'END := FALSE;                                       <<xd.m4>>10036000
      DELETE := FALSE;                                         <<xd.m4>>10038000
      NER := 0;                                                         10040000
      FER := 0;                                                         10042000
      FILEEND := FALSE;                                                 10044000
      IF DEVFC <> 0 THEN                                                10046000
         BEGIN                                                          10048000
         MATCH := FALSE;                                       <<xd.m4>>10050000
         IF NOT GOT THEN                                                10052000
            BEGIN                                                       10054000
            D := -1;                                                    10056000
            GOT := TRUE;                                                10058000
                                                               <<xd.m4>>10060000
            << Look at the device file id in the file direc->> <<xd.m4>>10062000
            << tory entry to see if it matches any of the   >> <<xd.m4>>10064000
            << dfid's we asked to be input.                 >> <<xd.m4>>10066000
                                                               <<xd.m4>>10068000
            WHILE (D:=D+1) < DEVFC DO                                   10070000
               IF DEVFS(D) <> 0 THEN                                    10072000
                  BEGIN                                                 10074000
                  GOT := FALSE;                                         10076000
                  IF XDD'SUBENTRY = DEVFS(D) THEN              <<xd.m4>>10078000
                     BEGIN                                              10080000
                     MATCH := TRUE;                            <<xd.m4>>10082000
                     DEVFS(D) := 0;                                     10084000
                     END;                                               10086000
                  END;                                                  10088000
            END;                                                        10090000
         END                                                            10092000
      ELSE                                                              10094000
         BEGIN                                                          10096000
         MATCH := TRUE;                                        <<xd.m4>>10098000
         N := IF USERF THEN -1 ELSE 3;                                  10100000
         M := IF ACCTF THEN 8 ELSE 4;                          <<xd.m4>>10102000
         WHILE (N:=N+1) < M DO                                 <<xd.m4>>10104000
            IF XDD'SUBENTRY(4+N) <> SNAMES(N) THEN             <<xd.m4>>10106000
               MATCH := FALSE;                                 <<xd.m4>>10108000
         END;                                                           10110000
                                                               <<xd.m4>>10112000
      IF NOT MATCH THEN                                        <<xd.m4>>10114000
         BEGIN                                                          10116000
         XDD'SUBENTRY := 0;                                    <<xd.m4>>10118000
         IF NOT GOT THEN READTAPE(FALSE);                               10120000
         END                                                            10122000
      ELSE                                                              10124000
         << read ODD entry which precedes spoolfile blocks >>  <<xd.m4>>10126000
         << 30 words if MPE4 tape, 32 words if MPE5 tape   >>  <<xd.m4>>10128000
         BEGIN                                                 <<xd.m4>>10130000
         READTAPE(TRUE);                                       <<xd.m4>>10132000
         IF TCOUNT = 0 THEN GOTO BADFMT                        <<xd.m4>>10134000
         ELSE                                                  <<xd.m4>>10136000
            IF TCOUNT = 20 THEN ERRORIN                        <<xd.m4>>10138000
            ELSE                                               <<xd.m4>>10140000
               IF (MPE5TAPE LAND TCOUNT=32) OR                 <<xd.m4>>10142000
                  (NOT MPE5TAPE LAND TCOUNT=30) THEN           <<xd.m4>>10144000
                     BEGIN                                     <<xd.m4>>10146000
                     OPEN'NEWSP;                               <<xd.m4>>10148000
                     IF NOT FILE'END THEN << no error found >> <<xd.m4>>10150000
                        READUSERLABELS;                        <<xd.m4>>10152000
                     END                                       <<xd.m4>>10154000
                     ELSE GOTO BADFMT;                         <<xd.m4>>10156000
                                                               <<xd.m4>>10158000
         << Read spoolfile blocks at this point >>             <<xd.m4>>10160000
         WHILE NOT FILE'END DO                                 <<xd.m4>>10162000
            BEGIN                                              <<01886>>10164000
            IF NOT PAST'ULABS THEN                             <<01886>>10166000
            READTAPE(TRUE);                                             10168000
            PAST'ULABS := FALSE;                               <<01886>>10170000
            IF TCOUNT = 0 THEN                                          10172000
               FILE'END := TRUE                                <<xd.m4>>10174000
            ELSE                                                        10176000
                    BEGIN                                               10178000
                    IF TCOUNT = 20 THEN ERRORIN                <<xd.m4>>10180000
                    ELSE                                       <<xd.m4>>10182000
                    IF TCOUNT = 512 OR TCOUNT = 1024 THEN               10184000
                       BEGIN                                            10186000
                       IF NOT VERIFY'BLOCK'STRUCTURE(SBUF,    <<<01549>>10188000
                            INDEX,NUMRECS) THEN                <<01726>>10190000
                         IF NOT REWRITE'BLOCK(FILEF,SBUF,     <<<01549>>10192000
                            INDEX) THEN                       <<<01549>>10194000
                            ERRORFILE(27);                    <<<01549>>10196000
                       FWRITE(FILEF,SBUF,512,0);              <<<01549>>10198000
                       IF <> THEN                                       10200000
                          ERRORFILE(27)                                 10202000
                       ELSE                                             10204000
                          IF TCOUNT = 1024 THEN                         10206000
                             BEGIN                                      10208000
                    IF NOT VERIFY'BLOCK'STRUCTURE(SBUF(512),  <<<01549>>10210000
                            INDEX,NUMRECS) THEN                <<01726>>10212000
                         IF NOT REWRITE'BLOCK(FILEF,SBUF(512),<<<01549>>10214000
                            INDEX) THEN                       <<<01549>>10216000
                            ERRORFILE(27);                    <<<01549>>10218000
                             FWRITE(FILEF,SBUF(512),512,0);   <<<01549>>10220000
                             IF <> THEN ERRORFILE(27);                  10222000
                             END;                                       10224000
                       END                                     <<xd.m4>>10226000
                    ELSE GOTO BADFMT;                          <<xd.m4>>10228000
                    END;                                                10230000
            END;     << while not file'end >>                  <<xd.m4>>10232000
         IF FILEF <> 0 THEN                                             10234000
            BEGIN                                                       10236000
            FSCLOSE(FILEF,IF DELETE THEN 4 ELSE 0,0);          <<xd.m4>>10238000
            IF < THEN ERRORFILE(25);                                    10240000
            FILEF := 0;                                                 10242000
            END;                                                        10244000
         IF NOT DELETE THEN                                    <<xd.m4>>10246000
            BEGIN                                                       10248000
            MOVE XDDBUF := XDD'SUBENTRY,(SIZE'OF'XDD'SUBENTRY);<<xd.m4>>10250000
            SHOWXDD(%10,DFID);                                 <<xd.m4>>10252000
            END;                                                        10254000
         END;                                                           10256000
      END;   << while C <= XDDC >>                             <<xd.m4>>10258000
   INFILES := TRUE;                                                     10260000
   GOTO LX;                                                             10262000
MRABORT:                                                       <<xd.m4>>10264000
   ERRN := 60;     << multi-reel abort >>                      <<ld.m4>>10266000
   GOTO LYZ;                                                            10268000
BADFMT:                                                        <<xd.m4>>10270000
   ERRN := 53;     << invalid tape format >>                   <<ld.m4>>10272000
   GOTO LYZ;                                                            10274000
BADREAD:                                                       <<xd.m4>>10276000
   ERRN := 54;     << tape file read error >>                  <<ld.m4>>10278000
LYZ:                                                                    10280000
   IF FILEF <> 0 THEN FSCLOSE(FILEF,4,0);                               10282000
   FCLOSE(FILET,1,0);                                          <<02724>>10284000
   FILET := 0;                                                          10286000
LX:                                                                     10288000
   END;                                                                 10290000
$PAGE "* * * OUTFILES * * *"                                   <<xd.m4>>10292000
$CONTROL SEGMENT=SPOOK3                                                 10294000
                                                                        10296000
LOGICAL PROCEDURE OUTFILES;                                             10298000
   BEGIN                                                                10300000
   INTEGER C,P,I;                                                       10302000
   INTEGER NER,FER;                                                     10304000
   INTEGER NUMSPULABS,J;                                       <<01886>>10306000
   INTEGER SAVE'XDDS'ADDR;                                     <<xd.m4>>10308000
   LOGICAL STOP'WRITE;                                         <<xd.m4>>10310000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>10312000
   << >>                                                                10314000
   <<------------------------------------------------------->> <<xd.m4>>10316000
   << WRITETAPE performs the actual FWRITE's to the output  >> <<xd.m4>>10318000
   << spook tape.                                           >> <<xd.m4>>10320000
   <<    If COUNT=0, an EOF mark is written.                >> <<xd.m4>>10322000
   <<    If COUNT<> 0, that many words/bytes is written out >> <<xd.m4>>10324000
   <<                  to tape.                             >> <<xd.m4>>10326000
   <<------------------------------------------------------->> <<xd.m4>>10328000
                                                               <<xd.m4>>10330000
   LOGICAL SUBROUTINE WRITETAPE(ADDR,COUNT);                            10332000
      VALUE   COUNT;                                                    10334000
      INTEGER COUNT;                                                    10336000
      ARRAY   ADDR;                                                     10338000
      BEGIN                                                             10340000
      WRITETAPE := TRUE;                                                10342000
      IF COUNT <> 0 THEN FWRITE(FILET,ADDR,COUNT,0)                     10344000
                    ELSE FCONTROL(FILET,6,P);                           10346000
      IF <> THEN                                                        10348000
         << check if at end of tape >>                         <<xd.m4>>10350000
         BEGIN                                                          10352000
         FCHECK(FILET,P);                                               10354000
         IF P = 23 THEN EOTMARK := TRUE                                 10356000
                   ELSE WRITETAPE := FALSE;                             10358000
         END;                                                           10360000
      END;                                                              10362000
   << >>                                                                10364000
   SUBROUTINE NEXTREEL;                                                 10366000
      BEGIN                                                             10368000
      IF EOTMARK OR LASTREEL THEN                                       10370000
         BEGIN                                                          10372000
         IF NOT FILEEND THEN                                            10374000
            IF NOT WRITETAPE(SBUF,0) THEN GOTO BADWRITE;       <<xd.m4>>10376000
         L0EOF := IF FILEEND THEN 1 ELSE 0;                    <<xd.m4>>10378000
         L0LASTREEL := IF LASTREEL THEN 1 ELSE 0;              <<xd.m4>>10380000
         IF NOT WRITETAPE(TBUF,40) THEN GOTO BADWRITE;         <<xd.m4>>10382000
         I := -1;                                                       10384000
         WHILE (I:=I+1) <= 3 DO                                         10386000
            IF NOT WRITETAPE(SBUF,0) THEN GOTO BADWRITE;       <<xd.m4>>10388000
         IF NOT LASTREEL THEN   << switch reels >>             <<xd.m4>>10390000
            BEGIN                                                       10392000
            FCONTROL(FILET,9,P);  << rewind/offline >>         <<xd.m4>>10394000
            IF <> THEN GOTO BADWRITE;                          <<xd.m4>>10396000
            REEL := REEL+1;                                             10398000
            I := PRINTOPREPLY(MREEL,17,0,RBUF,-1);                      10400000
            IF BRBUF = "N" THEN GOTO MRABORT;                  <<xd.m4>>10402000
            EOTMARK := FALSE;                                           10404000
            L0EOF := 0;                                        <<xd.m4>>10406000
            L0LASTREEL := 0;                                   <<xd.m4>>10408000
            L0REEL := REEL;                                    <<xd.m4>>10410000
            IF NOT WRITETAPE(TBUF,40) THEN GOTO BADWRITE;      <<xd.m4>>10412000
            IF NOT WRITETAPE(SBUF,0) THEN GOTO BADWRITE;       <<xd.m4>>10414000
            END;                                                        10416000
         END;                                                           10418000
      END;                                                              10420000
   << >>                                                                10422000
   <<------------------------------------------------------->> <<xd.m4>>10424000
   << ERROROUT saves errors in SBUF(0) and (1) for procedure>> <<xd.m4>>10426000
   << INFILES to recover when inputting these files.        >> <<xd.m4>>10428000
   <<------------------------------------------------------->> <<xd.m4>>10430000
                                                               <<xd.m4>>10432000
   SUBROUTINE ERROROUT;                                                 10434000
      BEGIN                                                             10436000
      XDDS'SPOOK'ERR := NER;                                   <<xd.m4>>10438000
      XDDS'FILESYS'ERR := FER;                                 <<xd.m4>>10440000
      SBUF := NER;                                                      10442000
      SBUF(1) := FER;                                                   10444000
      NER := 0;                                                         10446000
      FER := 0;                                                         10448000
      IF NOT WRITETAPE(SBUF,20) THEN GOTO BADWRITE;            <<xd.m4>>10450000
      END;                                                              10452000
   << >>                                                                10454000
   SUBROUTINE ERRORFILE;                                                10456000
      BEGIN                                                             10458000
      NER := 26;    << file read error >>                      <<xd.m4>>10460000
      FCHECK(FILEF,FER);                                                10462000
            ERRF := FER;                                       <<01326>>10464000
      ERROROUT;                                                         10466000
      END;                                                              10468000
   << >>                                                                10470000
                                                               <<01886>>10472000
   SUBROUTINE WRITEUSERLABELS;                                 <<01886>>10474000
      BEGIN                                                    <<01886>>10476000
         FFILEINFO(FILEF, 17, NUMSPULABS);                     <<01886>>10478000
         IF NUMSPULABS > 0 THEN                                <<01886>>10480000
         BEGIN                                                 <<01886>>10482000
            SBUF := 8;  <<LENGTH>>                             <<01930>>10484000
            SBUF(1) := 0;                                      <<01930>>10486000
            SBUF(2) := 3; <<FOPEN>>                            <<01930>>10488000
            SBUF(3) := 0; <<P1>>                               <<01930>>10490000
            SBUF(4) := NUMSPULABS; <<P2>>                      <<01930>>10492000
            SBUF(5) := -1; <<END OF BLOCK>>                    <<01930>>10494000
            MOVE SBUF(512) := SBUF, (6);                       <<01930>>10496000
            IF NOT WRITETAPE(SBUF,1024) THEN GO TO BADWRITE;   <<xd.m4>>10498000
            J := 1 ;                                           <<01930>>10500000
            DO                                                 <<01886>>10502000
            BEGIN                                              <<01886>>10504000
               FREADLABEL(FILEF,SBUF(128),, J-1);              <<01930>>10506000
               FREADLABEL(FILEF, SBUF(128*2),,J);              <<01930>>10508000
               FREADLABEL(FILEF, SBUF(128*3),,J+1);            <<01930>>10510000
               FREADLABEL(FILEF,SBUF(512+128),, J+2);          <<01930>>10512000
               FREADLABEL(FILEF, SBUF(512+(128*2)),,J+3);      <<01930>>10514000
               FREADLABEL(FILEF, SBUF(512+(128*3)),,J+4);      <<01930>>10516000
               IF NOT WRITETAPE(SBUF,1024) THEN GO TO BADWRITE;<<xd.m4>>10518000
            END                                                <<01930>>10520000
            UNTIL (J := J+6) > NUMSPULABS;                     <<01930>>10522000
         END;                                                  <<01886>>10524000
      END; <<SUBROUTINE WRITEUSERLABELS>>                      <<01886>>10526000
$PAGE                                                          <<xd.m4>>10528000
<<>>                                                           <<01886>>10530000
<< Start of procedure OUTFILES >>                              <<xd.m4>>10532000
                                                               <<01886>>10534000
   FILEF := 0;                                                          10536000
   C := 0;                                                              10538000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>10540000
   PRINT(MOUT,22,0);                                                    10542000
   WHILE (C:=C+1) <= XDDC DO                                            10544000
      BEGIN                                                             10546000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>10548000
      CRITFLAG := TRUE;                                        <<B0.00>>10550000
      @XDD'SUBENTRY := @XDD'SUBENTRY-SIZE'OF'XDD'SUBENTRY;     <<xd.m4>>10552000
      IF XDD'SUBENTRY > 0 THEN                                 <<xd.m4>>10554000
         BEGIN                                                          10556000
         << copy device file id number and idd'or'odd bit >>   <<xd.m4>>10558000
         DEVF := XDDS'DFID'ALL;                                <<xd.m4>>10560000
         STOP'WRITE := TRUE;                                   <<xd.m4>>10562000
         FILEEND := FALSE;                                              10564000
                                                               <<xd.m4>>10566000
      << open the spoolfile to be output >>                    <<xd.m4>>10568000
      TOS := SPOOLOPEN(DEVF,FILEF);                            <<B0.01>>10570000
         SAVE'XDDS'ADDR := @XDD'SUBENTRY;                      <<xd.m4>>10572000
         @XDD'SUBENTRY := @XDDBUF;                             <<xd.m4>>10574000
         XDDS'SPOOL'STATE := XDDS'LOCKED;                      <<xd.m4>>10576000
         XDDS'OUTPUT'PRIORITY := 1;                            <<xd.m4>>10578000
         XDDS'SHOW'ERRS := 0;                                  <<xd.m4>>10580000
         @XDD'SUBENTRY := SAVE'XDDS'ADDR;                      <<xd.m4>>10582000
         MOVE XDD'SUBENTRY := XDDBUF,(SIZE'OF'XDD'SUBENTRY);   <<xd.m4>>10584000
         IF NOT TOS THEN   << spoolfile not opened OK >>       <<xd.m4>>10586000
            BEGIN                                                       10588000
            NER := ERRN;                                                10590000
            FER := ERRF;                                                10592000
            ERRN := 0;                                                  10594000
            ERRF := NO'FILE'ERROR;                             <<04145>>10596000
            ERROROUT                                                    10598000
            END                                                         10600000
         ELSE                                                           10602000
            <<spoolfile opened OK, write XDD subentry to tape>><<xd.m4>>10604000
            BEGIN                                                       10606000
            IF NOT WRITETAPE(XDDBUF,SIZE'OF'XDD'SUBENTRY) THEN <<xd.m4>>10608000
               GOTO BADWRITE;                                  <<xd.m4>>10610000
            WRITEUSERLABELS;                                   <<01886>>10612000
                                                               <<xd.m4>>10614000
            << write 2 spoolfile blocks (1024-word record)  >> <<xd.m4>>10616000
            << at a time, until we are at the end of file.  >> <<xd.m4>>10618000
            DO                                                          10620000
               BEGIN                                                    10622000
               STOP'WRITE := TRUE;                             <<xd.m4>>10624000
               FREAD(FILEF,SBUF,512);                                   10626000
               IF < THEN                                                10628000
                  ERRORFILE                                             10630000
               ELSE                                                     10632000
                  IF = THEN                                             10634000
                     BEGIN                                              10636000
                     NEXTREEL;                                          10638000
                     FREAD(FILEF,SBUF(512),512);                        10640000
                     IF < THEN                                          10642000
                        ERRORFILE                                       10644000
                     ELSE                                               10646000
                        IF > THEN                                       10648000
                           BEGIN                                        10650000
                           IF NOT WRITETAPE(SBUF,512) THEN              10652000
                              GOTO BADWRITE;                   <<xd.m4>>10654000
                           END                                          10656000
                        ELSE  << CCE from FREAD >>             <<xd.m4>>10658000
                           BEGIN                                        10660000
                           IF NOT WRITETAPE(SBUF,1024) THEN             10662000
                              GOTO BADWRITE;                   <<xd.m4>>10664000
                           STOP'WRITE := FALSE;                <<xd.m4>>10666000
                           END;                                         10668000
                     END;                                               10670000
               END                                                      10672000
            UNTIL STOP'WRITE;                                  <<xd.m4>>10674000
            END;                                                        10676000
         IF NOT WRITETAPE(SBUF,0) THEN GOTO BADWRITE;          <<xd.m4>>10678000
         FILEEND := TRUE;                                               10680000
         NEXTREEL;                                                      10682000
         IF FILEF <> 0 THEN                                             10684000
            BEGIN                                                       10686000
            PRI := 1;                                                   10688000
            COPIES := 0;                                                10690000
            CLASS := 0;                                        <<xd.m4>>10692000
            DEVICE := 0;                                       <<xd.m4>>10694000
            ALTERXDD(DEVF);                                    <<B0.01>>10696000
            FSCLOSE(FILEF,IF PURGEFLAG THEN 4 ELSE 0,0);      <<00204>> 10698000
            FILEF := 0;                                                 10700000
            END;                                                        10702000
         MOVE XDDBUF := XDD'SUBENTRY,(SIZE'OF'XDD'SUBENTRY);   <<xd.m4>>10704000
         IF XDDS'SHOW'ERRS = 0 THEN SHOWXDD(%4,0);             <<xd.m4>>10706000
         END;    << if spoofle opened successfully >>          <<xd.m4>>10708000
      END;   << while C < XDDC >>                              <<xd.m4>>10710000
   LASTREEL := TRUE;                                                    10712000
   NEXTREEL;                                                            10714000
   OUTFILES := TRUE;                                                    10716000
   GOTO LX;                                                             10718000
MRABORT:                                                       <<xd.m4>>10720000
   ERRN := 60;    << multi-reel abort >>                       <<xd.m4>>10722000
   GOTO LY;                                                             10724000
BADWRITE:                                                      <<xd.m4>>10726000
   ERRN := 55;    << tape file write error >>                  <<xd.m4>>10728000
LY:                                                                     10730000
   IF FILEF <> 0 THEN FSCLOSE(FILEF,0,0);                               10732000
   FCLOSE(FILET,1,0);                                          <<02724>>10734000
   FILET := 0;                                                          10736000
   PURGEFLAG := FALSE;                                        <<00204>> 10738000
LX:                                                                     10740000
   END;                                                                 10742000
$PAGE "* * * PURGEFILES * * *"                                 <<xd.m4>>10744000
$CONTROL SEGMENT=SPOOK2                                                 10746000
                                                               <<xd.m4>>10748000
<<---------------------------------------------------------->> <<xd.m4>>10750000
<< PURGEFILES purges the spoolfiles previously obtained by  >> <<xd.m4>>10752000
<< procedure GETFILES.  A spoolfile to be purged is des-    >> <<xd.m4>>10754000
<< cribed in DEVF, and FILEF is its entry into the AFT.     >> <<xd.m4>>10756000
<<---------------------------------------------------------->> <<xd.m4>>10758000
                                                                        10760000
PROCEDURE PURGEFILES;                                                   10762000
   BEGIN                                                                10764000
   INTEGER C;                                                           10766000
   LOGICAL POINTER XDD'SUBENTRY;                               <<xd.m4>>10768000
   << >>                                                                10770000
   SUBROUTINE ERRORPURG;                                                10772000
      BEGIN                                                             10774000
      XDDS'SPOOK'ERR := ERRN;                                  <<xd.m4>>10776000
      XDDS'FILESYS'ERR := ERRF;                                <<xd.m4>>10778000
      ERRN := 0;                                                        10780000
      ERRF := NO'FILE'ERROR;                                   <<04145>>10782000
      FILEF := 0;                                                       10784000
      END;                                                              10786000
   << >>                                                                10788000
   C := 0;                                                              10790000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>10792000
   PRINT(MOUT,22,0);                                                    10794000
   WHILE (C:=C+1) <= XDDC DO                                            10796000
      BEGIN                                                             10798000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>10800000
      CRITFLAG := TRUE;                                        <<B0.00>>10802000
      @XDD'SUBENTRY := @XDD'SUBENTRY-SIZE'OF'XDD'SUBENTRY;     <<xd.m4>>10804000
      IF XDD'SUBENTRY > 0 THEN                                 <<xd.m4>>10806000
         BEGIN                                                          10808000
         DEVF := XDDS'DFID'ALL;                                <<xd.m4>>10810000
         IF FILEN <> 0 AND DEVF = DEVFN THEN                            10812000
            BEGIN                                                       10814000
            FILEF := FILEN;                                             10816000
            FILEN := 0;                                                 10818000
            END                                                         10820000
         ELSE                                                           10822000
         IF NOT SPOOLOPEN(DEVF,FILEF) THEN ERRORPURG;          <<B0.01>>10824000
         IF FILEF <> 0 THEN                                             10826000
            BEGIN    << close file and delete it >>            <<xd.m4>>10828000
            FSCLOSE(FILEF,4,0);                                         10830000
            IF < THEN                                                   10832000
               BEGIN                                                    10834000
               ERRN := 25;    << unable to purge file >>       <<xd.m4>>10836000
               FCHECK(FILEF,ERRF);                                      10838000
               ERRORPURG;                                               10840000
               END                                                      10842000
            ELSE                                                        10844000
               BEGIN                                                    10846000
              MOVE XDDBUF:=XDD'SUBENTRY,(SIZE'OF'XDD'SUBENTRY);<<xd.m4>>10848000
               SHOWXDD(%4,0);                                           10850000
               END;                                                     10852000
            END;                                                        10854000
         END;                                                           10856000
      END;                                                              10858000
   END;                                                                 10860000
                                                                        10862000
$PAGE "SPOOK CONTROLY ROUTINES"                                <<B0.00>>10864000
$CONTROL SEGMENT=SPOOK1                                                 10866000
                                                                        10868000
PROCEDURE CONTROLY;                                                     10870000
   BEGIN                                                                10872000
   << >>                                                                10874000
      TOS:=EXCHANGEDB(0);                                      <<B0.00>>10876000
      IF CRITFLAG THEN                                         <<B0.00>>10878000
        BEGIN                                                  <<B0.00>>10880000
        CONTROLYFLAG := TRUE;                                  <<B0.00>>10882000
        ASSEMBLE(ZERO,XCH);                                    <<B0.01>>10884000
        EXCHANGEDB(*);                                         <<B0.00>>10886000
        TOS := TOS.(8:8) + EXITINSTR;                          <<B0.01>>10888000
        ASSEMBLE(XEQ 0);                                       <<B0.01>>10890000
        END                                                    <<B0.00>>10892000
      ELSE                                                     <<B0.00>>10894000
         DDEL;                                                 <<B0.01>>10896000
        CONTROLYPROC;                                          <<B0.00>>10898000
        END;                                                   <<B0.00>>10900000
                                                               <<B0.00>>10902000
                                                               <<B0.00>>10904000
$CONTROL SEGMENT=SPOOK1                                        <<B0.00>>10906000
                                                               <<B0.00>>10908000
PROCEDURE CONTROLYPROC;                                        <<B0.00>>10910000
                                                               <<B0.00>>10912000
   BEGIN                                                       <<B0.00>>10914000
<<>>                                                           <<B0.00>>10916000
                                                               <<B0.00>>10918000
   EXCHANGEDB(0) ;                                             <<B0.01>>10920000
   DELTAP.(2:14) := CYADDR;                                             10922000
   QMSTAT := STATVAL;                                                   10924000
   PUSH(Q);                                                             10926000
   DELTAQ := TOS-QVAL;                                                  10928000
   IF DELTAQ < 4 THEN DEBUG;                                   <<B0.01>>10930000
   CONTROLYFLAG := FALSE;                                      <<B0.00>>10932000
   RESETCONTROL;                                                        10934000
   END;                                                                 10936000
$PAGE "SPOOK SUBTASKING INTERFACE ROUTINE"                     <<B0.00>>10938000
$CONTROL SEGMENT=SPOOK1                                        <<B0.00>>10940000
<<  PROCEDURE ATTACH WILL ATTEMPT >>                           <<B0.00>>10942000
<<  TO ATTACH (CREATE AND/OR ACTIVATE >>                       <<B0.00>>10944000
<<  A TASK            >>                                       <<B0.00>>10946000
                                                               <<B0.00>>10948000
LOGICAL PROCEDURE ATTACH(PROGNAME,PINNUM);                     <<B0.00>>10950000
BYTE ARRAY PROGNAME;                                           <<B0.00>>10952000
INTEGER PINNUM;                                                <<B0.00>>10954000
                                                               <<B0.00>>10956000
BEGIN                                                          <<B0.00>>10958000
   INTEGER COUNT;                                              <<B0.00>>10960000
                                                               <<xd.m4>>10962000
<<  >>                                                         <<B0.00>>10964000
   SCAN PROGNAME UNTIL %6440,1;                                <<B0.00>>10966000
   COUNT := TOS - @PROGNAME;                                   <<B0.00>>10968000
   ATTACH:=FALSE;                                              <<B0.00>>10970000
   IF LASTCREATE = PROGNAME ,(COUNT)  THEN                     <<B0.00>>10972000
      BEGIN                                                    <<B0.00>>10974000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>10976000
      IF (LASTPIN := GETPROCID(1)) = 0                         <<B0.00>>10978000
      THEN GO TO CREATE'TASK;                                  <<B0.00>>10980000
      ACTIVATE(PINNUM,3);                                      <<B0.00>>10982000
      IF < THEN GO TO CREATE'TASK;                             <<B0.00>>10984000
      IF (LASTPIN := GETPROCID(1)) = 0                         <<B0.00>>10986000
      THEN LASTCREATE := 0;    <<SON HAS TERMINATED>>          <<B0.00>>10988000
      XCONTRAP(CYLABEL,CYOLD); <<REARM CONTROLY>>              <<B0.00>>10990000
      ATTACH:=TRUE;                                            <<B0.00>>10992000
      CRITFLAG := TRUE;;                                       <<B0.00>>10994000
      RETURN;                                                  <<B0.00>>10996000
      END;                                                     <<B0.00>>10998000
CREATE'TASK:                                                   <<B0.00>>11000000
          IF LASTPIN <> 0 THEN                                 <<B0.00>>11002000
             KILL(LASTPIN);                                    <<B0.00>>11004000
   ERRORON; INTRINS := 100;NUMPARMS :=2;                       <<B0.00>>11006000
   CREATE (PROGNAME,,PINNUM,SUBTASK'LEVEL,1);                  <<B0.00>>11008000
      IF < OR CARRY  THEN                                      <<B0.00>>11010000
            BEGIN                                              <<B0.00>>11012000
            ATTACH:=FALSE;                                     <<B0.00>>11014000
            ERROREXIT(INTRWORD,0,0);                           <<B0.00>>11016000
            RETURN;                                            <<B0.00>>11018000
            END                                                <<B0.00>>11020000
     ELSE BEGIN                                                <<B0.00>>11022000
     CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;     <<B0.00>>11024000
          ACTIVATE(PINNUM,3);                                  <<B0.00>>11026000
         XCONTRAP(CYLABEL,CYOLD); <<REARM CONTROLY>>           <<B0.00>>11028000
          IF (LASTPIN := GETPROCID(1)) = 0                     <<B0.00>>11030000
      THEN LASTCREATE := 0     <<SON HAS TERMINATED>>          <<B0.00>>11032000
      ELSE                                                     <<B0.00>>11034000
          MOVE LASTCREATE:=PROGNAME,(27);                      <<B0.00>>11036000
      CRITFLAG := TRUE;                                        <<B0.00>>11038000
            ATTACH:=TRUE;                                      <<B0.00>>11040000
      ERROREXIT(INTRWORD,0,0);                                 <<B0.00>>11042000
          END;                                                 <<B0.00>>11044000
END;                                                           <<B0.00>>11046000
$PAGE "SPOOK MPE COMMAND PROCESSING ROUTINE"                   <<00897>>11048000
$CONTROL SEGMENT=SPOOK1                                        <<B0.00>>11050000
<< PROCEDURE MPECOMMAND WILL ATTEMPT>>                         <<B0.00>>11052000
<< TO EXECUTE PROGRAMMATICALLY A    >>                         <<B0.00>>11054000
<< COMMAND STRING THAT IS NOT       >>                         <<B0.00>>11056000
<< A SPOOK COMMAND                  >>                         <<B0.00>>11058000
                                                               <<B0.00>>11060000
LOGICAL PROCEDURE MPECOMMAND(COMMAND'STRING);                  <<B0.00>>11062000
BYTE ARRAY   COMMAND'STRING;                                   <<B0.00>>11064000
                                                               <<B0.00>>11066000
BEGIN                                                          <<B0.00>>11068000
   INTEGER ERROR, PARM, J;                                     <<xd.m4>>11070000
                                                               <<xd.m4>>11072000
<<>>                                                           <<B0.00>>11074000
MPECOMMAND := FALSE;                                           <<B0.00>>11076000
COMMAND(COMMAND'STRING,ERROR, PARM);                           <<B0.00>>11078000
   IF = THEN                                                   <<cwarn>>11080000
   BEGIN                                                       <<cwarn>>11082000
      MPECOMMAND := TRUE;                                      <<cwarn>>11084000
      IF ERROR <> 0 THEN                                       <<cwarn>>11086000
      BEGIN                                                    <<cwarn>>11088000
         IF ERROR < 0 THEN ERROR := -ERROR;                    <<cwarn>>11090000
         J := GENMSG(2,ERROR);                                 <<cwarn>>11092000
      END;                                                     <<cwarn>>11094000
   END                                                         <<cwarn>>11096000
   ELSE                                                        <<cwarn>>11098000
      IF > THEN                                                <<B0.00>>11100000
         BEGIN                                                 <<B0.00>>11102000
            IF ERROR < 0 THEN ERROR := -ERROR;                          11104000
            J := GENMSG(2,ERROR);                              <<B0.00>>11106000
            MPECOMMAND := TRUE;                                <<B0.00>>11108000
        END;                                                   <<B0.00>>11110000
END;                                                           <<B0.00>>11112000
$PAGE "SPOOK COPY/APPEND ROUTINES"                             <<00897>>11114000
$CONTROL SEGMENT=SPOOK3                                        <<B0.01>>11116000
                                                               <<B0.01>>11118000
LOGICAL PROCEDURE NEW'FILE'CLOSE(OLD);                         <<B0.01>>11120000
<<>>                                                           <<B0.01>>11122000
   VALUE OLD;                                                  <<B0.01>>11124000
   LOGICAL OLD;                                                <<B0.01>>11126000
                                                               <<04145>>11128000
<<****************************************************>>       <<04145>>11130000
<< THIS PROCEDURE CLOSES THE NEWLY CREATED COPIED FILE>>       <<B0.01>>11132000
<< THAT WAS OPENED AS A RESULT OF COPY/APPEND         >>       <<B0.01>>11134000
<< IF THE FILE IS A SPOOLFILE, THEN A CALL TO FSCLOSE >>       <<B0.01>>11136000
<< IS MADE AND THE APPROPRIATE SPOOLER IS AWAKENED.   >>       <<B0.01>>11138000
<< IF THE FILE IS A PERMANENT FILE, THEN IF A FILE    >>       <<B0.01>>11140000
<< WITH THE SAME NAME ALREADY EXISTS, THE USER IS     >>       <<B0.01>>11142000
<< PROMPTED FOR ITS REPLACEMENT.                      >>       <<B0.01>>11144000
<<****************************************************>>       <<04145>>11146000
                                                               <<04145>>11148000
BEGIN                                                          <<B0.01>>11150000
INTEGER DISP;  <<CLOSE DISPOSITION>>                           <<B0.01>>11152000
ARRAY FILENAME(0:13);                                          <<04145>>11154000
BYTE ARRAY FILENAME'B(*)=FILENAME;                             <<04145>>11156000
LOGICAL TRY'AGAIN;                                             <<B0.01>>11158000
<<>>                                                           <<B0.01>>11160000
                                                               <<B0.01>>11162000
NEW'FILE'CLOSE := FALSE;                                       <<B0.01>>11164000
DISP := %11;                                                   <<B0.01>>11166000
TRY'AGAIN := FALSE;                                            <<B0.01>>11168000
                                                               <<04145>>11170000
<<**********************************************************>> <<04145>>11172000
<<  If we have a new spoolfile, close it out.               >> <<04145>>11174000
<<**********************************************************>> <<04145>>11176000
                                                               <<04145>>11178000
IF NEW'SPOOLFILE THEN                                          <<B0.01>>11180000
   IF NEW'FILEN <> 0 THEN                                      <<B0.01>>11182000
   BEGIN                                                       <<B0.01>>11184000
   ODDN := FINDODD(NEW'XDDN);                                  <<xd.m4>>11186000
   FSCLOSE(NEW'FILEN,0,0);                                     <<B0.01>>11188000
   IF < THEN                                                   <<B0.01>>11190000
      BEGIN                                                    <<B0.01>>11192000
      << unable to close copy file >>                          <<ld.m4>>11194000
      ERRN := 73; FCHECK(NEW'FILEN,ERRF); GO TO LX;            <<B0.01>>11196000
      END;                                                     <<B0.01>>11198000
   SROOSTER(ODDN);                                             <<xd.m4>>11200000
   NEW'SPOOLFILE := FALSE;                                     <<B0.01>>11202000
   END                                                         <<B0.01>>11204000
   ELSE GO TO LX                                               <<B0.01>>11206000
$PAGE                                                          <<04145>>11208000
<<**********************************************************>> <<04145>>11210000
<< Permanent file, try closing it permanent, freeing space  >> <<04145>>11212000
<< after EOF.                                               >> <<04145>>11214000
<<**********************************************************>> <<04145>>11216000
                                                               <<04145>>11218000
ELSE                                                           <<B0.01>>11220000
PERM'CLOSE:                                                    <<B0.01>>11222000
   BEGIN                                                       <<B0.01>>11224000
   FCLOSE(NEW'FILEN,DISP,0);                                   <<B0.01>>11226000
   IF < THEN                                                   <<B0.01>>11228000
      BEGIN                                                    <<B0.01>>11230000
      IF TRY'AGAIN THEN                                        <<B0.01>>11232000
        BEGIN                                                  <<B0.01>>11234000
        DISP := -1;                                            <<B0.01>>11236000
        GO TO PERM'CLOSE;                                      <<B0.01>>11238000
        END;                                                   <<B0.01>>11240000
      TRY'AGAIN := TRUE;                                       <<B0.01>>11242000
      << unable to close copy file >>                          <<ld.m4>>11244000
      ERRN := 73; FCHECK(NEW'FILEN,ERRF);                      <<B0.01>>11246000
                                                               <<04145>>11248000
      <<****************************************************>> <<04145>>11250000
      << If the file already exists (perm or temp), ask the >> <<04145>>11252000
      << user if he wants the file purged.                  >> <<04145>>11254000
      <<****************************************************>> <<04145>>11256000
                                                               <<04145>>11258000
      IF ERRF = 100 OR ERRF = 101 THEN                         <<B0.01>>11260000
         BEGIN                                                 <<B0.01>>11262000
REPLACE'FILE:                                                  <<B0.01>>11264000
         FGETINFO(NEW'FILEN,FILENAME'B);                       <<04145>>11266000
         MOVE CBUF := PRINTFILE,2;                             <<04145>>11268000
         I := TOS - @CBUF;                                     <<04145>>11270000
         MOVE CBUF(3) := FILENAME,(13);                        <<04145>>11272000
         PRINT(CBUF,I,0);                                      <<04145>>11274000
         MOVE CBUF := REPLACEFILE,2;                           <<B0.01>>11276000
         I := TOS - @CBUF;                                     <<B0.01>>11278000
         PRINT(CBUF,I,%320);                                   <<B0.01>>11280000
         CRITFLAG := FALSE; IF CONTROLYFLAG THEN               <<B0.01>>11282000
            CONTROLYPROC;                                      <<B0.01>>11284000
         COUNT := READ(CBUF,-72);                              <<B0.01>>11286000
         CRITFLAG := TRUE;                                     <<B0.01>>11288000
             ERRF := NO'FILE'ERROR;                            <<04145>>11290000
         @BP := @BCBUF;                                        <<B0.01>>11292000
         BP(COUNT) := CR ;                                     <<04145>>11294000
         IF NOT SHIFTUPPER(BP,COUNT) THEN GO REPLACE'FILE;     <<B0.01>>11296000
         SCAN BP WHILE %6440 ,1; <<CR,BLANK>>                  <<B0.01>>11298000
         @BP := TOS;                                           <<B0.01>>11300000
                                                               <<04145>>11302000
         <<*************************************************>> <<04145>>11304000
         <<  If so, purge the file via MPECOMMAND and re-   >> <<04145>>11306000
         << close the file via PERM'CLOSE.                  >> <<04145>>11308000
         <<*************************************************>> <<04145>>11310000
                                                               <<04145>>11312000
         IF NOCARRY AND BP = "Y" THEN                          <<B0.01>>11314000
            BEGIN                                              <<B0.01>>11316000
            IF OLD THEN MOVE BCBUF(6) := OLD'FILENAME,(29)     <<B0.01>>11318000
                   ELSE MOVE BCBUF(6) := NEW'FILENAME,(29);    <<B0.01>>11320000
            MOVE BCBUF(6+28) := CR ;                           <<04145>>11322000
            MOVE BCBUF := "PURGE ";                            <<B0.01>>11324000
            MPECOMMAND(BCBUF);                                 <<B0.01>>11326000
            DISP := %11;                                       <<B0.01>>11328000
            GO TO PERM'CLOSE;                                  <<B0.01>>11330000
            END                                                <<B0.01>>11332000
                                                               <<04145>>11334000
       <<***************************************************>> <<04145>>11336000
       <<  Otherwise, prompt the user for a new file name,  >> <<04145>>11338000
       << a CR signifies user wants the new file purged.    >> <<04145>>11340000
       <<***************************************************>> <<04145>>11342000
                                                               <<04145>>11344000
       ELSE                                                    <<B0.01>>11346000
RENAME'FILE:                                                   <<B0.01>>11348000
          BEGIN                                                <<B0.01>>11350000
          CRITFLAG := FALSE;                                   <<B0.01>>11352000
          IF CONTROLYFLAG THEN CONTROLYPROC;                   <<B0.01>>11354000
          MOVE CBUF := RENAMEFILE,2;                           <<B0.01>>11356000
          I := TOS - @CBUF;                                    <<B0.01>>11358000
          PRINT(CBUF,I,%320);                                  <<B0.01>>11360000
          COUNT := READ(CBUF,-72);                             <<B0.01>>11362000
          CRITFLAG := TRUE;                                    <<B0.01>>11364000
          @BP := @BCBUF;                                       <<B0.01>>11366000
          BP(COUNT) := CR ;                                    <<04145>>11368000
          IF NOT SHIFTUPPER(BP,COUNT) THEN                     <<B0.01>>11370000
             GO RENAME'FILE;                                   <<B0.01>>11372000
          SCAN BP WHILE %6440 ,1; <<CR , BLANK>>               <<B0.01>>11374000
          @BP := TOS;                                          <<B0.01>>11376000
          IF CARRY THEN                                        <<B0.01>>11378000
            BEGIN                                              <<B0.01>>11380000
            DISP := %4;  <<DELETE FILE>>                       <<B0.01>>11382000
            GO TO PERM'CLOSE;                                  <<B0.01>>11384000
            END;                                               <<B0.01>>11386000
                                                               <<04145>>11388000
          <<************************************************>> <<04145>>11390000
          << Otherwise rename the file and reclose it.  If  >> <<04145>>11392000
          << RENAME failed, return to RENAME'FILE to        >> <<04145>>11394000
          << prompt the user again.                         >> <<04145>>11396000
          <<************************************************>> <<04145>>11398000
                                                               <<04145>>11400000
          FRENAME(NEW'FILEN,BP);                               <<B0.01>>11402000
          IF <> THEN                                           <<B0.01>>11404000
             BEGIN                                             <<B0.01>>11406000
             MOVE CBUF := BAD'RENAME,2;                        <<04145>>11408000
             I := TOS - @CBUF;                                 <<04145>>11410000
             PRINT(CBUF,I,0);                                  <<04145>>11412000
             GO TO RENAME'FILE;                                <<04145>>11414000
             END                                               <<B0.01>>11416000
          ELSE                                                 <<B0.01>>11418000
             MOVE CBUF := RENAMED'MESSAGE,2;                   <<B0.01>>11420000
             I:= TOS - @CBUF;                                  <<B0.01>>11422000
             PRINT(CBUF,I,0);                                  <<B0.01>>11424000
             ERRN := 0;                                        <<B0.01>>11426000
             ERRF := NO'FILE'ERROR;                            <<04145>>11428000
             DISP := %11;                                      <<04145>>11430000
             TRY'AGAIN:=FALSE;                                 <<04145>>11432000
             GO TO PERM'CLOSE;                                 <<04145>>11434000
          END;  << Rename file >>                              <<04145>>11436000
                                                               <<04145>>11438000
          END; <<IF ERROR = 100 OR 101 >>                      <<04145>>11440000
                                                               <<04145>>11442000
      FCLOSE(NEW'FILEN,0,0); <<Give back file space>>          <<04145>>11444000
      NEW'FILEN:=0;                                            <<04145>>11446000
      GO TO LX; <<IF Other than Error 100 or 101>>             <<04145>>11448000
                                                               <<04145>>11450000
      END; <<IF < ON THE FCLOSE>>                              <<04145>>11452000
                                                               <<04145>>11454000
   END;  <<IF PERMENENT FILE>>                                 <<04145>>11456000
                                                               <<04145>>11458000
<<GOOD FCLOSE>>                                                <<04145>>11460000
                                                               <<04145>>11462000
                                                               <<xd.m4>>11464000
NEW'FILE'CLOSE := TRUE;                                        <<B0.01>>11466000
NEW'FILEN := 0;                                                <<B0.01>>11468000
                                                               <<04145>>11470000
<<Bad FCLOSE>>                                                 <<04145>>11472000
                                                               <<04145>>11474000
LX:                                                            <<B0.01>>11476000
END;                                                           <<B0.01>>11478000
                                                               <<B0.01>>11480000
$CONTROL SEGMENT=SPOOK3                                        <<B0.01>>11482000
                                                               <<B0.01>>11484000
LOGICAL PROCEDURE NEW'FILE'OPEN;                               <<B0.01>>11486000
<<>>                                                           <<B0.01>>11488000
<< THIS PROCEDURE IS INVOKED TO CREATE A NEW FILE>>            <<B0.01>>11490000
<< FOR COPY/APPEND OR IN THE CASE OF APPEND TO   >>            <<B0.01>>11492000
<< USE FILE ALREADY OPENED FOR OUTPUT.           >>            <<B0.01>>11494000
<<>>                                                           <<B0.01>>11496000
BEGIN                                                          <<B0.01>>11498000
INTEGER DEV;                                                   <<B0.01>>11500000
INTEGER TEMP;                                                           11502000
INTEGER FILEX, ORIG'FILEN ;                                    <<01886>>11504000
LOGICAL POINTER                                                <<ld.m4>>11506000
   LDT,                                                        <<ld.m4>>11508000
   DCT,                                                        <<xd.m4>>11510000
   XDD'SUBENTRY;                                               <<xd.m4>>11512000
DOUBLE POINTER                                                 <<ld.m4>>11514000
   DCTD = DCT;                                                 <<ld.m4>>11516000
BYTE POINTER XDD'BSUBENTRY;                                    <<xd.m4>>11518000
ARRAY CL(0:9) = Q;                                             <<B0.01>>11520000
DOUBLE DCL0 = CL + 0,DCL1 = CL+2;                              <<B0.01>>11522000
BYTE ARRAY BCL(*) = CL + 0;                                    <<B0.01>>11524000
LOGICAL STDLIST;                                               <<xd.m4>>11526000
INTEGER                                                        <<xd.m4>>11528000
        NEW'NUMBUFS,                                           <<xd.m4>>11530000
        NEW'OUTPRI,                                            <<xd.m4>>11532000
        NEW'COPIES,                                            <<xd.m4>>11534000
        NEW'AOPTIONS,                                          <<xd.m4>>11536000
        NEW'DFID,                                              <<xd.m4>>11538000
        NEW'DEVTYPE,                                           <<xd.m4>>11540000
        NEW'LDEV,                                              <<xd.m4>>11542000
        NEW'HDADDR;                                            <<xd.m4>>11544000
LOGICAL                                                        <<xd.m4>>11546000
        REMOTE'FILE;                                           <<xd.m4>>11548000
BYTE ARRAY                                                     <<xd.m4>>11550000
        NEW'ENV(0:36),                                         <<xd.m4>>11552000
        NEW'DEVICE(0:8);                                       <<xd.m4>>11554000
<<>>                                                           <<B0.01>>11556000
@XDD'SUBENTRY := @XDDBUF;                                      <<xd.m4>>11558000
@XDD'BSUBENTRY := @BXDDBUF;                                    <<xd.m4>>11560000
NEW'FILE'OPEN := FALSE;                                        <<B0.01>>11562000
STDLIST := FALSE;   <<INITIALIZE>>                             <<00123>>11564000
IF NEW'FILEN <> 0 THEN  <<PREVIOUSLY OPENED FILE>>             <<B0.01>>11566000
   IF APPEND THEN      <<APPEND COMMAND>>                      <<B0.01>>11568000
      BEGIN                                                    <<B0.01>>11570000
      NEW'FILE'OPEN := TRUE;                                   <<B0.01>>11572000
      GOTO QUICKOUT;                                           <<xd.m4>>11574000
      END                                                      <<B0.01>>11576000
   ELSE                                                        <<B0.01>>11578000
      BEGIN          <<NEW FILE, MUST CLOSE OLD FILE>>         <<B0.01>>11580000
      IF NOT NEW'FILE'CLOSE(TRUE) THEN GOTO QUICKOUT;          <<xd.m4>>11582000
      END;                                                     <<B0.01>>11584000
MOVE NEW'DEVICE := "DISC"; <<DEFAULT>>                         <<B0.01>>11586000
NEW'DEVICE(4):=0;                                              <<B0.01>>11588000
NEW'NUMBUFS := 0;                                              <<B0.01>>11590000
IF NEW'FILENAME = "  " THEN                                    <<B0.01>>11592000
      BEGIN                                                    <<B0.01>>11594000
      <<ENSURE THAT XDD ARRAY REFLECTS TEXT FILE>>             <<B0.01>>11596000
                                                               <<B0.01>>11598000
      SPOOLOPEN(DEVFN,FILEX);                                  <<B0.01>>11600000
      FSCLOSE(FILEX,0,0);                                      <<B0.01>>11602000
     <<>>                                                      <<B0.01>>11604000
      MOVE NEW'FILENAME := XDDSB'FILE'NAME,(8);                <<xd.m4>>11606000
      IF NEW'FILENAME = "$STDLIST" THEN                        <<00123>>11608000
         BEGIN                                                 <<00123>>11610000
         STDLIST := TRUE;                                      <<00123>>11612000
         NEW'FILENAME := "S";      <<CHANGE "$" TO "S" >>      <<00123>>11614000
         END;                                                  <<00123>>11616000
      NEW'NUMBUFS.(4:7):=NEW'COPIES:=ODDS'NUMBER'COPIES;       <<xd.m4>>11618000
      NEW'NUMBUFS.(0:4):=NEW'OUTPRI:=XDDS'OUTPUT'PRIORITY;     <<xd.m4>>11620000
      IF XDDS'CLASS THEN   <<CLASS BITS>>                      <<xd.m4>>11622000
         BEGIN                                                 <<B0.01>>11624000
         DEV := -XDDS'DEVICE;                                  <<xd.m4>>11626000
         @LDT := 0;                                            <<ld.m4>>11628000
         EXCHANGEDB(LDT'DST);                                  <<ld.m4>>11630000
         @DCT := LDT'DCT'BASE;                                 <<ld.m4>>11632000
         WHILE (DEV := DEV +1) < 0 DO                          <<B0.01>>11634000
            @DCT := @DCT+integer(DCT'NEXT'ENTRY);              <<ld.m4>>11636000
         DCL0 := DCTD;                                         <<ld.m4>>11638000
         DCL1 := DCTD(1);                                      <<ld.m4>>11640000
         EXCHANGEDB(0);                                        <<B0.01>>11642000
         MOVE NEW'DEVICE := BCL,(8);                           <<B0.01>>11644000
         END                                                   <<B0.01>>11646000
      ELSE                                                     <<B0.01>>11648000
         ASCII(XDDS'DEVICE,10,NEW'DEVICE);   << ldev >>        <<xd.m4>>11650000
      END;                                                     <<B0.01>>11652000
                                                               <<B0.01>>11654000
<<---------------------------------------------------------->> <<xd.m4>>11656000
<< FOPEN the new copy file with the following options:      >> <<xd.m4>>11658000
<<   FOPTIONS - variable recs, ASCII, new file              >> <<xd.m4>>11660000
<<   AOPTIONS - BUF, excl. access, r/w access               >> <<xd.m4>>11662000
<<   records  - 132 bytes                                   >> <<xd.m4>>11664000
<<---------------------------------------------------------->> <<xd.m4>>11666000
                                                               <<B0.01>>11668000
NEW'FILEN := FOPEN(NEW'FILENAME,%504,%1004,-132,                        11670000
                  NEW'DEVICE,,,,NEW'NUMBUFS);                  <<B0.01>>11672000
IF <> THEN                                                     <<B0.01>>11674000
   << unable to open copy file >>                              <<ld.m4>>11676000
   BEGIN ERRN:=74; FCHECK(NEW'FILEN,ERRF); GOTO QUICKOUT;      <<xd.m4>>11678000
   END;                                                        <<B0.01>>11680000
                                                               <<xd.m4>>11682000
FGETINFO(NEW'FILEN,NEW'FILENAME,,NEW'AOPTIONS,,NEW'DEVTYPE,    <<xd.m4>>11684000
         NEW'LDEV,NEW'HDADDR,NEW'DFID);                        <<B0.01>>11686000
   NEW'ENV := 0; <<INITIALIZE>>                                <<01886>>11688000
FFILEINFO(NEW'FILEN,38,NEW'DFID,43, NEW'ENV);                  <<01886>>11690000
                                                               <<xd.m4>>11692000
<< Find out if this is a remote file by looking at the AFT  >> <<xd.m4>>11694000
<< entry type.  If it is, purge the new copy file.          >> <<xd.m4>>11696000
PUSH(DL);                                                      <<00131>>11698000
TOS := TOS - 4 - NEW'FILEN * 4; <<AFTENTRY>>                   <<00131>>11700000
REMOTE'FILE := PS0.(0:4) = 1 <<ENTRY TYPE 1>>;                 <<00131>>11702000
DEL;                                                           <<00131>>11704000
IF REMOTE'FILE THEN                                                     11706000
   BEGIN                                                                11708000
   ERRN := 77;  <<DS COPY NOT AVAILABLE>>                               11710000
   FCLOSE(NEW'FILEN,4,0); <<PURGE NEW FILE>>                            11712000
   NEW'FILEN := 0;                                                      11714000
   GOTO QUICKOUT;                                              <<xd.m4>>11716000
   END;                                                                 11718000
                                                               <<xd.m4>>11720000
IF NEW'HDADDR.(0:8) = 0 THEN                                   <<B0.01>>11722000
   <<NEW SPOOLFILE>>                                           <<B0.01>>11724000
   BEGIN                                                       <<B0.01>>11726000
   IF NOT SFINDODD(NEW'DFID,NEW'XDDN) THEN                     <<B0.01>>11728000
   << spool file create error >>                               <<ld.m4>>11730000
      BEGIN ERRN := 75; GOTO QUICKOUT; END;                    <<xd.m4>>11732000
   PRI := 1;                                                   <<B0.01>>11734000
   COPIES := 0;                                                <<B0.01>>11736000
   CLASS := 0;                                                 <<xd.m4>>11738000
   DEVICE := 0;                                                <<xd.m4>>11740000
   ALTERXDD(NEW'DFID);     <<TEMPORARY DEFER>>                 <<B0.01>>11742000
   FCLOSE(NEW'FILEN,0,0);                                      <<B0.01>>11744000
   IF NOT SPOOLOPEN(NEW'DFID,NEW'FILEN) THEN                   <<B0.01>>11746000
      GOTO QUICKOUT;                                           <<xd.m4>>11748000
   MOVE SBUF(512) := SBUF, (512); <<STORE CURRENT BLOCK>>      <<B0.01>>11750000
   FREAD(NEW'FILEN,SBUF,512);  <<GET FOPEN RECORD>>            <<B0.01>>11752000
   MOVE NEW'BUFW := SBUF,((SBUF+3)/2);<<FOPEN RECORD>>         <<B0.01>>11754000
   FILE'FORMSMSG := IF SBUF > 8 THEN TRUE                      <<B0.01>>11756000
        ELSE FALSE;      <<IF FORMSMSG THEN TRUE>>             <<B0.01>>11758000
   INHIBIT'FOPEN := FALSE;                                     <<01726>>11760000
   ORIG'FILEN := NEW'FILEN;                                    <<01886>>11762000
   XDDS'OUTPUT'PRIORITY := OLD'PRI;                            <<xd.m4>>11764000
   DEV := XDDS'DEVICE;                                         <<xd.m4>>11766000
   IF XDDS'CLASS THEN DEV := -DEV;                             <<xd.m4>>11768000
   XDDS'SPOOL'STATE := XDDS'OPEN;                              <<xd.m4>>11770000
   IF STDLIST THEN BEGIN <<CHANGE "S" BACK TO "$">>            <<00123>>11772000
                   STDLIST := FALSE; XDDS'FILE'NAME := "$S";   <<xd.m4>>11774000
                   END;                                        <<00123>>11776000
   IF SPUTXDD(1,DEV,XDD'SUBENTRY,NEW'XDDNP) <> 0 THEN          <<xd.m4>>11778000
      << no room in device table >>                            <<ld.m4>>11780000
      BEGIN ERRN := 59; GOTO QUICKOUT; END;                    <<xd.m4>>11782000
   NEW'FILEN := FSOPEN(,%304,%501,NEW'XDDN);                   <<B0.01>>11784000
   IF < THEN                                                   <<B0.01>>11786000
      << unable to open copy file >>                           <<ld.m4>>11788000
      BEGIN ERRN := 74; SREMOVEXDD(NEW'XDDNP);                 <<B0.01>>11790000
       NEW'FILEN := 0;                                         <<B0.01>>11792000
      END;                                                     <<B0.01>>11794000
   FCONTROL(ORIG'FILEN,5,TEMP); <<REWIND SPOOLFILE>>                    11796000
                                                               <<xd.m4>>11798000
   DO                                                          <<01886>>11800000
   BEGIN  <<READ ORIGINAL FILE AND WRITE FOPEN, ENV RECS>>     <<01886>>11802000
      FREAD(ORIG'FILEN, SBUF, 512);                            <<01886>>11804000
      IF <> THEN GOTO CLOSE;                                   <<xd.m4>>11806000
      FWRITE(NEW'FILEN, SBUF, 512, 0);                         <<01886>>11808000
      IF <> THEN                                               <<01886>>11810000
      << file write error >>                                   <<ld.m4>>11812000
      BEGIN ERRN := 27; GOTO QUICKOUT; END;                    <<xd.m4>>11814000
   END                                                         <<01886>>11816000
   UNTIL FALSE;                                                <<xd.m4>>11818000
CLOSE:                                                         <<xd.m4>>11820000
   FSCLOSE(ORIG'FILEN,4,0);  <<PURGE FILE>>                    <<01886>>11822000
   NEW'SPOOLFILE := TRUE;                                      <<B0.01>>11824000
   END;                                                        <<B0.01>>11826000
NEW'FILE'OPEN := TRUE;                                         <<B0.01>>11828000
QUICKOUT:                                                      <<xd.m4>>11830000
END;                                                           <<B0.01>>11832000
                                                               <<B0.01>>11834000
                                                               <<B0.01>>11836000
$PAGE                                                          <<04145>>11838000
$CONTROL SEGMENT=SPOOK2                                        <<B0.01>>11840000
                                                               <<B0.01>>11842000
LOGICAL PROCEDURE COPYRANGE;                                   <<xd.m4>>11844000
   BEGIN                                                       <<xd.m4>>11846000
   INTEGER LSP;                                                <<xd.m4>>11848000
   INTEGER                                                     <<xd.m4>>11850000
      NEW'FOPTIONS,                                            <<xd.m4>>11852000
      NEW'RECSIZE,                                             <<xd.m4>>11854000
      OLD'REC'SIZE;   << # of bytes to xfer from old spoofle>> <<04626>>11856000
   LOGICAL UNI;                                                <<B0.01>>11858000
   BYTE POINTER BSP,NEW'BUF'PNTR;                              <<04626>>11860000
   LOGICAL POINTER SP'NEXT;                                    <<B0.01>>11862000
   DEFINE NEW'VAR'FILE = NEW'FOPTIONS.(8:2)=1#;                <<04626>>11864000
DEFINE CCTLOPTION = LOGICAL(NEW'FOPTIONS.(7:1))#;              <<xd.m4>>11866000
DEFINE NOCCTL'INPUT = LOGICAL(SP(3) = 0 LAND SP(2) = 1)#;      <<xd.m4>>11868000
   << >>                                                       <<B0.01>>11870000
   UNI := TRUE;                                                <<B0.01>>11872000
   DO                                                          <<B0.01>>11874000
      BEGIN                                                    <<B0.01>>11876000
      IF UNI THEN                                              <<B0.01>>11878000
      BEGIN                                                    <<B0.01>>11880000
         UNI := FALSE ;                                        <<B0.01>>11882000
      IF NEW'SPOOLFILE THEN                                    <<B0.01>>11884000
         BEGIN                                                 <<B0.01>>11886000
         IF NOT FILE'FORMSMSG AND NOT INHIBIT'FOPEN THEN       <<01726>>11888000
         COPY'LAST'OPEN;                                       <<B0.01>>11890000
                                                               <<B0.01>>11892000
         INHIBIT'FOPEN := TRUE; <<JUST COPY FIRST FOPEN>>      <<01726>>11894000
         FILE'FORMSMSG := FALSE; <<RESET FOR SUBSEQENT FOPENS>><<B0.01>>11896000
         COMPRESS(SBUF,@SP,512);                               <<B0.01>>11898000
         @SP := @SBUF;                                         <<B0.01>>11900000
         END;                                                  <<B0.01>>11902000
      END                                                      <<B0.01>>11904000
      ELSE                                                     <<B0.01>>11906000
         IF NOT SKANTOLINE(FALSE) THEN GOTO LX;                <<B0.01>>11908000
                                                               <<04145>>11910000
      <<****************************************************>> <<04145>>11912000
      << Now, SP(word pointer) points to the beginning of   >> <<04145>>11914000
      << the next spoolfile record to copy and BSP(byte ptr)>> <<04145>>11916000
      << points to the beginning of the data of the record. >> <<04145>>11918000
      << The spoolfile record looks like the following:     >> <<04145>>11920000
      <<                                                    >> <<04145>>11922000
      <<   SP----->------------------------------------     >> <<04145>>11924000
      <<    Word 0 | Byte count of entire record - 2  |     >> <<04145>>11926000
      <<           |----------------------------------|     >> <<04145>>11928000
      <<    Word 1 | Byte cnt data portion, w/blanks  |     >> <<04145>>11930000
      <<           |----------------------------------|     >> <<04145>>11932000
      <<    Word 2 | Function code of ATTACHIO        |     >> <<04145>>11934000
      <<           |----------------------------------|     >> <<04145>>11936000
      <<    Word 3 | P1 ATTACHIO parameter            |     >> <<04145>>11938000
      <<           |----------------------------------|     >> <<04145>>11940000
      <<    Word 4 | P2 ATTACHIO parameter            |     >> <<04145>>11942000
      <<   BSP---->|----------------------------------|     >> <<04145>>11944000
      <<    Word 5+| DATA portion of record           |     >> <<04145>>11946000
      <<           ~                                  ~     >> <<04145>>11948000
      <<           |----------------------------------|     >> <<04145>>11950000
      <<****************************************************>> <<04145>>11952000
                                                               <<04145>>11954000
      @BSP := @SP(5)&ASL(1);                                   <<B0.01>>11956000
      LSP := FLINECNT;                                         <<B0.01>>11958000
                                                               <<xd.m4>>11960000
      <<****************************************************>> <<04145>>11962000
      << If we are copying to a new spoolfile, then check if>> <<04145>>11964000
      << we are at the end of a block (-1 after record).    >> <<04145>>11966000
      <<****************************************************>> <<04145>>11968000
                                                               <<04145>>11970000
      IF NEW'SPOOLFILE THEN                                    <<B0.01>>11972000
      BEGIN                                                    <<B0.01>>11974000
      @SP'NEXT := LOGICAL(@SP) + LOGICAL((SP +3)/2);           <<B0.01>>11976000
      IF  SP'NEXT = -1 THEN                                    <<B0.01>>11978000
         BEGIN                                                 <<B0.01>>11980000
         FWRITE(NEW'FILEN,SBUF,512,0);                         <<B0.01>>11982000
         IF <> THEN                                            <<B0.01>>11984000
            BEGIN                                              <<B0.01>>11986000
            << file write error >>                             <<ld.m4>>11988000
            ERRN := 27; FCHECK(NEW'FILEN,ERRF); GO TO LX;      <<B0.01>>11990000
            END;                                               <<B0.01>>11992000
                                                               <<B0.01>>11994000
         END;                                                  <<B0.01>>11996000
      END                                                      <<B0.01>>11998000
                                                               <<04145>>12000000
      <<****************************************************>> <<04145>>12002000
      << Otherwise, we have a regular disc file.  The start->> <<04626>>12004000
      << ing byte location of the new file buffer and the   >> <<04626>>12006000
      << old file buffer BSP, will be different when copying>> <<04626>>12008000
      << from NOCCTL to CCTL or vise-versa.  When copying   >> <<04626>>12010000
      << to a file with CCTL, transform the FCONTROL func-  >> <<04626>>12012000
      << tions to a record with only a CCTL byte in it,     >> <<04626>>12014000
      << equal to the FCONTROL function.                    >> <<04626>>12016000
      <<****************************************************>> <<04145>>12018000
                                                               <<04145>>12020000
      ELSE                                                     <<B0.01>>12022000
         BEGIN                                                 <<B0.01>>12024000
   FGETINFO(NEW'FILEN,NEW'FILENAME,NEW'FOPTIONS,,              <<xd.m4>>12026000
            NEW'RECSIZE,,,,);                                  <<xd.m4>>12028000
         NEW'BUF(0) := " ";  << Blank out the new buffer.   >> <<04626>>12030000
         MOVE NEW'BUF(1) := NEW'BUF(0),(255);                  <<04626>>12032000
         OLD'REC'SIZE := SP(0) - 8; << Size of actual data. >> <<04626>>12034000
         @NEW'BUF'PNTR := @NEW'BUF; << Assume no change.    >> <<04626>>12036000
                                                               <<04626>>12038000
         << For variable files, record size in neg. bytes.  >> <<04626>>12040000
                                                               <<04626>>12042000
         IF NEW'VAR'FILE                                       <<04626>>12044000
            THEN NEW'RECSIZE := -OLD'REC'SIZE;                 <<04626>>12046000
         IF CCTLOPTION THEN                                    <<04626>>12048000
            BEGIN << New file has carriage control          >> <<04626>>12050000
            IF SP(2) = 2 AND OLD'REC'SIZE = 0 THEN             <<04626>>12052000
               BEGIN   << FCONTROL function! Place in CCTL  >> <<04626>>12054000
               OLD'REC'SIZE := 1;   << Transfer one byte    >> <<04626>>12056000
               IF NEW'VAR'FILE                                 <<04626>>12058000
                  THEN NEW'RECSIZE := -1;                      <<04626>>12060000
               @BSP := @BSP - 3;    << Point P1 control byte>> <<04626>>12062000
               END                                             <<04626>>12064000
                                                               <<04626>>12066000
            <<**********************************************>> <<04626>>12068000
            << New file has CCTL, old file does not, skip   >> <<04626>>12070000
            << past CCTL byte of new file.                  >> <<04626>>12072000
            <<**********************************************>> <<04626>>12074000
                                                               <<04626>>12076000
            ELSE IF NOCCTL'INPUT THEN                          <<04626>>12078000
               @NEW'BUF'PNTR := @NEW'BUF'PNTR + 1;             <<04626>>12080000
            END                                                <<04626>>12082000
         ELSE IF NOT NOCCTL'INPUT THEN                         <<04626>>12084000
            BEGIN << New does not have CCTL, old file does! >> <<04626>>12086000
            @BSP := @BSP + 1;  << Skip over CCTL byte.      >> <<04626>>12088000
            IF OLD'REC'SIZE > 1                                <<04626>>12090000
               THEN OLD'REC'SIZE := OLD'REC'SIZE - 1;          <<04626>>12092000
            IF NEW'VAR'FILE << Decrement variable count.  >>   <<04626>>12094000
               THEN NEW'RECSIZE := NEW'RECSIZE + 1;            <<04626>>12096000
            END;                                               <<04626>>12098000
                                                               <<04626>>12100000
         <<*************************************************>> <<04626>>12102000
         << Now do the MOVE and write the record.  The de-  >> <<04626>>12104000
         << fault CCTL for new files is single space (" "). >> <<04626>>12106000
         <<*************************************************>> <<04626>>12108000
                                                               <<04626>>12110000
          IF NEW'RECSIZE <> 0 AND OLD'REC'SIZE <> 0 THEN       <<04626>>12112000
             BEGIN                                             <<04626>>12114000
             MOVE NEW'BUF'PNTR := BSP,(OLD'REC'SIZE);          <<04626>>12116000
             IF NEW'BUF(0) = 0 AND CCTLOPTION                  <<04626>>12118000
                THEN NEW'BUF(0) := " ";                        <<04626>>12120000
             FWRITE(NEW'FILEN,NEW'BUFW,NEW'RECSIZE,1);         <<04626>>12122000
             IF <> THEN                                        <<04626>>12124000
                BEGIN                                          <<04626>>12126000
               << file write error >>                          <<ld.m4>>12128000
                ERRN := 27;                                    <<04626>>12130000
                FCHECK(NEW'FILEN,ERRF);                        <<04626>>12132000
                GO TO LX;                                      <<04626>>12134000
                END;                                           <<04626>>12136000
             END;                                              <<04626>>12138000
         CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC; <<04145>>12140000
         CRITFLAG := TRUE;                                     <<04145>>12142000
         END; <<ELSE OF IF NEW'SPOOLFILE>>                     <<04145>>12144000
      END   <<OF DO UNTIL FLINE >= TOLINE >>                   <<04145>>12146000
   UNTIL FLINE >= TOLINE;                                      <<B0.01>>12148000
$PAGE                                                          <<04145>>12150000
   <<*******************************************************>> <<04145>>12152000
   << If you can explain the below code, be my guest!!!     >> <<04145>>12154000
   <<*******************************************************>> <<04145>>12156000
                                                               <<04145>>12158000
   IF NEW'SPOOLFILE THEN                                       <<B0.01>>12160000
      IF TOLINE < EOFLINE AND SP'NEXT <> -1 THEN               <<B0.01>>12162000
      BEGIN                                                    <<B0.01>>12164000
      MOVE SBUF(512) := SBUF,(512);                            <<B0.01>>12166000
       SP'NEXT := -1;                                          <<B0.01>>12168000
      MOVE  SP'NEXT(1) :=  SP'NEXT,(  512-( @SP'NEXT-@SBUF)-1);<<B0.01>>12170000
      FWRITE(NEW'FILEN,SBUF,512,0);                            <<B0.01>>12172000
      IF <> THEN                                               <<B0.01>>12174000
         BEGIN   << file write error >>                        <<ld.m4>>12176000
        ERRN := 27; FCHECK(NEW'FILEN,ERRF);                    <<B0.01>>12178000
        GO TO LX;                                              <<B0.01>>12180000
        END;                                                   <<B0.01>>12182000
      MOVE SBUF := SBUF(512),(512); <<RESTORE LAST BLOCK>>     <<B0.01>>12184000
<<    FREADDIR(FILEN,SBUF,512,BLOCKNO);   RESTORE LAST BLOCK>> <<B0.01>>12186000
<<    IF <> THEN  >>                                           <<B0.01>>12188000
<<    BEGIN      >>                                            <<B0.01>>12190000
<<       ERRN:= 26; FCHECK(FILEN,ERRF); GO TO LX;   >>         <<B0.01>>12192000
<<       END;  >>                                              <<B0.01>>12194000
      END;                                                     <<B0.01>>12196000
                                                               <<B0.01>>12198000
   COPYRANGE := TRUE;                                          <<B0.01>>12200000
LX:                                                            <<B0.01>>12202000
   END;                                                        <<B0.01>>12204000
$CONTROL SEGMENT=SPOOK2                                        <<00897>>12206000
                                                               <<00897>>12208000
LOGICAL PROCEDURE TEXT'NEXT'FILE(XDD'SUBENTRY);                <<xd.m4>>12210000
  LOGICAL POINTER XDD'SUBENTRY;                                <<xd.m4>>12212000
                                                               <<00897>>12214000
BEGIN                                                          <<00897>>12216000
                                                               <<00897>>12218000
   TEXT'NEXT'FILE := FALSE;                                    <<00897>>12220000
   @XDD'SUBENTRY := @XDD'SUBENTRY-SIZE'OF'XDD'SUBENTRY;        <<xd.m4>>12222000
   IF FILEN <> 0 THEN                                          <<00897>>12224000
      BEGIN   <<RELEASE THE CURRENTLY TEXTED FILE>>            <<00897>>12226000
         ODDN := FINDODD(XDDN);                                <<xd.m4>>12228000
         FSCLOSE(FILEN,0,0);                                   <<00897>>12230000
         IF < THEN                                             <<00897>>12232000
         BEGIN     << unable to close file >>                  <<ld.m4>>12234000
            ERRN := 24;                                        <<00897>>12236000
            FCHECK(FILEN,ERRF);                                <<00897>>12238000
            GO TO LX;                                          <<00897>>12240000
         END;                                                  <<00897>>12242000
         SROOSTER(ODDN);                                       <<xd.m4>>12244000
         FILEN := 0;                                           <<00897>>12246000
         XDDN := 0;                                            <<00897>>12248000
         DEVFN := 0;                                           <<00897>>12250000
      END;                                                     <<00897>>12252000
   IF NOT SPOOLOPEN(DEVF := XDDS'DFID'ALL,FILEF) THEN          <<xd.m4>>12254000
      GO TO LX ;                                               <<00897>>12256000
   START'RECNUM := FLINE + 1D; <<INITIALIZE START'RECNUM>>   <<<<01549>>12258000
   @BLOCKFP := @BLOCKCP := @BLOCKTABLE;                        <<00897>>12260000
   BLOCKNO := 0D;                                              <<00897>>12262000
   BLOCKFP := 0;                                               <<00897>>12264000
   MOVE BLOCKFP(1) := BLOCKFP, (BENTRIES*BENTRY'SIZE-1);       <<00897>>12266000
   FILEN := FILEF;                                             <<00897>>12268000
   XDDN := XDDX;                                               <<00897>>12270000
   DEVFN := DEVF;                                              <<00897>>12272000
   FLINE := -1D;                                               <<00897>>12274000
   FGETINFO(FILEN,,,,,,,,,,EOFLINE);                           <<00897>>12276000
   EOFLINE := EOFLINE - 1D;                                    <<00897>>12278000
   TEXT'NEXT'FILE := TRUE;                                     <<00897>>12280000
LX:                                                            <<00897>>12282000
END;   <<TEXT'NEXT'FILE>>                                      <<00897>>12284000
                                                               <<00897>>12286000
$CONTROL SEGMENT = SPOOK2                                      <<00897>>12288000
<<---------------------------------------------------------->> <<xd.m4>>12290000
<< ALTER'FILES is called by the main loop to process the    >> <<xd.m4>>12292000
<< ALTER command.  It in turn calls ALTERXDD, which changes >> <<xd.m4>>12294000
<< the actual xdd subentry in the ODD or IDD.  Errors re-   >> <<xd.m4>>12296000
<< turned from ALTERXDD are saved.                          >> <<xd.m4>>12298000
<<---------------------------------------------------------->> <<xd.m4>>12300000
                                                               <<xd.m4>>12302000
                                                               <<00897>>12304000
LOGICAL PROCEDURE ALTER'FILES;                                 <<00897>>12306000
                                                               <<00897>>12308000
BEGIN                                                          <<00897>>12310000
                                                               <<00897>>12312000
LOGICAL POINTER XDD'SUBENTRY;                                  <<xd.m4>>12314000
                                                               <<00897>>12316000
   ALTER'FILES := FALSE;                                       <<00897>>12318000
   COUNT := 0;                                                 <<00897>>12320000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>12322000
   WHILE (COUNT := COUNT+1)<= XDDC                             <<00897>>12324000
   DO                                                          <<00897>>12326000
      BEGIN                                                    <<00897>>12328000
         @XDD'SUBENTRY := @XDD'SUBENTRY-SIZE'OF'XDD'SUBENTRY;; <<xd.m4>>12330000
         MOVE XDDBUF := XDD'SUBENTRY,(SIZE'OF'XDD'SUBENTRY);   <<xd.m4>>12332000
         IF NOT ALTERXDD(XDDBUF(XD'DFID)) THEN                 <<xd.m4>>12334000
         BEGIN <<STORE ERRORS IN XDD COPY IN STACK>>           <<01326>>12336000
            XDDS'SPOOK'ERR := ERRN;                            <<xd.m4>>12338000
            XDDS'FILESYS'ERR := ERRF;                          <<xd.m4>>12340000
            ERRN := 0;                                         <<04145>>12342000
            ERRF := NO'FILE'ERROR;                             <<04145>>12344000
         END                                                   <<01726>>12346000
         ELSE                                                  <<01726>>12348000
         BEGIN                                                 <<01726>>12350000
             XDD'SUBENTRY := XDDBUF;                           <<xd.m4>>12352000
             XDDS'COPY'INFO := XDDBUF(XD'COPY'INFO);           <<xd.m4>>12354000
         END;                                                  <<01726>>12356000
      END;                                                     <<00897>>12358000
   ALTER'FILES := TRUE;                                        <<00897>>12360000
                                                               <<xd.m4>>12362000
END;    <<ALTER'FILES>>                                        <<00897>>12364000
                                                               <<00897>>12366000
$CONTROL SEGMENT = SPOOK2                                      <<00897>>12368000
                                                               <<00897>>12370000
LOGICAL PROCEDURE COPY'FILES;                                  <<00897>>12372000
                                                               <<00897>>12374000
BEGIN                                                          <<00897>>12376000
                                                               <<00897>>12378000
LOGICAL POINTER XDD'SUBENTRY;                                  <<xd.m4>>12380000
                                                               <<00897>>12382000
COPY'FILES := FALSE;                                           <<00897>>12384000
   COUNT := 0;                                                 <<00897>>12386000
   @XDD'SUBENTRY := INITXDDP;                                  <<xd.m4>>12388000
   WHILE (COUNT := COUNT + 1) <=XDDC                           <<00897>>12390000
   DO  BEGIN                                                   <<00897>>12392000
      @BP := @SECONDPARM;                                      <<00897>>12394000
      IF COPY'FILES'FLAG THEN                                  <<00897>>12396000
      IF NOT TEXT'NEXT'FILE(XDD'SUBENTRY) THEN GO TO EXIT1;    <<xd.m4>>12398000
      IF NOT LINERANGE(COPY) THEN  GO TO EXIT1;                <<00897>>12400000
      IF NOT NEW'FILE'OPEN THEN GO TO EXIT1;                   <<00897>>12402000
      IF NOT SKANTOLINE(TRUE) THEN GO TO EXIT1;                <<00897>>12404000
      IF NOT COPYRANGE THEN GO TO EXIT1;                       <<xd.m4>>12406000
      IF NOT APPEND THEN                                       <<00897>>12408000
         IF NOT NEW'FILE'CLOSE(FALSE) THEN GO TO EXIT1;        <<00897>>12410000
   END;                                                        <<00897>>12412000
   COPY'FILES := TRUE;                                         <<00897>>12414000
                                                               <<00897>>12416000
EXIT1:                                                         <<00897>>12418000
END;  <<COPY'FILES>>                                           <<00897>>12420000
                                                               <<01726>>12422000
$PAGE "READ'RECORD WITH FREADDIR PROCEDURE"                    <<01726>>12424000
                                                               <<01726>>12426000
$CONTROL SEGMENT = SPOOK2                                      <<01726>>12428000
                                                               <<01726>>12430000
   PROCEDURE READ'RECORD(FILENUM, RECORDNUM, BUFFER, RECP,     <<01726>>12432000
        XDDP,BLOCKNUM, ERRNUM);                                <<01726>>12434000
                                                               <<01726>>12436000
      VALUE RECORDNUM, FILENUM, XDDP;                          <<01726>>12438000
      DOUBLE RECORDNUM, BLOCKNUM;                              <<01726>>12440000
      INTEGER POINTER RECP;                                    <<01726>>12442000
      INTEGER ERRNUM, FILENUM;                                 <<01726>>12444000
      LOGICAL XDDP;                                            <<01726>>12446000
      LOGICAL ARRAY BUFFER;                                    <<01726>>12448000
                                                               <<01726>>12450000
   BEGIN                                                       <<01726>>12452000
      COMMENT                                                  <<01726>>12454000
        THIS PROCEDURE READS A BLOCK CONTAINING                <<01726>>12456000
        THE RECORDNUM INTO BUFFER AND POINTS TO                <<01726>>12458000
        RECORDNUM WITH RECP, PLACES THE BLOCK                  <<01726>>12460000
        NUMBER IN BLOCKNUM.                                    <<01726>>12462000
        IF FILESYS ERROR THEN ERRNUM CONTAINS THE ERROR        <<01726>>12464000
        OTHERWISE ERRNUM = NO'FILE'ERROR.                      <<04145>>12466000
        IF RECORDNUM IS < FIRST NON PURGED RECORDNUM           <<01726>>12468000
        THEN WE RETURN CCL.                                    <<01726>>12470000
        IF RECORDUM IS PAST THE END OF FILE WE                 <<01726>>12472000
        RETURN CCG. OTHERWISE CCE.                             <<01726>>12474000
                                                               <<01726>>12476000
                                        ;                      <<01726>>12478000
                                                               <<01726>>12480000
   DOUBLE REC'FIRST'BLOCK,                                     <<01726>>12482000
          BLOCK'EOF,                                           <<01726>>12484000
          REC'EOF,                                             <<01726>>12486000
          REC'CURR'BLOCK,                                      <<01726>>12488000
          FIRST'BLOCK,                                         <<01726>>12490000
          TOT'SECTORS,                                         <<01726>>12492000
          TARGET'BLOCK,                                        <<01726>>12494000
          LAST'TARGET'BLOCK,                                   <<01726>>12496000
          HI'H2O,                                              <<01726>>12498000
          LO'H2O,                                              <<01726>>12500000
          DCOUNT;                                              <<01726>>12502000
                                                               <<01726>>12504000
   INTEGER REC'CNT'IN'BLOCK,                                   <<01726>>12506000
          NUMSPULABS,                                          <<01726>>12508000
          FIRST'EXTENT,                                        <<01726>>12510000
          LENGTH,                                              <<01726>>12512000
          INDEX,                                               <<01726>>12514000
          SCOUNT;                                              <<01726>>12516000
                                                               <<01726>>12518000
   LOGICAL STATUS = Q-1;                                       <<01726>>12520000
   LOGICAL CONTINUE,                                           <<01726>>12522000
            SINGLE'STEP,                                       <<01730>>12524000
          EXTENT'IN'SECTORS;                                   <<01726>>12526000
                                                               <<01726>>12528000
                                                               <<01726>>12530000
   LOGICAL ARRAY XDD'SUBENTRY(0:SIZE'OF'XDD'SUBENTRY-1);       <<xd.m4>>12532000
                                                               <<01726>>12534000
   DEFINE CONDCODE = STATUS.(6:2)#;                            <<01726>>12536000
                                                               <<01726>>12538000
   EQUATE  CCE = 2,                                            <<01726>>12540000
           CCG = 0,                                            <<01726>>12542000
           CCL = 1,                                            <<01726>>12544000
           ULAB = 17,   <<INTEGER>>                            <<01726>>12546000
           EOF = 10,    <<DOUBLE>>                             <<01726>>12548000
           NZEXTENT = 39, <<LOGICAL>>                          <<01726>>12550000
           EXTENTSIZE = 15; <<LOGICAL>>                        <<xd.m4>>12552000
                                                               <<01726>>12554000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<01726>>12556000
                                                               <<01726>>12558000
SUBROUTINE POINT'TO'RECORD;                                    <<01726>>12560000
   BEGIN                                                       <<01726>>12562000
       COMMENT                                                 <<01726>>12564000
           GIVEN A BUFFER THE LAST TWO WORDS ARE               <<01726>>12566000
           THE RECORDNUMBER OF THE FIRST RECORD                <<01726>>12568000
           IN BLOCK.                                           <<01726>>12570000
           POINT TO TARGET RECNUM WITH RECP                    <<01726>>12572000
                                            ;                  <<01726>>12574000
                                                               <<01726>>12576000
      SCOUNT := 0;                                             <<01726>>12578000
      TOS := BUFFER(510);                                      <<01726>>12580000
      TOS := BUFFER(511);                                      <<01726>>12582000
      DCOUNT := TOS;                                           <<01726>>12584000
      @RECP := @BUFFER;                                        <<01726>>12586000
      CONTINUE := TRUE;                                        <<01726>>12588000
      DO                                                       <<01726>>12590000
      BEGIN                                                    <<01726>>12592000
         IF DCOUNT >= RECORDNUM THEN                           <<01726>>12594000
            CONTINUE := FALSE                                  <<01726>>12596000
         ELSE                                                  <<01726>>12598000
            BEGIN                                              <<01726>>12600000
               LENGTH := BUFFER(SCOUNT);                       <<01726>>12602000
               INDEX := SCOUNT;                                <<01726>>12604000
               SCOUNT := SCOUNT + (LENGTH+3)&ASR(1);           <<01726>>12606000
               DCOUNT := DCOUNT + 1D;                          <<01726>>12608000
            END;                                               <<01726>>12610000
       END                                                     <<01726>>12612000
       UNTIL (NOT CONTINUE) LOR (INTEGER(BUFFER(SCOUNT))       <<01726>>12614000
                 = -1);                                        <<01726>>12616000
       @RECP := @BUFFER + SCOUNT;                              <<01726>>12618000
   END;  <<SUBROUTINE POINT'TO'RECORD>>                        <<01726>>12620000
                                                               <<01726>>12622000
   << FIND INITIAL PARAMETERS DEFINING SPOOLFILE>>             <<01726>>12624000
                                                               <<01726>>12626000
   CONDCODE := CCE;                                            <<01726>>12628000
   FFILEINFO(FILENUM, ULAB,       NUMSPULABS,                  <<01726>>12630000
                      EOF,        REC'EOF,                     <<01726>>12632000
                      EXTENTSIZE, EXTENT'IN'SECTORS,           <<01726>>12634000
                      NZEXTENT,   FIRST'EXTENT);               <<01726>>12636000
                                                               <<01726>>12638000
                                                               <<01726>>12640000
   MOVEFROMDSEG(@XDD'SUBENTRY, ODD'DST, XDDP.IDNUM,            <<xd.m4>>12642000
       SIZE'OF'XDD'SUBENTRY);                                  <<xd.m4>>12644000
                                                               <<01726>>12646000
   TOS := 0;                                                   <<01726>>12648000
   TOS := XDDS'NUMBER'EXTENTS;                                 <<xd.m4>>12650000
   IF = THEN TOS := TOS + 1;                                   <<01726>>12652000
   TOS := LOGICAL( TOS - 1)**EXTENT'IN'SECTORS;                <<01726>>12654000
   TOS := TOS + DOUBLE(XDDS'LAST'EXTENT'SIZE);                 <<xd.m4>>12656000
   TOT'SECTORS := TOS;   <<TOTAL SECTORS IN FILE>>             <<01726>>12658000
   BLOCK'EOF := (DOUBLE(((FIRST'EXTENT                         <<01726>>12660000
          -(IF FIRST'EXTENT = 0 THEN 0 ELSE 1))                <<01726>>12662000
          * INTEGER(EXTENT'IN'SECTORS))                        <<01726>>12664000
                - (NUMSPULABS + 1))                                     12666000
                + TOT'SECTORS)&DASR(2);                                 12668000
   FIRST'BLOCK := DOUBLE((FIRST'EXTENT *                       <<01726>>12670000
          INTEGER(EXTENT'IN'SECTORS)                           <<01726>>12672000
          - (IF FIRST'EXTENT = 0 THEN 0 ELSE                   <<01726>>12674000
            (NUMSPULABS + 1)))&ASR(2));                        <<01726>>12676000
   REC'CURR'BLOCK := TARGET'BLOCK := 0D;                       <<01726>>12678000
   IF RECORDNUM > REC'EOF THEN                                 <<01726>>12680000
   BEGIN                                                       <<01726>>12682000
      CONDCODE := CCG;                                         <<01726>>12684000
      RETURN;                                                  <<01726>>12686000
   END                                                         <<01726>>12688000
   ELSE                                                        <<01726>>12690000
   BEGIN                                                       <<01726>>12692000
      FREADDIR(FILENUM,BUFFER, 512, FIRST'BLOCK);              <<01726>>12694000
      IF <> THEN                                               <<01726>>12696000
      BEGIN                                                    <<01726>>12698000
         FCHECK(FILENUM, ERRNUM);  <<ERROR IN FIRST BLOCK>>    <<01726>>12700000
         CONDCODE := CCL;                                      <<01726>>12702000
         CONTINUE := FALSE;                                    <<01726>>12704000
      END                                                      <<01726>>12706000
      ELSE                                                     <<01726>>12708000
      BEGIN  <<READ WENT OK, GET RECORDNUM OF FIRST BLOCK>>    <<01726>>12710000
         TOS := BUFFER(510);                                   <<01726>>12712000
         TOS := BUFFER(511);                                   <<01726>>12714000
         REC'FIRST'BLOCK := TOS;                               <<01726>>12716000
         IF RECORDNUM < REC'FIRST'BLOCK THEN                   <<01726>>12718000
         BEGIN  <<TARGET RECORD BEFORE BEGINNING OF FILE>>     <<01726>>12720000
            CONDCODE := CCL;                                   <<01726>>12722000
            RETURN;                                            <<01726>>12724000
         END;                                                  <<01726>>12726000
      END;                                                     <<01726>>12728000
  END;                                                         <<01726>>12730000
                                                               <<01726>>12732000
   CONTINUE := TRUE;   <<INITIALIZE>>                          <<01726>>12734000
    LO'H2O := FIRST'BLOCK;                                     <<01726>>12736000
    HI'H2O := BLOCK'EOF - 1D;                                  <<01730>>12738000
    SINGLE'STEP := FALSE;                                      <<01730>>12740000
   DO                                                          <<01726>>12742000
   BEGIN << ITERATIVELY FIND BLOCK OF TARGETREC>>              <<01726>>12744000
      LAST'TARGET'BLOCK := TARGET'BLOCK;                       <<01726>>12746000
      TARGET'BLOCK := TARGET'BLOCK +                           <<01726>>12748000
              (BLOCK'EOF * (RECORDNUM - REC'CURR'BLOCK))       <<01726>>12750000
              / REC'EOF;                                       <<01726>>12752000
                                                               <<01726>>12754000
      IF FIRST'BLOCK > TARGET'BLOCK THEN                       <<01726>>12756000
         TARGET'BLOCK := FIRST'BLOCK                           <<01726>>12758000
               + (LAST'TARGET'BLOCK - FIRST'BLOCK)&DASR(1)     <<01726>>12760000
      ELSE                                                     <<01726>>12762000
      IF TARGET'BLOCK > BLOCK'EOF THEN                         <<01726>>12764000
         TARGET'BLOCK := LAST'TARGET'BLOCK +                   <<01726>>12766000
               (BLOCK'EOF - LAST'TARGET'BLOCK)&DASR(1) ;       <<01726>>12768000
                                                               <<01726>>12770000
                                                               <<01726>>12772000
             << READ TARGET BLOCK, SEE IF IN BALLPARK>>        <<01726>>12774000
            IF LAST'TARGET'BLOCK <  TARGET'BLOCK THEN          <<01730>>12776000
            LO'H2O := LAST'TARGET'BLOCK + 1D                   <<01726>>12778000
            ELSE                                               <<01726>>12780000
            IF LAST'TARGET'BLOCK >  TARGET'BLOCK THEN          <<01730>>12782000
            HI'H2O := LAST'TARGET'BLOCK - 1D;                  <<01726>>12784000
            IF LAST'TARGET'BLOCK = TARGET'BLOCK THEN           <<01730>>12786000
            BEGIN                                              <<01730>>12788000
               SINGLE'STEP := TRUE;                            <<01730>>12790000
            END;                                               <<01730>>12792000
            IF TARGET'BLOCK < LO'H2O THEN                      <<01726>>12794000
               TARGET'BLOCK := LO'H2O;                         <<01726>>12796000
            IF TARGET'BLOCK > HI'H2O THEN                      <<01726>>12798000
               TARGET'BLOCK := HI'H2O;                         <<01726>>12800000
TRY'READ:                                                      <<01730>>12802000
         CRITFLAG := FALSE;                                    <<01726>>12804000
         IF CONTROLYFLAG THEN CONTROLYPROC;                    <<01726>>12806000
         CRITFLAG := TRUE;                                     <<01726>>12808000
         FREADDIR(FILENUM, BUFFER, 512, TARGET'BLOCK);         <<01726>>12810000
         IF <> THEN                                            <<01726>>12812000
         BEGIN                                                 <<01726>>12814000
            FCHECK(FILENUM, ERRNUM);                           <<01726>>12816000
            CONDCODE := CCL;                                   <<01726>>12818000
            CONTINUE := FALSE;                                 <<01726>>12820000
         END                                                   <<01726>>12822000
         ELSE                                                  <<01726>>12824000
         BEGIN  <<SEE IF WE ARE IN RIGHT BLOCK>>               <<01726>>12826000
            TOS := BUFFER(510);                                <<01726>>12828000
            TOS := BUFFER(511);                                <<01726>>12830000
            REC'CURR'BLOCK := TOS;                             <<01726>>12832000
            VERIFY'BLOCK'STRUCTURE(BUFFER, INDEX,              <<01726>>12834000
                 REC'CNT'IN'BLOCK);                            <<01726>>12836000
            IF REC'CURR'BLOCK <= RECORDNUM AND                 <<01726>>12838000
               RECORDNUM <  REC'CURR'BLOCK +                   <<01726>>12840000
                DOUBLE(REC'CNT'IN'BLOCK   ) THEN               <<01726>>12842000
            BEGIN << A HIT !!!>>                               <<01726>>12844000
               ERRNUM := NO'FILE'ERROR;                        <<04145>>12846000
               CONDCODE := CCE;                                <<01726>>12848000
               BLOCKNUM := TARGET'BLOCK;                       <<01726>>12850000
               POINT'TO'RECORD;                                <<01726>>12852000
               CONTINUE := FALSE;                              <<01726>>12854000
            END                                                <<01730>>12856000
            ELSE                                               <<01730>>12858000
            IF SINGLE'STEP THEN                                <<01730>>12860000
            BEGIN                                              <<01730>>12862000
               IF RECORDNUM < REC'CURR'BLOCK THEN              <<01730>>12864000
                  TARGET'BLOCK := TARGET'BLOCK -1D             <<01730>>12866000
               ELSE                                            <<01730>>12868000
                  TARGET'BLOCK := TARGET'BLOCK + 1D;           <<01730>>12870000
               GO TO TRY'READ;                                 <<01730>>12872000
            END;                                               <<01730>>12874000
         END;                                                  <<01726>>12876000
                                                               <<01726>>12878000
  END                                                          <<01726>>12880000
                                                               <<01726>>12882000
  UNTIL NOT CONTINUE;                                          <<01726>>12884000
END; <<READ'RECORD>>                                           <<01726>>12886000
                                                               <<01726>>12888000
$PAGE  "SPOOK OUTER BLOCK"                                     <<B0.00>>12890000
<< - - -   MAIN PROGRAM   - - - >>                             <<01.02>>12892000
                                                                        12894000
SPOOK:                                                         <<B0.00>>12896000
   PINOFFATHER:=FATHER;                                        <<B0.00>>12898000
   IF = THEN SUBTASK:=TRUE;                                    <<B0.00>>12900000
   SUBTASK'LEVEL := IF SUBLEVEL = 0 THEN "1"                   <<B0.00>>12902000
        ELSE SUBLEVEL+1;                                       <<B0.00>>12904000
   CRITFLAG := TRUE;                                           <<B0.00>>12906000
   CYLABEL := @CONTROLY;                                                12908000
   PUSH(Q);                                                             12910000
   QVAL := TOS;                                                         12912000
   PUSH(S);                                                             12914000
   SVAL := TOS;                                                         12916000
   ARITRAP(FALSE);                                             <<01.02>>12918000
   PUSH(STATUS);                                                        12920000
   STATVAL := TOS;                                                      12922000
   XCONTRAP(CYLABEL,CYOLD);                                             12924000
   IF CYLABEL = 0 THEN                                                  12926000
      BEGIN                                                             12928000
         <<*************************************************>> <<04145>>12930000
         << Entrance from Control Y procedure.              >> <<04145>>12932000
         <<*************************************************>> <<04145>>12934000
                                                               <<04145>>12936000
CYNEXT:                                                                 12938000
      PUSH(S);                                                          12940000
      TOS := TOS-SVAL;                                                  12942000
      ASSEMBLE(SUBS 0);                                                 12944000
      IF FILET <> 0 THEN                                                12946000
         BEGIN                                                          12948000
         FCLOSE(FILET,1,0);                                    <<02724>>12950000
         FILET := 0;                                                    12952000
         END;                                                           12954000
       MOVE CBUF := "  ** Control Y ** ";                      <<04145>>12956000
      PRINT(CBUF,-17,0);                                       <<04145>>12958000
      GOTO NEXT;                                                        12960000
      END                                                               12962000
   ELSE                                                                 12964000
      CYADDR := @CYNEXT;                                                12966000
                                                               <<04145>>12968000
   <<------------------------------------------------------->> <<xd.m4>>12970000
   << See if this is the correct version of SPOOK running on>> <<xd.m4>>12972000
   << the appropriate system by looking at the PCB entry    >> <<xd.m4>>12974000
   << size (16 for MPE4, 21 for MPE5).  If not, print mes-  >> <<xd.m4>>12976000
   << sage and exit.                                        >> <<xd.m4>>12978000
   <<------------------------------------------------------->> <<xd.m4>>12980000
                                                               <<xd.m4>>12982000
   IF LDT'MPE'VERSION=4 AND PCB(1)<>16 THEN                    <<xd.m4>>12984000
   BEGIN                                                       <<xd.m4>>12986000
      MOVE OBUF := "***ERROR*** CAN ONLY RUN SPOOK4 ON AN";    <<xd.m4>>12988000
      MOVE OBUF(19) := "MPEIV SYSTEM";                         <<xd.m4>>12990000
      PRINT (OBUF,-50,0);                                      <<xd.m4>>12992000
      PRINT (ABORTP,-25,0);                                    <<xd.m4>>12994000
      GOTO EXITL;                                              <<xd.m4>>12996000
   END;                                                        <<xd.m4>>12998000
                                                               <<xd.m4>>13000000
   <<*******************************************************>> <<04145>>13002000
   << Obtain a variety of information from the "WHO", inclu->> <<04145>>13004000
   << ding CAPabilities, names, LDEV etc.  Initialize global>> <<04145>>13006000
   << variables and print title.                            >> <<04145>>13008000
   <<*******************************************************>> <<04145>>13010000
                                                               <<04145>>13012000
   WHO(MODE,CAP,LAT,NAMES(0),NAMES(8),NAMES(4),                         13014000
                    NAMES(12),LDEV);                                    13016000
   IF CAP1.(5:1) THEN CAP1.(0:1) := 1;                                  13018000
   ERRN := 0;                                                           13020000
   ERRF := NO'FILE'ERROR;                                      <<04145>>13022000
   WARN := 0;                                                           13024000
   FILEN := 0;                                                          13026000
   FILET := 0;                                                          13028000
   XDDN := 0;                                                           13030000
   DEVFN := 0;                                                          13032000
   FALL := FALSE;                                                       13034000
   FWIDTH := 0;                                                         13036000
SPOOK'TITLE:                                                            13038000
   MOVE CBUF := PTITLE,2;                                      <<01.02>>13040000
   I := TOS-@CBUF;                                             <<01.02>>13042000
   MOVE BCBUF(VUUFF'COL) := OFFICIAL'VUUFF;                    <<04151>>13044000
   PRINT(CBUF,I,0);                                            <<01.02>>13046000
$PAGE                                                          <<04145>>13048000
<<**********************************************************>> <<04145>>13050000
<<                                                          >> <<04145>>13052000
<<    ############ C O M M A N D     L O O P ##########     >> <<04145>>13054000
<<                                                          >> <<04145>>13056000
<<**********************************************************>> <<04145>>13058000
                                                               <<04145>>13060000
NEXT:                                                                   13062000
   IF WARN <> 0 THEN                                                    13064000
      BEGIN                                                             13066000
      ERRMSG(WARN,NO'FILE'ERROR);                              <<04145>>13068000
      WARN := 0;                                                        13070000
      END;                                                              13072000
   DLSIZE(0);                                                           13074000
   INITXDDP := 0;                                                       13076000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>13078000
   CBUF := "> ";                                                        13080000
   I := 1;                                                     <<B0.00>>13082000
                                                               <<04145>>13084000
   <<*******************************************************>> <<04145>>13086000
   << Output prompt ">" and (sublevel).  Read Command and   >> <<04145>>13088000
   << check for errors on the way!!                         >> <<04145>>13090000
   <<*******************************************************>> <<04145>>13092000
                                                               <<04145>>13094000
   IF SUBLEVEL <> 0 THEN BEGIN                                 <<B0.00>>13096000
      CBUF.(8:8) := "(";                                       <<B0.00>>13098000
      CBUF(1).(0:8) := SUBLEVEL;                               <<B0.00>>13100000
      CBUF(1).(8:8) := ")";                                    <<B0.00>>13102000
      I := 2;                                                  <<B0.00>>13104000
      END;                                                     <<B0.00>>13106000
   PRINT(CBUF,I,%320);                                         <<B0.00>>13108000
   IF > THEN                                                   <<04145>>13110000
      TERMINATE                                                <<04145>>13112000
   ELSE IF < THEN                                              <<04145>>13114000
      BEGIN    << prompt I/O error >>                          <<ld.m4>>13116000
         ERRN := 22;                                           <<04145>>13118000
         GO TO ERROR;                                          <<04145>>13120000
      END;                                                     <<04145>>13122000
   COUNT := READ(CBUF(1),-72);                                          13124000
   IF < THEN    << input I/O error >>                          <<ld.m4>>13126000
      BEGIN ERRN := 23; GOTO ERROR; END;                                13128000
   IF > THEN                                                            13130000
      BEGIN ERRMSG(2,NO'FILE'ERROR); GO TO QUITL; END;         <<04145>>13132000
   IF NOT LOGICAL(MODE.(14:1)) THEN  <<NOT DUPLICATIVE>>       <<00897>>13134000
      PRINT(CBUF(1),-COUNT,0);                                 <<00897>>13136000
   CRITFLAG := TRUE;                                           <<B0.00>>13138000
                                                               <<04145>>13140000
   @BP := @BCBUF(2);                                                    13142000
   BP(COUNT) := CR ;                                           <<04145>>13144000
   CNT := 0;                                                            13146000
   SCAN BP(CNT) WHILE %6440,1; <<Skip past blanks, if empty >> <<04145>>13148000
   @BP := TOS;                  << go to command loop      >>  <<04145>>13150000
   IF CARRY THEN GOTO NEXT;                                             13152000
   MOVE BP := BP WHILE AS,1; << Scan for Alpha charactera an>> <<04145>>13154000
   CNT := TOS-@BP;           <<upshift.                     >> <<04145>>13156000
   IF CNT = 0 THEN                                             <<B0.01>>13158000
      BEGIN     << invalid command name >>                     <<ld.m4>>13160000
      ERRN := 20; GO TO ERROR;                                 <<B0.01>>13162000
      END;                                                     <<B0.01>>13164000
   I := 0;                                                              13166000
                                                               <<04145>>13168000
   <<*******************************************************>> <<04145>>13170000
   << Check for proper command name.  If not command, try   >> <<04145>>13172000
   << MPE command.                                          >> <<04145>>13174000
   <<*******************************************************>> <<04145>>13176000
                                                               <<04145>>13178000
   WHILE (I<CNUM) AND (BP<>COMMAND'LIST(I*CSIZE),(CNT)) DO     <<B0.00>>13180000
      I := I+1;                                                         13182000
   IF I = CNUM THEN                                                     13184000
      IF NOT MPECOMMAND(BP) THEN                               <<04145>>13186000
         BEGIN      << invalid command name >>                 <<ld.m4>>13188000
           ERRN := 20; GO TO ERROR;                            <<04145>>13190000
         END                                                   <<04145>>13192000
      ELSE GO TO NEXT;                                         <<04145>>13194000
   IF NOT SHIFTUPPER(BP,COUNT) THEN GO TO ERROR;               <<04145>>13196000
   SCAN BP(CNT) WHILE %6440,1;                                          13198000
   @BP := TOS;                                                          13200000
   CARRYF := 0;                                                         13202000
   TOS := @BP;                                                          13204000
   TOS := @BP;                                                          13206000
   WHILE NOT CARRYF DO                                                  13208000
      BEGIN                                                             13210000
      SCAN * WHILE %6440,1;                                             13212000
      ASSEMBLE(DUP,DUP);                                                13214000
      IF BPS0 = %42 THEN                                                13216000
         BEGIN                                                          13218000
         TOS := TOS+1;                                                  13220000
         SCAN * UNTIL %6442,1;                                          13222000
         END;                                                           13224000
      IF CARRY                                                          13226000
         THEN CARRYF := TRUE                                            13228000
         ELSE TOS := TOS+1;                                             13230000
      ASSEMBLE(XCH,SUB);                                                13232000
      CNT := TOS;                                                       13234000
      MOVE * := *,(CNT),1;                                              13236000
      END;                                                              13238000
   MOVE * := *,(1);                                                     13240000
   GOTO SWCOM(I);                                                       13242000
                                                                        13244000
$PAGE                                                          <<04145>>13246000
<<*********************** E R R O R ! **********************>> <<04145>>13248000
                                                               <<04145>>13250000
ERROR:                                                                  13252000
   ERRMSG(ERRN,ERRF);                                                   13254000
   ERRN := 0;                                                           13256000
   ERRF := NO'FILE'ERROR;                                      <<04145>>13258000
   GOTO NEXT;                                                           13260000
                                                                        13262000
<<*********************** D E B U G ************************>> <<04145>>13264000
                                                               <<04145>>13266000
DBUGL:                                                                  13268000
   IF NOT CAP2.(9:1) THEN                                               13270000
      BEGIN                                                             13272000
      ERRN := 20;     << invalid command name >>               <<ld.m4>>13274000
      WARN := 4;                                                        13276000
      GOTO ERROR;                                                       13278000
      END;                                                              13280000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>13282000
   DEBUG;                                                               13284000
   CRITFLAG := TRUE;                                           <<B0.00>>13286000
   GOTO NEXT;                                                           13288000
                                                                        13290000
<<*********************** E X I T **************************>> <<04145>>13292000
<< First check if we are a subtask.  Of so, check for errors>> <<04145>>13294000
<<**********************************************************>> <<04145>>13296000
                                                               <<04145>>13298000
EXITL:                                                                  13300000
      IF SUBTASK THEN                                          <<B0.00>>13302000
         BEGIN                                                 <<B0.00>>13304000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>13306000
         FATHERINFO := GETPROCINFO(0);                         <<B0.01>>13308000
         IF <> THEN GO TO QUITL; <<FATHER TERMINATED>>         <<B0.01>>13310000
         IF LOGICAL(FATHERINFO1) THEN GO TO QUITL;             <<B0.01>>13312000
                                      <<FATHER ACTIVE>>        <<B0.01>>13314000
           ACTIVATE(0,3);         <<FATHER>>                   <<B0.00>>13316000
         XCONTRAP(CYLABEL,CYOLD); <<REARM CONTROLY>>           <<B0.00>>13318000
      CRITFLAG := TRUE;                                        <<B0.00>>13320000
           GO TO NEXT;                                         <<B0.00>>13322000
         END;                                                  <<B0.00>>13324000
                                                               <<04145>>13326000
$PAGE                                                          <<04145>>13328000
   <<*******************************************************>> <<04145>>13330000
   << Close any texted spool files open and place back on   >> <<04145>>13332000
   << ready queue via SROOSTER.                             >> <<04145>>13334000
   <<*******************************************************>> <<04145>>13336000
                                                               <<04145>>13338000
   IF FILEN <> 0 THEN                                                   13340000
      BEGIN                                                             13342000
      ODDN:=FINDODD(XDDN);                                     <<xd.m4>>13344000
      FSCLOSE(FILEN,0,0);                                               13346000
      IF < THEN                                                         13348000
         BEGIN                                                 <<04145>>13350000
           ERRN := 24;                                         <<04145>>13352000
           FCHECK(FILEN,ERRF);                                 <<04145>>13354000
           FILEN := 0;                                         <<04145>>13356000
           GOTO ERROR;                                         <<04145>>13358000
         END;                                                  <<04145>>13360000
      SROOSTER(ODDN);   << place odd back on ready queue >>    <<xd.m4>>13362000
      END;                                                              13364000
                                                               <<04145>>13366000
   <<*******************************************************>> <<04145>>13368000
   << Close any disk files that have been left open.        >> <<04145>>13370000
   <<*******************************************************>> <<04145>>13372000
                                                               <<04145>>13374000
   IF NEW'FILEN <> 0  THEN                                     <<B0.01>>13376000
      IF NOT NEW'FILE'CLOSE(FALSE) THEN                        <<B0.01>>13378000
         GO TO ERROR;                                          <<B0.01>>13380000
   GOTO FIN;                                                            13382000
                                                                        13384000
<<*****************E X P L A I N  I T ! ********************>> <<04145>>13386000
                                                               <<04145>>13388000
XPLAL:                                                                  13390000
   IF BP <> CR  THEN   << unexpected character >>              <<ld.m4>>13392000
      BEGIN ERRN := 33; GOTO ERROR; END;                                13394000
   EXPLAIN;                                                             13396000
   GOTO NEXT;                                                           13398000
                                                                        13400000
<<********************* S H O W ****************************>> <<04145>>13402000
<< Obtain file ID's, get XDD's and show them and any errors!>> <<04145>>13404000
<<**********************************************************>> <<04145>>13406000
                                                               <<04145>>13408000
SHOWL:                                                                  13410000
   IF NOT GETFILES(1) THEN GOTO ERROR;                                  13412000
   IF BP <> CR  THEN    << unexpected character >>             <<ld.m4>>13414000
      BEGIN ERRN := 33; GOTO ERROR; END;                                13416000
   IF MOVEFROMXDD                                              <<04145>>13418000
     THEN SHOWFILES;                                           <<04145>>13420000
   SHOWERRORS(TRUE);                                           <<04145>>13422000
   GOTO NEXT;                                                           13424000
$PAGE                                                          <<04145>>13426000
<<************************ T E X T *************************>> <<04145>>13428000
<< First close any previously texted files.                 >> <<04145>>13430000
<<**********************************************************>> <<04145>>13432000
                                                               <<04145>>13434000
TEXTL:                                                                  13436000
   IF FILEN <> 0 THEN                                                   13438000
      BEGIN                                                             13440000
      ODDN:=FINDODD(XDDN);                                     <<xd.m4>>13442000
      FSCLOSE(FILEN,0,0);                                               13444000
      IF < THEN      << unable to close file >>                <<ld.m4>>13446000
         BEGIN ERRN := 24; FCHECK(FILEN,ERRF); GOTO ERROR; END;         13448000
      SROOSTER(ODDN);                                          <<xd.m4>>13450000
      FILEN := 0;                                                       13452000
      XDDN := 0;                                                        13454000
      DEVFN := 0;                                                       13456000
      IF BP = "*" AND BP(1) = CR  THEN GO TO NEXT;             <<04145>>13458000
      END;                                                              13460000
   DEVFC := 0;                                                          13462000
   IF NOT GETDEVF THEN GOTO ERROR;                                      13464000
   IF DEVF >= 0 THEN    << input file not allowed >>           <<ld.m4>>13466000
      BEGIN ERRN := 30; GOTO ERROR; END;                                13468000
   IF BP <> CR  THEN     << unexpected character >>            <<ld.m4>>13470000
      BEGIN ERRN := 33; GOTO ERROR; END;                                13472000
   IF NOT SPOOLOPEN(DEVF,FILEF) THEN GO TO ERROR;              <<B0.01>>13474000
  START'RECNUM := FLINE + 1D; <<INITIALIZE START'RECNUM>>   <<S<<01549>>13476000
   @BLOCKFP := @BLOCKCP := @BLOCKTABLE;                        <<B0.01>>13478000
   BLOCKNO := 0D;                                              <<B0.01>>13480000
   BLOCKFP := 0;                                               <<B0.01>>13482000
   MOVE BLOCKFP(1) := BLOCKFP, (BENTRIES*BENTRY'SIZE-1);       <<B0.01>>13484000
   FILEN := FILEF;                                                      13486000
   XDDN := XDDX;                                                        13488000
   DEVFN := DEVF;                                                       13490000
   FLINE := -1D;                                                        13492000
   FGETINFO(FILEN,,,,,,,,,,EOFLINE);                                    13494000
   EOFLINE := EOFLINE-1D;                                               13496000
   GOTO NEXT;                                                           13498000
$PAGE                                                          <<04145>>13500000
<<*********************** L I S T **************************>> <<04145>>13502000
<< Check for texted file, obtain List range, skan to the    >> <<04145>>13504000
<< range and list the file.                                 >> <<04145>>13506000
<<**********************************************************>> <<04145>>13508000
                                                               <<04145>>13510000
LISTL:                                                                  13512000
   IF FILEN = 0 THEN   << no text file >>                      <<ld.m4>>13514000
      BEGIN ERRN := 46; GOTO ERROR; END;                                13516000
   IF NOT LINERANGE(FALSE) THEN GOTO ERROR;                             13518000
   IF NOT SKANTOLINE(TRUE) THEN GOTO ERROR;                             13520000
   IF NOT LISTRANGE(FALSE) THEN GOTO ERROR;                             13522000
   GOTO NEXT;                                                           13524000
                                                                        13526000
<<******************** F I N D  I T ! **********************>> <<04145>>13528000
                                                               <<04145>>13530000
FINDL:                                                                  13532000
   IF FILEN = 0 THEN   << no text file >>                      <<ld.m4>>13534000
      BEGIN ERRN := 46; GOTO ERROR; END;                                13536000
   IF NOT FINDRANGE THEN GOTO ERROR;                                    13538000
   IF NOT SKANTOLINE(TRUE) THEN GOTO ERROR;                             13540000
   IF NOT LISTRANGE(TRUE) THEN GOTO ERROR;                              13542000
   GOTO NEXT;                                                           13544000
                                                                        13546000
MODEL:                                                                  13548000
   IF NOT GETMODE THEN GOTO ERROR;                                      13550000
   GOTO NEXT;                                                           13552000
                                                                        13554000
<<******************* A L T E R ****************************>> <<04145>>13556000
                                                               <<04145>>13558000
ALTEL:                                                                  13560000
   DEVFC := 0;                                                          13562000
   INITXDDP := -2048;                                          <<00897>>13564000
   IF NOT GETFILES(4) THEN GOTO ERROR;                         <<04145>>13566000
   IF BP <> ";" THEN    << missing semi-colon >>               <<ld.m4>>13568000
      BEGIN ERRN := 49; GOTO ERROR; END;                       <<00897>>13570000
   @BP := @BP+1;                                               <<00897>>13572000
   IF MOVEFROMXDD THEN                                         <<04145>>13574000
      BEGIN                                                    <<04145>>13576000
        IF NOT GETALTER THEN GOTO ERROR;                       <<04145>>13578000
        IF NOT ALTER'FILES THEN GO TO ERROR;                   <<04145>>13580000
        SHOWFILES;                                             <<04145>>13582000
      END;                                                     <<04145>>13584000
   SHOWERRORS(FALSE);                                          <<04145>>13586000
   GOTO NEXT;                                                           13588000
                                                                        13590000
$PAGE                                                          <<04145>>13592000
<<******************* P U R G E ****************************>> <<04145>>13594000
                                                               <<04145>>13596000
PURGL:                                                                  13598000
   IF NOT GETFILES(3) THEN                                     <<B0.00>>13600000
      IF NOT MPECOMMAND(BCBUF(2)) THEN                         <<B0.00>>13602000
         GO TO ERROR                                           <<B0.00>>13604000
      ELSE GO TO NEXT;                                         <<B0.00>>13606000
   IF BP <> CR  THEN    << unexpected character >>             <<ld.m4>>13608000
      BEGIN ERRN := 33; GOTO ERROR; END;                                13610000
   IF MOVEFROMXDD                                              <<04145>>13612000
   THEN PURGEFILES;                                            <<04145>>13614000
   SHOWERRORS(FALSE);                                          <<04145>>13616000
   GOTO NEXT;                                                           13618000
                                                                        13620000
<<******************* I N P U T ****************************>> <<04145>>13622000
<<  First check for SM capabilities.  Get the Input files   >> <<04145>>13624000
<<  list.  Open the input tape file.  Build the tape direc- >> <<04145>>13626000
<<  tory and input the files.  Lastly, close the tape file  >> <<04145>>13628000
<<  and check for errors.                                   >> <<04145>>13630000
<<**********************************************************>> <<04145>>13632000
                                                               <<04145>>13634000
INL:                                                                    13636000
   IF NOT CAP1.(0:1) THEN    << invalid command name >>        <<ld.m4>>13638000
      BEGIN ERRN := 20;WARN := 4;GOTO ERROR; END;                       13640000
   INITXDDP := -2048;                                                   13642000
   IF NOT GETFILES(0) THEN GOTO ERROR;                                  13644000
   IF BP <> ";" THEN    << missing semi-colon >>               <<ld.m4>>13646000
      BEGIN ERRN := 49; GOTO ERROR; END;                                13648000
   @BP := @BP+1;                                                        13650000
   IF NOT OPENTAPE(0) THEN GOTO ERROR;                                  13652000
   IF NOT INDIRECTORY THEN GOTO ERROR;                                  13654000
   IF NOT INFILES THEN GOTO ERROR;                                      13656000
   SHOWERRORS(FALSE);                                          <<04145>>13658000
   FCLOSE(FILET,1,0);                                          <<02724>>13660000
   IF < THEN         << unable to close tape file >>           <<ld.m4>>13662000
      BEGIN ERRN := 51; FCHECK(FILET,ERRF); GOTO ERROR; END;            13664000
   FILET := 0;                                                          13666000
   GOTO NEXT;                                                           13668000
                                                                        13670000
$PAGE                                                          <<04145>>13672000
<<********************* O U T P U T ************************>> <<04145>>13674000
<< Check for SM capabilities.  Get the files for output.    >> <<04145>>13676000
<<**********************************************************>> <<04145>>13678000
                                                               <<04145>>13680000
OUTL:                                                                   13682000
   IF NOT CAP1.(0:1) THEN   << invalid command name >>         <<ld.m4>>13684000
      BEGIN ERRN := 20;WARN := 4;GOTO ERROR; END;                       13686000
   INITXDDP := -2048;                                                   13688000
   IF NOT GETFILES(2) THEN GOTO ERROR;                                  13690000
   IF BP <> ";" THEN        << missing semi-colon >>           <<ld.m4>>13692000
      BEGIN ERRN := 49; GOTO ERROR; END;                                13694000
                                                               <<04145>>13696000
   <<*******************************************************>> <<04145>>13698000
   << If there are any files to output found by GETFILES,   >> <<04145>>13700000
   << then open the tape file, check for the PURGE option   >> <<04145>>13702000
   << and output the files.  Last, show any error encountred>> <<04145>>13704000
   <<*******************************************************>> <<04145>>13706000
                                                               <<04145>>13708000
   IF MOVEFROMXDD THEN                                         <<04145>>13710000
      BEGIN                                                    <<04145>>13712000
        @BP := @BP+1;                                          <<04145>>13714000
        IF NOT OPENTAPE(1) THEN GOTO ERROR;                    <<04145>>13716000
        PURGEFLAG := FALSE;                                    <<04145>>13718000
        SCAN BP UNTIL %6473,1;  <<CR, ; >>                     <<04145>>13720000
        @BP := TOS  ;                                          <<04145>>13722000
        IF NOCARRY THEN                                        <<04145>>13724000
           IF BP(1) = "PURGE" THEN                             <<04145>>13726000
              PURGEFLAG := TRUE                                <<04145>>13728000
           ELSE                                                <<04145>>13730000
              BEGIN                                            <<04145>>13732000
              FCLOSE(FILET,1,0);                               <<04145>>13734000
              FILET := 0;                                      <<04145>>13736000
              << unexpected character >>                       <<ld.m4>>13738000
              ERRN := 33; GO TO ERROR; END;                    <<04145>>13740000
                                                               <<04145>>13742000
        IF NOT OUTDIRECTORY THEN GOTO ERROR;                   <<04145>>13744000
        IF NOT OUTFILES THEN GOTO ERROR;                       <<04145>>13746000
      END;                                                     <<04145>>13748000
   PURGEFLAG := FALSE;                                        <<00204>> 13750000
   SHOWERRORS(FALSE);                                          <<04145>>13752000
                                                               <<04145>>13754000
   <<Close the tape file                                    >> <<04145>>13756000
                                                               <<04145>>13758000
   IF FILET <> 0 THEN                                          <<04145>>13760000
      BEGIN                                                    <<04145>>13762000
        FCLOSE(FILET,1,0);                                     <<04145>>13764000
        IF < THEN                                              <<04145>>13766000
           BEGIN    << unable to close tape file >>            <<ld.m4>>13768000
             ERRN := 51;                                       <<04145>>13770000
             FCHECK(FILET,ERRF);                               <<04145>>13772000
             GOTO ERROR;                                       <<04145>>13774000
           END;                                                <<04145>>13776000
        FILET := 0;                                            <<04145>>13778000
      END;                                                     <<04145>>13780000
   GOTO NEXT;                                                           13782000
                                                               <<01.02>>13784000
$PAGE                                                          <<04145>>13786000
<<************************ H E L P ! ***********************>> <<04145>>13788000
<< Check if MPE help facility has been requested and call   >> <<04145>>13790000
<< via MPECOMMAND.                                          >> <<04145>>13792000
<<**********************************************************>> <<04145>>13794000
                                                               <<04145>>13796000
HELPL:                                                         <<B0.00>>13798000
   IF BP = CR  THEN                                            <<04145>>13800000
   GO TO XPLAL;                                                <<B0.00>>13802000
   IF BP = "MPE" THEN                                          <<B0.00>>13804000
      BEGIN                                                    <<B0.00>>13806000
      SCAN BP(3) WHILE %6440;                                  <<B0.00>>13808000
      IF CARRY THEN                                            <<B0.00>>13810000
         BP := CR ;                                            <<04145>>13812000
      END;                                                     <<B0.00>>13814000
   MPECOMMAND(BCBUF(2));                                       <<B0.00>>13816000
   IF BP=CR  AND BP(1) ="PE" THEN                              <<04145>>13818000
      GO TO SPOOK'TITLE                                                 13820000
   ELSE                                                                 13822000
     GO TO NEXT;                                                        13824000
                                                                        13826000
<<************************** R U N *************************>> <<04145>>13828000
<< Run a user program via ATTACH.  If failed, than either   >> <<04145>>13830000
<< capabilty is illegal or program is invalid.              >> <<04145>>13832000
<<**********************************************************>> <<04145>>13834000
                                                               <<04145>>13836000
RUNL:                                                          <<B0.00>>13838000
         PROGNAME(26):=" ";                                    <<B0.00>>13840000
         MOVE PROGNAME:=BP,(26);                               <<B0.00>>13842000
         SCAN PROGNAME UNTIL %6440,1;                          <<B0.00>>13844000
         MOVE * := " ";                                        <<B0.00>>13846000
         IF PROGNAME = " " THEN                                <<B0.00>>13848000
            BEGIN                                              <<B0.00>>13850000
            ERRN := 72; GO TO ERROR; <<MISSING OPERAND>>       <<B0.00>>13852000
            END;                                               <<B0.00>>13854000
         IF PROGNAME = "*" THEN                                <<B0.00>>13856000
            MOVE PROGNAME := LASTCREATE,(27);                  <<B0.00>>13858000
         IF NOT ATTACH(PROGNAME,PIN) THEN                      <<B0.00>>13860000
           BEGIN                                               <<04145>>13862000
            IF NOT CAP2.(15:1) THEN                            <<04145>>13864000
               BEGIN    << invalid command name >>             <<ld.m4>>13866000
                 ERRN := 20;                                   <<04145>>13868000
                 WARN := 4;                                    <<04145>>13870000
                 GO TO ERROR;                                  <<04145>>13872000
               END                                             <<04145>>13874000
            ELSE                                               <<04145>>13876000
               BEGIN    << file is not program file >>         <<ld.m4>>13878000
                 ERRN := 70;                                   <<04145>>13880000
                 GO TO ERROR;                                  <<04145>>13882000
               END;                                            <<04145>>13884000
           END                                                 <<04145>>13886000
         ELSE BEGIN                                            <<04145>>13888000
              MOVE CBUF := PTITLE,2;                           <<04145>>13890000
              I := TOS - @CBUF;                                <<04145>>13892000
        MOVE BCBUF(VUUFF'COL) := OFFICIAL'VUUFF;               <<04151>>13894000
              PRINT(CBUF,I,0);                                 <<04145>>13896000
            END;                                               <<04145>>13898000
      GO TO NEXT;                                              <<B0.00>>13900000
                                                               <<B0.00>>13902000
<<************************* K I L L ! **********************>> <<04145>>13904000
<< Check if any programs being run and kill the last pin    >> <<04145>>13906000
<< number via KILL.                                         >> <<04145>>13908000
<<**********************************************************>> <<04145>>13910000
                                                               <<04145>>13912000
KILLL:                                                         <<B0.00>>13914000
   IF LASTPIN = 0 THEN                                         <<B0.00>>13916000
      BEGIN     << no son process to be deleted >>             <<ld.m4>>13918000
         ERRN :=71; GO TO ERROR;                               <<B0.00>>13920000
      END                                                      <<B0.00>>13922000
   ELSE                                                        <<B0.00>>13924000
      BEGIN                                                    <<B0.00>>13926000
      KILL(LASTPIN);                                           <<B0.00>>13928000
      LASTPIN := 0; LASTCREATE := 0;                           <<B0.00>>13930000
      END;                                                     <<B0.00>>13932000
   GO TO NEXT;                                                 <<B0.00>>13934000
                                                               <<B0.00>>13936000
<<********************** I  Q U I T ! **********************>> <<04145>>13938000
                                                               <<04145>>13940000
QUITL:                                                         <<B0.00>>13942000
   <<  TERMINATE SUBTASK>>                                     <<B0.00>>13944000
                                                               <<B0.00>>13946000
   SUBTASK := FALSE;                                           <<B0.00>>13948000
   GO TO EXITL;                                                <<B0.00>>13950000
                                                               <<B0.00>>13952000
$PAGE                                                          <<04145>>13954000
<<********************** C O P Y ***************************>> <<04145>>13956000
<< If a file was specified, then obtain the list of files   >> <<04145>>13958000
<< via GETFILES.  Move the ODD entries in.  If no files were>> <<04145>>13960000
<< specified, copy the texted file if one is texted.  If no >> <<04145>>13962000
<< copy file was specified, create another spoolfile exactly>> <<04145>>13964000
<< like the original and copy the contents of the spoolfiles>> <<04145>>13966000
<< specified into it.                                       >> <<04145>>13968000
<<**********************************************************>> <<04145>>13970000
                                                               <<04145>>13972000
COPYL:                                                         <<B0.01>>13974000
   IF BP = "END" THEN                                          <<B0.01>>13976000
     BEGIN                                                     <<B0.01>>13978000
     APPEND := FALSE;                                          <<B0.01>>13980000
      IF NEW'FILEN = 0 THEN GO TO NEXT                         <<B0.01>>13982000
      ELSE                                                     <<B0.01>>13984000
         BEGIN                                                 <<B0.01>>13986000
         IF NOT NEW'FILE'CLOSE(FALSE) THEN GO TO ERROR;        <<B0.01>>13988000
         GO TO NEXT;                                           <<B0.01>>13990000
         END;                                                  <<00897>>13992000
      END;                                                     <<00897>>13994000
   COPY'FILES'FLAG := FALSE; @FIRSTPARM := @BP;                <<00897>>13996000
   INITXDDP := -2048;                                          <<00897>>13998000
   SCAN BP UNTIL %6473;                                        <<04329>>14000000
   IF NOCARRY THEN   << CR ";">>                               <<04329>>14002000
      BEGIN                                                    <<04329>>14004000
      IF NOT GETFILES(2) THEN GO TO ERROR;                     <<00897>>14006000
      IF BP <> ";" THEN     << missing semi-colon >>           <<ld.m4>>14008000
      BEGIN ERRN := 49; GO TO ERROR ; END;                     <<00897>>14010000
      @BP := @BP + 1;                                          <<00897>>14012000
      MOVEFROMXDD;                                             <<00897>>14014000
      COPY'FILES'FLAG := TRUE; @SECONDPARM := @BP;             <<00897>>14016000
      END                                                      <<04329>>14018000
   ELSE                                                        <<00897>>14020000
      IF FILEN = 0 THEN                                        <<04329>>14022000
         BEGIN                                                 <<04329>>14024000
         ERRN := 46;               << No text file          >> <<04329>>14026000
         GO TO ERROR;              << Aren't GO TO's ugly?  >> <<04329>>14028000
         END                                                   <<04329>>14030000
      ELSE                                                     <<04329>>14032000
        FILE'FOUND := TRUE;        << File exists.          >> <<04329>>14034000
                                                               <<04329>>14036000
   IF NOT COPY'FILES'FLAG THEN                                 <<00897>>14038000
   BEGIN                                                       <<00897>>14040000
      XDDC := 1;                                               <<00897>>14042000
      @BP := @FIRSTPARM;                                       <<00897>>14044000
      @SECONDPARM := @FIRSTPARM;                               <<00897>>14046000
   END;                                                        <<00897>>14048000
                                                               <<04145>>14050000
   <<*******************************************************>> <<04145>>14052000
   << Copy the files via COPY'FILES and show any error that >> <<04145>>14054000
   << occured via SHOWERRORS.                               >> <<04145>>14056000
   <<*******************************************************>> <<04145>>14058000
                                                               <<04145>>14060000
   IF FILE'FOUND THEN                                          <<04145>>14062000
      IF NOT COPY'FILES THEN GO TO ERROR;                      <<04145>>14064000
   APPEND:= FALSE;                                             <<B0.01>>14066000
   IF COPY'FILES'FLAG                                          <<04329>>14068000
      THEN SHOWERRORS(FALSE);                                  <<04329>>14070000
   COPY'FILES'FLAG := FALSE;                                   <<04329>>14072000
   GO TO NEXT;                                                 <<B0.01>>14074000
                                                               <<B0.01>>14076000
                                                               <<B0.01>>14078000
APPENDL:                                                       <<B0.01>>14080000
   APPEND := TRUE;                                             <<B0.01>>14082000
   GO TO COPYL;                                                <<B0.01>>14084000
                                                                        14086000
                                                                        14088000
FIN:                                                                    14090000
   XCONTRAP(CYOLD,CYLABEL);                                             14092000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>14094000
                                                                        14096000
                                                                        14098000
END.                                                                    14100000
