$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 = ("SPOOK V.UU.FF  (C) HEWLETT-PACKARD CO., 1976")#;    <<04151>>00100000
EQUATE VUUFF'COL = 6;  << Index into PTITLE for V.UU.FF     >> <<04151>>00102000
$INCLUDE INCLVUF                                               <<04151>>00104000
                                                                        00106000
<<GLOBAL DECLARATIONS>>                                                 00108000
EQUATE                                                                  00110000
   NO'FILE'ERROR = -1,                                         <<04145>>00112000
   CR            = %15,                                        <<04145>>00114000
   EXITINSTR = %031400 ,                                       <<B0.01>>00116000
   LPDTDST= 13 ,                                                        00118000
   LDTDST = 14 ,                                                        00120000
   IDDDST = 45 ,                                                        00122000
   ODDDST = 46 ,                                                        00124000
   LPDTSIR=  9 ,                                                        00126000
   LDTSIR = 10 ,                                                        00128000
   IDDSIR =  3 ,                                                        00130000
   ODDSIR =  4 ;                                                        00132000
DEFINE INTRINS = INTRWORD.(0:10)#,                             <<B0.00>>00134000
      NUMPARMS = INTRWORD.(10:6)#;                             <<B0.00>>00136000
INTEGER X=X;                                                            00138000
INTEGER S0=S-0;                                                         00140000
LOGICAL LS0=S-0;                                                        00142000
INTEGER POINTER PS0=S-0;                                                00144000
BYTE POINTER BPS0=S-0;                                                  00146000
ARRAY BASE(*)=DB+0;                                                     00148000
                                                                        00150000
<<GENERAL>>                                                             00152000
INTEGER I,COUNT,CNT,J;                                                  00154000
LOGICAL CARRYF;                                                         00156000
                                                                        00158000
<<CONTROL Y>>                                                           00160000
INTEGER CYLABEL,CYOLD,CYADDR;                                           00162000
INTEGER SVAL,QVAL,STATVAL;                                              00164000
INTEGER DELTAP=Q-2,QMSTAT=Q-1,DELTAQ=Q-0;                               00166000
LOGICAL CRITFLAG,CONTROLYFLAG,                                 <<04145>>00168000
   FILE'FOUND;     << At least one DEV File found in command>> <<04145>>00170000
                                                               <<B0.00>>00172000
<< SUBTASKING INTERFACE >>                                     <<B0.00>>00174000
INTEGER PIN:=0,LASTPIN:=0,PINOFFATHER:=0;                      <<B0.00>>00176000
DOUBLE FATHERINFO;                                             <<B0.00>>00178000
BYTE ARRAY PROGNAME(0:26);                                     <<B0.00>>00180000
BYTE ARRAY LASTCREATE(0:26);                                   <<B0.00>>00182000
LOGICAL SUBTASK:=FALSE;                                        <<B0.00>>00184000
INTEGER SUBTASK'LEVEL := 0,SUBLEVEL = Q-4;                     <<B0.00>>00186000
INTEGER INTRWORD;                                              <<B0.00>>00188000
INTEGER FATHERINFO0=FATHERINFO;                                <<B0.01>>00190000
INTEGER FATHERINFO1=FATHERINFO0+1;                             <<B0.01>>00192000
<<                      >>                                     <<B0.00>>00194000
                                                                        00196000
<<USER ATTRIBUTES>>                                                     00198000
INTEGER MODE,LDEV;                                                      00200000
DOUBLE  CAP,LAT;                                                        00202000
LOGICAL CAP1=CAP,CAP2=CAP+1;                                            00204000
ARRAY NAMES(0:15);                                                      00206000
BYTE ARRAY BNAMES(*)=NAMES;                                             00208000
BYTE ARRAY USERN(*)=NAMES(0),                                           00210000
           ACCTN(*)=NAMES(4),                                           00212000
           GROUPN(*)=NAMES(8),                                          00214000
           HOMEN(*)=NAMES(12);                                          00216000
                                                                        00218000
<<MODES>>                                                               00220000
LOGICAL FALL;                                                           00222000
INTEGER FWIDTH;                                                         00224000
                                                                        00226000
<<ALTER>>                                                               00228000
INTEGER PRI,COPIES,CLDEV;                                               00230000
                                                                        00232000
<<COMMANDS AND XDD MGMT>>                                               00234000
INTEGER OLDSIR,CRIT,ERRN,WARN,ERRF;                                     00236000
INTEGER INITXDDP;                                                       00238000
INTEGER XDDX,XDDC,DEVF,DEVFC,FILEF;                                     00240000
LOGICAL USERF,ACCTF;                                                    00242000
LOGICAL SHOWIO,SHOWF,SHOWP;                                             00244000
ARRAY SNAMES(0:7);                                                      00246000
BYTE ARRAY SUSERN(*)=SNAMES(0),                                         00248000
           SACCTN(*)=SNAMES(4);                                         00250000
                                                                        00252000
<<SPOOL FILE MGMT>>                                                     00254000
INTEGER FILEN,XDDN,DEVFN;                                               00256000
INTEGER FLINECNT;                                                       00258000
INTEGER ODDN;      <<01.02>>                                   <<01.02>>00260000
DOUBLE SBLINE;                                                          00262000
DOUBLE FLINE,EOFLINE;                                                   00264000
LOGICAL PURGEFLAG;  <<USED FOR OUTPUT>>                       <<00204>> 00266000
DOUBLE START'RECNUM; <<BEGINNING RECORD NUMBER OF FILE>>     <<<<01549>>00268000
                  <<MAY BE NON-ZERO IN EXTENT PURGED CASE>>  <<<<01549>>00270000
                                                                        00272000
<<SPOOL FILE SCAN/LIST>>                                                00274000
DOUBLE FRLINE,TOLINE,LINECNT;                                           00276000
DOUBLE DNUM;                                                            00278000
INTEGER DNUM0=DNUM+0,DNUM1=DNUM+1;                                      00280000
INTEGER FSTRING;                                                        00282000
LOGICAL FSTRALL;                                                        00284000
LOGICAL EOFFLAG;                                               <<B0.01>>00286000
ARRAY FSTR(0:40);                                                       00288000
BYTE ARRAY BFSTR(*)=FSTR;                                               00290000
BYTE POINTER                                                   <<00897>>00292000
     FIRSTPARM,                                                <<00897>>00294000
     SECONDPARM,                                               <<00897>>00296000
     THIRDPARM;                                                <<00897>>00298000
BYTE POINTER FBP;                                                       00300000
EQUATE BENTRIES = 10, BENTRY'SIZE=5;                           <<B0.01>>00302000
ARRAY BLOCKTABLE(0:BENTRIES * BENTRY'SIZE);                    <<B0.01>>00304000
INTEGER POINTER BLOCKCP,BLOCKFP;  <<CURRENT,FIRST POINTER>>    <<B0.01>>00306000
DOUBLE POINTER DBLOCKFP = BLOCKFP;                             <<B0.01>>00308000
DOUBLE POINTER DBLOCKCP=BLOCKCP;                               <<B0.01>>00310000
LOGICAL READ'DIR'FLAG;                                         <<B0.01>>00312000
DOUBLE BLOCKNO;                                                <<B0.01>>00314000
<<NOTE EACH BLOCKTABLE ENTRY IS >>                             <<B0.01>>00316000
<<      BLOCKCOUNT      (DOUBLEWORD)>>                         <<B0.01>>00318000
<<      RECORDCOUNT     (DOUBLEWORD)>>                         <<B0.01>>00320000
<<      PAGECOUNT       (DOUBLEWORD)>>                         <<B0.01>>00322000
                                                                        00324000
<<COPY SPOOLFILE VARIABLES>>                                   <<B0.01>>00326000
INTEGER                                                        <<B0.01>>00328000
        NEW'FILEN,                                             <<B0.01>>00330000
        NEW'NUMBUFS,                                           <<B0.01>>00332000
        NEW'FOPTIONS,                                          <<B0.01>>00334000
        NEW'OUTPRI,                                            <<B0.01>>00336000
        NEW'COPIES,                                            <<B0.01>>00338000
        NEW'AOPTIONS,                                          <<B0.01>>00340000
        NEW'RECSIZE,                                           <<B0.01>>00342000
        NEW'DFID,                                              <<B0.01>>00344000
        NEW'BLOCKSIZE,                                         <<B0.01>>00346000
        NEW'DEVTYPE,                                           <<B0.01>>00348000
        NEW'LDEV,                                              <<B0.01>>00350000
        NEW'HDADDR,                                            <<B0.01>>00352000
        NEW'XDDN,                                              <<B0.01>>00354000
        OLD'PRI,                                               <<B0.01>>00356000
        FOPEN'COUNT,                                           <<B0.01>>00358000
        FOPEN'COUNT'LAST,                                      <<B0.01>>00360000
        FOPEN'COPIED                                           <<B0.01>>00362000
                                                               <<B0.01>>00364000
                    ;                                          <<B0.01>>00366000
LOGICAL                                                        <<B0.01>>00368000
         COPY'FILES'FLAG,                                      <<00897>>00370000
         INHIBIT'FOPEN,                                        <<01726>>00372000
        NEW'SPOOLFILE,                                         <<B0.01>>00374000
        NEW'CLOSE,                                             <<B0.01>>00376000
        FILE'FORMSMSG ,                                        <<B0.01>>00378000
        REMOTE'FILE,                                                    00380000
        APPEND                                                 <<B0.01>>00382000
                ;                                              <<B0.01>>00384000
                                                               <<B0.01>>00386000
                                                               <<B0.01>>00388000
INTEGER ARRAY NEW'BUFW(0:128);                                 <<B0.01>>00390000
                                                               <<B0.01>>00392000
BYTE ARRAY NEW'BUF(*) = NEW'BUFW;                              <<B0.01>>00394000
                                                               <<B0.01>>00396000
BYTE ARRAY                                                     <<B0.01>>00398000
         NEW'ENV(0:36),                                        <<01886>>00400000
        NEW'FILENAME(0:28),                                    <<B0.01>>00402000
        OLD'FILENAME(0:28),                                    <<B0.01>>00404000
        FOPEN'RECORD(0:256),                                   <<B0.01>>00406000
        NEW'DEVICE(0:8);                                       <<B0.01>>00408000
                                                               <<B0.01>>00410000
DOUBLE                                                         <<B0.01>>00412000
        NEW'LABADDR;                                           <<B0.01>>00414000
INTEGER POINTER NEW'XDDNP = NEW'XDDN;                          <<B0.01>>00416000
EQUATE                                                         <<B0.01>>00418000
        COPY = 2;                                              <<B0.01>>00420000
DEFINE  CCTLOPTION = LOGICAL(NEW'FOPTIONS.(7:1))#;   <<B0.01>> <<B0.01>>00422000
DEFINE NOCCTL'INPUT = LOGICAL(SP(3) = 0 LAND SP(2) = 1)#;      <<B0.01>>00424000
                      <<END OF COPY VARIABLES>>                <<B0.01>>00426000
<<TAPE FILE MANAGEMENT>>                                                00428000
INTEGER FILET,TCOUNT,REEL;                                              00430000
LOGICAL LASTREEL,EOTMARK,FILEEND;                                       00432000
DOUBLE TIME;                                                            00434000
LOGICAL DATE,TIME1=TIME+0,TIME2=TIME+1;                                 00436000
                                                                        00438000
                                                                        00440000
<<COMMAND BUFFER>>                                                      00442000
EQUATE COMMAND'LENGTH = 40;                                    <<B0.00>>00444000
ARRAY CBUF(0:COMMAND'LENGTH);                                  <<B0.00>>00446000
BYTE ARRAY BCBUF(*)=CBUF;                                               00448000
BYTE POINTER BP;                                                        00450000
                                                                        00452000
<<XDD BUFFER>>                                                          00454000
ARRAY DEVFS(0:63);                                                      00456000
ARRAY XDD(0:29);                                                        00458000
BYTE ARRAY BXDD(*)=XDD;                                                 00460000
DEFINE XD'DFID        =    18   #;                             <<00897>>00462000
                                                                        00464000
<<LIST OUTPUT BUFFER>>                                                  00466000
ARRAY OBUF(0:127);                                                      00468000
BYTE ARRAY BOBUF(*)=OBUF;                                               00470000
                                                                        00472000
<<SPOOLFILE BUFFERS>>                                                   00474000
ARRAY SBUF(0:1024);                                                     00476000
BYTE ARRAY BSBUF(*)=SBUF;                                               00478000
POINTER SP;                                                             00480000
                                                                        00482000
<<TAPE LABEL BUFFER>>                                                   00484000
ARRAY TBUF(0:40);                                                       00486000
BYTE ARRAY BTBUF(*)=TBUF;                                               00488000
                                                                        00490000
<<TAPE REPLY BUFFER>>                                                   00492000
ARRAY RBUF(0:1);                                                        00494000
BYTE ARRAY BRBUF(*)=RBUF;                                               00496000
                                                                        00498000
                                                                        00500000
<<COMMANDS>>                                                            00502000
EQUATE CNUM = 18;                                              <<B0.01>>00504000
EQUATE CSIZE=6;                                                         00506000
BYTE ARRAY COMMAND'LIST(0:CNUM*CSIZE-1):=                      <<B0.00>>00508000
      "DEBUG EXIT  XPLAINSHOW  ",                                       00510000
      "TEXT  LIST  FIND  MODE  ",                                       00512000
      "ALTER PURGE INPUT OUTPUT",                              <<B0.00>>00514000
      "HELP  RUN   KILL  QUIT  ",                              <<B0.01>>00516000
      "COPY  APPEND";                                          <<B0.01>>00518000
                                                                        00520000
<<MODES>>                                                               00522000
EQUATE MNUM=2;                                                          00524000
EQUATE MSIZE=8;                                                         00526000
BYTE ARRAY MMODE(0:15):=                                                00528000
      "WIDTH   CONTROLS";                                               00530000
                                                                        00532000
<<ALTER>>                                                               00534000
EQUATE ANUM=3;                                                          00536000
EQUATE ASIZE=6;                                                         00538000
BYTE ARRAY AALTER(0:ANUM * ASIZE - 1):=                        <<B0.00>>00540000
      "PRI   COPIESDEV   ";                                             00542000
                                                                        00544000
<<STATES>>                                                              00546000
BYTE ARRAY STATES(0:23):=                                               00548000
      "ACTIVEREADY OPEN  LOCKED";                                       00550000
                                                                        00552000
<<HEADINGS>>                                                            00554000
                                                               <<01.02>>00556000
                                                               <<01.02>>00558000
ARRAY TAPEID(0:13):=                                                    00560000
      "SPOOLFILETAPE LABEL-HP/3000.";                                   00562000
ARRAY MREEL(0:16):=                                                     00564000
      " CHANGE REELS ON LDEV     ? (Y/N) ";                             00566000
ARRAY EREEL(0:17):=                                                     00568000
      " INCORRECT REEL - TRY AGAIN ? (Y/N) ";                           00570000
ARRAY MSHOW(0:28):=                                                     00572000
      "#FILE   #JOB    FNAME    STATE  DEV/CL   PR COP RFN OWNER ";     00574000
ARRAY MSHOWS(0:18):=                                                    00576000
      "#FILE   #JOB    FNAME    STATE  OWNER ";                         00578000
ARRAY MIN(0:22):=                                                       00580000
      "#FILE   ===>  #FILE   #JOB    DEV/CL    OWNER ";                 00582000
ARRAY MOUT(0:21):=                                                      00584000
      "#FILE   #JOB    DEV/CL   SECTORS      OWNER ";                   00586000
ARRAY MSHWX(0:28):=                                                     00588000
      "#FILE   LDEV    LABEL      SECTORS       LINES      TIME  ";     00590000
                                                                        00592000
SWITCH SWCOM:=                                                          00594000
      DBUGL,                                                            00596000
      EXITL,                                                            00598000
      XPLAL,                                                            00600000
      SHOWL,                                                            00602000
      TEXTL,                                                            00604000
      LISTL,                                                            00606000
      FINDL,                                                            00608000
      MODEL,                                                            00610000
      ALTEL,                                                            00612000
      PURGL,                                                            00614000
      INL  ,                                                            00616000
      OUTL ,                                                   <<B0.00>>00618000
      HELPL,                                                   <<B0.00>>00620000
      RUNL ,                                                   <<B0.00>>00622000
      KILLL,                                                   <<B0.00>>00624000
      QUITL,                                                   <<B0.01>>00626000
      COPYL,                                                   <<B0.01>>00628000
      APPENDL;                                                 <<B0.01>>00630000
                                                                        00632000
DEFINE DEF'MOVEFROMDSEG=                                       <<01726>>00634000
MOVEFROMDSEG(TARGET,DSTN,OFFSET,COUNT);                        <<01726>>00636000
VALUE TARGET,DSTN,OFFSET,COUNT;                                <<01726>>00638000
LOGICAL TARGET,DSTN,OFFSET,COUNT;                              <<01726>>00640000
BEGIN                                                          <<01726>>00642000
   X:=TOS;     <<SAVE RETURN ADDR>>                            <<01726>>00644000
   ASSEMBLE(MFDS 0);                                           <<01726>>00646000
   TOS:=X;     <<RESTORE RETURN ADDR>>                         <<01726>>00648000
END#,                                                          <<01726>>00650000
                                                               <<01726>>00652000
       DEF'MOVETODSEG=                                         <<01726>>00654000
MOVETODSEG(DSTN,OFFSET,SOURCE,COUNT);                          <<01726>>00656000
VALUE DSTN,OFFSET,SOURCE,COUNT;                                <<01726>>00658000
LOGICAL DSTN,OFFSET,SOURCE,COUNT;                              <<01726>>00660000
BEGIN                                                          <<01726>>00662000
   X:=TOS;                                                     <<01726>>00664000
   ASSEMBLE(MTDS 0);                                           <<01726>>00666000
   TOS:=X;     <<RESTORE RETURN ADDR>>                         <<01726>>00668000
END#;                                                          <<01726>>00670000
                                                               <<01726>>00672000
$PAGE                                                          <<04145>>00674000
                                                               <<04145>>00676000
<<**********************************************************>> <<04145>>00678000
<<    EXPLANATION OF IMPORTANT GLOBAL VARIABLES             >> <<04145>>00680000
<<                                                          >> <<04145>>00682000
<<  DEVF - Device file ID, If the 1st. bit is on, then it is>> <<04145>>00684000
<<         an OUTPUT file, off and INPUT file.  ID number   >> <<04145>>00686000
<<         is the integer portion.                          >> <<04145>>00688000
<<  DEVFN- Currently texted file number.                    >> <<04145>>00690000
<<  FILEN-                                                  >> <<04145>>00692000
<<  DEVFS- Logical array containing all the Device File ID's>> <<04145>>00694000
<<         to be used for the current command.              >> <<04145>>00696000
<<  DEVFC- Number of Device File ID's in the array DEVFS for>> <<04145>>00698000
<<         the current command.                             >> <<04145>>00700000
<< SHOWIO- An integer to show which types of Device ID's we >> <<04145>>00702000
<<         have encountered .  If bit 15=on Output and/or   >> <<04145>>00704000
<<                                    14=on Input           >> <<04145>>00706000
<<  SHOWF- Flag signifying to show all the file information,>> <<04145>>00708000
<<         eg. show PRI, COP, LDEV, etc.                    >> <<04145>>00710000
<<**********************************************************>> <<04145>>00712000
                                                               <<04145>>00714000
<<**********************************************************>> <<04145>>00716000
                                                               <<04145>>00718000
$PAGE                                                                   00720000
                                                                        00722000
PROCEDURE CONTROLYPROC;                                        <<B0.00>>00724000
   OPTION FORWARD;                                             <<B0.00>>00726000
PROCEDURE DEBUG;                                                        00728000
   OPTION EXTERNAL;                                                     00730000
INTEGER PROCEDURE SETCRITICAL;                                          00732000
   OPTION EXTERNAL;                                                     00734000
PROCEDURE RESETCRITICAL(C);                                             00736000
   VALUE   C;                                                           00738000
   INTEGER C;                                                           00740000
   OPTION EXTERNAL;                                                     00742000
INTEGER PROCEDURE GETSIR(S);                                            00744000
   VALUE   S;                                                           00746000
   INTEGER S;                                                           00748000
   OPTION EXTERNAL;                                                     00750000
PROCEDURE RELSIR(S,R);                                                  00752000
   VALUE   S,R;                                                         00754000
   INTEGER S,R;                                                         00756000
   OPTION EXTERNAL;                                                     00758000
INTEGER PROCEDURE EXCHANGEDB(D);                                        00760000
   VALUE   D;                                                           00762000
   INTEGER D;                                                           00764000
   OPTION EXTERNAL;                                                     00766000
LOGICAL PROCEDURE CALENDAR;                                             00768000
   OPTION EXTERNAL;                                                     00770000
DOUBLE PROCEDURE CLOCK;                                                 00772000
   OPTION EXTERNAL;                                                     00774000
INTEGER PROCEDURE GETDEVINFO(D,I);                                      00776000
   INTEGER ARRAY I;                                                     00778000
   BYTE ARRAY D;                                                        00780000
   OPTION EXTERNAL;                                                     00782000
LOGICAL PROCEDURE SPOOLEDDEV(D);                                        00784000
   VALUE   D;                                                           00786000
   INTEGER D;                                                           00788000
   OPTION EXTERNAL;                                                     00790000
PROCEDURE SROOSTER(D);                                                  00792000
   VALUE   D;                                                           00794000
   INTEGER D;                                                           00796000
   OPTION EXTERNAL;                                                     00798000
PROCEDURE SRELINKODD(O,D);                                              00800000
   VALUE   O,D;                                                         00802000
   INTEGER D;                                                           00804000
   INTEGER POINTER O;                                                   00806000
   OPTION EXTERNAL;                                                     00808000
INTEGER PROCEDURE SPUTXDD(ODD,DEV,SUBE,XDDSUBP);                        00810000
   VALUE   ODD,DEV;                                                     00812000
   LOGICAL ODD;                                                         00814000
   INTEGER DEV;                                                         00816000
   INTEGER ARRAY SUBE;                                                  00818000
   INTEGER POINTER XDDSUBP;                                             00820000
   OPTION EXTERNAL;                                                     00822000
PROCEDURE SREMOVEXDD(XDDSUBP);                                          00824000
   VALUE   XDDSUBP;                                                     00826000
   INTEGER POINTER XDDSUBP;                                             00828000
   OPTION EXTERNAL;                                                     00830000
INTEGER PROCEDURE FSOPEN(FD,FO,AO,XD,DV,FM,UL,BF,NB,                    00832000
                           FS,NE,IA,FC);                                00834000
   VALUE   FO,AO,XD,UL,BF,NB,FS,NE,IA,FC;                               00836000
   INTEGER XD,UL,BF,NB,NE,IA,FC;                                        00838000
   LOGICAL FO,AO;                                                       00840000
   DOUBLE  FS;                                                          00842000
   BYTE ARRAY FD,DV,FM;                                                 00844000
   OPTION EXTERNAL,VARIABLE;                                            00846000
PROCEDURE FSCLOSE(FN,D,S);                                              00848000
   VALUE   FN,D,S;                                                      00850000
   INTEGER FN,D,S;                                                      00852000
   OPTION EXTERNAL;                                                     00854000
PROCEDURE ERRORON;                                             <<B0.00>>00856000
   OPTION EXTERNAL;                                            <<B0.00>>00858000
PROCEDURE ERROREXIT(INTRINEXIT,ERRWORD,PARAM);                 <<B0.00>>00860000
   VALUE INTRINEXIT,ERRWORD,PARAM;                             <<B0.00>>00862000
   LOGICAL INTRINEXIT,ERRWORD,PARAM;                           <<B0.00>>00864000
   OPTION EXTERNAL;                                            <<B0.00>>00866000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,M,P1,P2,P3,P4,P5,         <<B0.00>>00868000
         D,R,O,DST,C);                                         <<B0.00>>00870000
   VALUE SETNO,MSGNO,M,P1,P2,P3,P4,P5,D,R,O,DST,C;             <<B0.00>>00872000
   INTEGER SETNO,MSGNO,D,DST;                                  <<B0.00>>00874000
   LOGICAL M,P1,P2,P3,P4,P5,R,O,C;                             <<B0.00>>00876000
   OPTION EXTERNAL,VARIABLE;                                   <<B0.00>>00878000
LOGICAL PROCEDURE NEW'FILE'CLOSE(OLD);                         <<B0.01>>00880000
   VALUE OLD;                                                  <<B0.01>>00882000
   LOGICAL OLD;                                                <<B0.01>>00884000
   OPTION FORWARD;                                             <<B0.01>>00886000
                                                               <<B0.01>>00888000
LOGICAL PROCEDURE SFINDODD(DFID,XDDEP);                        <<B0.01>>00890000
   VALUE DFID;                                                 <<B0.01>>00892000
   INTEGER XDDEP;                                              <<B0.01>>00894000
   INTEGER DFID;                                               <<B0.01>>00896000
   OPTION EXTERNAL;                                            <<B0.01>>00898000
                                                               <<B0.01>>00900000
                                                               <<B0.00>>00902000
LOGICAL PROCEDURE VERIFY'BLOCK'STRUCTURE(BUFFER,INDEX,NUMRECS);<<01726>>00904000
                                                              <<SP.MP4>>00906000
   LOGICAL ARRAY BUFFER;                                      <<SP.MP4>>00908000
   INTEGER INDEX,NUMRECS;                                     <<SP.MP4>>00910000
                                                              <<SP.MP4>>00912000
   OPTION FORWARD;                                             <<01726>>00914000
                                                               <<01726>>00916000
   PROCEDURE READ'RECORD(FILENUM, RECORDNUM, BUFFER, RECP,     <<01726>>00918000
        XDDP,BLOCKNUM, ERRNUM);                                <<01726>>00920000
                                                               <<01726>>00922000
      VALUE RECORDNUM, FILENUM, XDDP;                          <<01726>>00924000
      DOUBLE RECORDNUM, BLOCKNUM;                              <<01726>>00926000
      INTEGER POINTER RECP;                                    <<01726>>00928000
      LOGICAL XDDP;                                            <<01726>>00930000
      INTEGER ERRNUM, FILENUM;                                 <<01726>>00932000
      LOGICAL ARRAY BUFFER;                                    <<01726>>00934000
                                                               <<01726>>00936000
      OPTION FORWARD;                                          <<01726>>00938000
                                                                        00940000
INTRINSIC FOPEN,FCLOSE,FREAD,FWRITE,FCONTROL,FGETINFO,FCHECK;           00942000
INTRINSIC WHO,DLSIZE,READ,PRINT,ASCII,BINARY,PRINTOPREPLY;              00944000
INTRINSIC DASCII,DBINARY;                                               00946000
INTRINSIC XCONTRAP,RESETCONTROL,FERRMSG,FFILEINFO,TERMINATE;   <<04145>>00948000
INTRINSIC ARITRAP;                                             <<01.02>>00950000
                                                                        00952000
INTRINSIC CREATE,FATHER,KILL,ACTIVATE,SUSPEND; <<SUBTASKING>>  <<B0.00>>00954000
INTRINSIC GETPROCID,GETPROCINFO; <<SUBTASKING>>                <<B0.01>>00956000
INTRINSIC COMMAND;                                             <<B0.00>>00958000
INTRINSIC FREADDIR;                                            <<B0.01>>00960000
INTRINSIC FWRITEDIR;                                           <<B0.01>>00962000
INTRINSIC FRENAME;                                             <<B0.01>>00964000
INTRINSIC FFILEINFO;                                           <<01607>>00966000
INTRINSIC FREADLABEL, FWRITELABEL;                             <<01886>>00968000
$PAGE                                                                   00970000
$CONTROL SEGMENT=SPOOK1                                                 00972000
                                                                        00974000
PROCEDURE ERRFORM(ERR,FERR,IX);                                         00976000
   VALUE   ERR,FERR;                                                    00978000
   INTEGER ERR,FERR,IX;                                                 00980000
   BEGIN                                                                00982000
   INTEGER CT,IZ,BEG'MSG;                                      <<04145>>00984000
   LOGICAL F;                                                           00986000
   INTEGER ARRAY MESSAG(*) = PB :=                             <<04151>>00988000
       1,12,"NOT INTERACTIVE SESSION ",                                 00990000
       2, 6,"END OF FILE",                                              00992000
       3, 7,"TOO MANY FILES",                                           00994000
       4,12,"INSUFFICIENT CAPABILITY ",                                 00996000
       5,22,"NO FILES FOUND UNDER USER.ACCOUNT SPECIFIED ",    <<04145>>00998000
      19,13,"IMPOSSIBLE INTERNAL ERROR ",                               01000000
      20,10,"INVALID COMMAND NAME",                                     01002000
      21,10,"COMMAND NAME TOO BIG",                                     01004000
      22, 8,"PROMPT I/O ERROR",                                         01006000
      23, 8,"INPUT I/O ERROR ",                                         01008000
      24,10,"UNABLE TO CLOSE FILE",                                     01010000
      25,10,"UNABLE TO PURGE FILE",                                     01012000
      26, 8,"FILE READ ERROR ",                                         01014000
      27, 8,"FILE WRITE ERROR",                                         01016000
      28, 8,"FILE NOT 'READY'",                                         01018000
      29,10,"UNABLE TO OPEN FILE ",                                     01020000
      30,11,"INPUT FILE NOT ALLOWED",                                   01022000
      31, 7,"FILE NOT FOUND",                                           01024000
      32, 8,"INVALID FILE ID ",                                         01026000
      33,10,"UNEXPECTED CHARACTER",                                     01028000
      34, 9,"USER NAME TOO BIG ",                                       01030000
      35,10,"USER NOT ACCESSIBLE ",                                     01032000
      36,10,"ACCOUNT NAME TOO BIG",                                     01034000
      37,11,"ACCOUNT NOT ACCESSIBLE",                                   01036000
      38,11,"INVALID LINE MNEMONIC ",                                   01038000
      39,10,"INVALID LINE NUMBER ",                                     01040000
      40, 9,"INVALID LINE COUNT",                                       01042000
      41, 9,"INVALID LINE RANGE",                                       01044000
      42,16,"NON TERMINATED CHARACTER STRING ",                         01046000
      43,10,"INVALID OPTION NAME ",                                     01048000
      44,12,"INVALID OPTION SEPARATOR",                                 01050000
      45,12,"INVALID OPTION PARAMETER",                                 01052000
      46, 6,"NO TEXT FILE",                                             01054000
      47,11,"FILE NOT 'READY/OPEN' ",                                   01056000
      48,11,"TEXT FILE NOT ALLOWED ",                                   01058000
      49, 9,"MISSING SEMI-COLON",                                       01060000
      50,12,"UNABLE TO OPEN TAPE FILE",                                 01062000
      51,13,"UNABLE TO CLOSE TAPE FILE ",                               01064000
      52, 9,"INVALID TAPE FILE ",                                       01066000
      53,10,"INVALID TAPE FORMAT ",                                     01068000
      54,10,"TAPE FILE READ ERROR",                                     01070000
      55,11,"TAPE FILE WRITE ERROR ",                                   01072000
      56,12,"USER.ACCOUNT NOT ALLOWED",                                 01074000
      57,10,"NO EQUIVALENT DEVICE",                                     01076000
      58,10,"NO EQUIVALENT CLASS ",                                     01078000
      59,12,"NO ROOM IN DEVICE TABLE ",                                 01080000
      60, 8,"MULTI REEL ABORT",                                         01082000
      61,19,"INVALID LENGTH OF RECORD IN TEXT FILE",           <<B0.00>>01084000
      70,12,"FILE IS NOT PROGRAM FILE",                        <<B0.00>>01086000
      71,14,"NO SON PROCESS TO BE DELETED",                    <<B0.00>>01088000
      72,13,"MISSING PROGRAM FILE NAME ",                      <<B0.00>>01090000
      73,13,"UNABLE TO CLOSE COPY FILE",                       <<B0.01>>01092000
      74,13,"UNABLE TO OPEN COPY FILE ",                       <<B0.01>>01094000
      75,11,"SPOOLFILE CREATE ERROR",                          <<B0.01>>01096000
      76,13,"UNABLE TO RENAME COPY FILE",                      <<B0.01>>01098000
   77,13,"DS COPY NOT YET AVAILABLE",                                   01100000
      78,16,"LINE NUMBER IS IN PURGED EXTENT",               <<<<01549>>01102000
      79,9,"INVALID COPY FILE",                                <<04145>>01104000
      80,14,"MISSING DFID OR USER.ACCOUNT",                    <<04145>>01106000
       0, 0;                                                            01108000
   << >>                                                                01110000
   IF (F := (ERR < 0)) THEN ERR := -ERR;                                01112000
   IF ERR < 16 THEN                                                     01114000
      BEGIN MOVE BOBUF(IX) := "*WARNING="; IX:=IX+9; END                01116000
   ELSE                                                                 01118000
      BEGIN MOVE BOBUF(IX) := "*ERROR="; IX:=IX+7; END;                 01120000
   CT := ASCII(ERR,10,BOBUF(IX));                                       01122000
   IX := IX+CT;                                                         01124000
   IF F AND ERR >= 16 THEN                                              01126000
      BEGIN                                                             01128000
      MOVE BOBUF(IX) := " BYTE=";                                       01130000
      IX := IX+6;                                                       01132000
      CT := ASCII(@BP-@BCBUF(2),10,BOBUF(IX));                          01134000
      IX := IX+CT;                                                      01136000
      END;                                                              01138000
   BOBUF(IX) := "*";                                                    01140000
   IX := (IX+3)&ASR(1);                                                 01142000
   IZ := 0;                                                             01144000
   WHILE MESSAG(IZ)<>0 AND MESSAG(IZ)<>ERR DO                           01146000
      IZ := IZ+2+MESSAG(IZ+1);                                          01148000
   MOVE OBUF(IX) := MESSAG(IZ+2),(MESSAG(IZ+1));                        01150000
   BEG'MSG:=IX;                                                <<04145>>01152000
   IX := IX+MESSAG(IZ+1);                                               01154000
   IX := IX&ASL(1);                                                     01156000
   PRINT(OBUF,-IX,0);                                          <<04145>>01158000
   IF FERR <> NO'FILE'ERROR THEN                               <<04145>>01160000
      BEGIN                                                             01162000
        MOVE BOBUF(0):=" ";                                    <<04145>>01164000
        MOVE BOBUF(1):=BOBUF(0),(254);                         <<04145>>01166000
        FERRMSG(FERR,OBUF(0),CT);                              <<04329>>01168000
        IX:=CT ;                                               <<04329>>01170000
        PRINT(OBUF,-IX,0);                                     <<04145>>01172000
      END;                                                              01174000
   END;                                                                 01176000
                                                                        01178000
$CONTROL SEGMENT=SPOOK1                                                 01180000
                                                                        01182000
PROCEDURE ERRMSG(ERR,FERR);                                             01184000
   VALUE   ERR,FERR;                                                    01186000
   INTEGER ERR,FERR;                                                    01188000
   BEGIN                                                                01190000
   INTEGER IX;                                                          01192000
   << >>                                                                01194000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>01196000
   OBUF := "  ";                                                        01198000
   MOVE OBUF(1) := OBUF,(127);                                          01200000
   IX := 0;                                                             01202000
   ERRFORM(-ERR,FERR,IX);                                               01204000
   CRITFLAG := TRUE;                                           <<B0.00>>01208000
   END;                                                                 01210000
                                                                        01212000
$CONTROL SEGMENT=SPOOK1                                                 01214000
                                                                        01216000
PROCEDURE EXPLAIN;                                                      01218000
   BEGIN                                                                01220000
   INTEGER IX,IZ;                                                       01222000
   LOGICAL F;                                                           01224000
   INTEGER ARRAY XMESSAG(*)=PB:=                               <<04151>>01226000
    %400, 3,"DEBUG ",                                                   01228000
       1,21,"EXIT  <<TERMINATE IF NOT A SON PROCESS>> ",       <<B0.00>>01230000
       2, 3,"XPLAIN",                                                   01232000
       3,23,"SHOW   [ USER [ .ACCOUNT ] ] [ ; [@] [I] [O] ]",           01234000
       3,21,"SHOW   DEVICEFILEID [ , DEVICEFILEID ]....",               01236000
       4,10,"TEXT   DEVICEFILEID ",                                     01238000
       5, 8,"LIST   [ RANGE ]",                                         01240000
       6,20,"FIND   [ @ ] [ ""STRING"" ] [ , FRANGE ] ",       <<04145>>01242000
       7,16,"MODE   [ OPTION [ , OPTION ]...]",                         01244000
       7,16,"       OPTION = WIDTH / CONTROLS",                         01246000
     %10,28,"ALTER {DFID [,DFID[,...]]} [ ; OPTION [ , OPTION ]....]",  01248000
     %10,28,"ALTER {USER [.ACCOUNT]   } [ ; OPTION [ , OPTION ]....]",  01250000
     %10,17,"       OPTION = PRI / COPIES / DEV",                       01252000
     %11,21,"PURGE  DEVICEFILEID [ , DEVICEFILEID ]....",               01254000
   %1012,20,"INPUT  [ USER [ .ACCOUNT ] ] ; TAPEFILE ",                 01256000
   %1012,26,"INPUT  DEVICEFILEID [ , DEVICEFILEID ].. ; TAPEFILE ",     01258000
%1013,25,"OUTPUT [ USER [ .ACCOUNT ] ] ; TAPEFILE [; PURGE] ",<<00204>> 01260000
%1013,28,"OUTPUT DEVFILEID [, DEVFILEID ] .. ; TAPEFILE [; PURGE] ",    01262000
     %14, 2,"HELP",                                            <<B0.00>>01264000
     %15,23,"RUN    PROGRAMFILENAME [ .GROUP [ .ACCOUNT] ]",   <<B0.00>>01266000
     %16,12,"KILL  << SON PROCESS >>",                         <<B0.00>>01268000
     %17,11,"QUIT  << TERMINATE >> ",                          <<B0.00>>01270000
     %20,13,"COPY   [RANGE] [,FILENAME]",                      <<B0.01>>01272000
     %20,28,"COPY   [DFID [,DFID [,...]] ;] [RANGE] [,FILENAME]     ",  01274000
     %20,24,"COPY   [USER [.ACCOUNT] ;]  [RANGE] [,FILENAME]",          01276000
     %21,13,"APPEND [RANGE] [,FILENAME]",                      <<B0.01>>01278000
     %20,28,"APPEND [DFID [,DFID [,...]] ;] [RANGE] [,FILENAME]     ",  01280000
     %20,24,"APPEND [USER [.ACCOUNT] ;]  [RANGE] [,FILENAME]",          01282000
     %21, 8,"       [END  ]  ",                               <<00204>> 01284000
     %22,0;                                                    <<B0.01>>01286000
   << >>                                                                01288000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>01290000
   OBUF := "  ";                                                        01292000
   MOVE OBUF(1) := OBUF,(127);                                          01294000
   IZ := 0;                                                             01296000
   WHILE (IX := XMESSAG(IZ+1)) <> 0 DO                                  01298000
      BEGIN                                                             01300000
      F := TRUE;                                                        01302000
      TOS := XMESSAG(IZ).(0:8);                                         01304000
      ASSEMBLE(TBC 15);                                                 01306000
      IF <> THEN IF NOT CAP2.(9:1) THEN F := FALSE;                     01308000
      ASSEMBLE(TBC 14);                                                 01310000
      IF <> THEN IF NOT CAP1.(0:1) THEN F := FALSE;                     01312000
      IF F THEN                                                         01314000
         BEGIN                                                          01316000
         MOVE OBUF := XMESSAG(IZ+2),(IX);                               01318000
         PRINT(OBUF,IX,0);                                              01320000
         END;                                                           01322000
      IZ := IZ+2+IX;                                                    01324000
      END;                                                              01326000
   CRITFLAG := TRUE;                                           <<B0.00>>01328000
   END;                                                                 01330000
$PAGE                                                                   01332000
$CONTROL SEGMENT=SPOOK2                                                 01334000
                                                                        01336000
PROCEDURE LOCKXDD(XDDI);                                                01338000
   VALUE   XDDI;                                                        01340000
   INTEGER XDDI;                                                        01342000
   BEGIN                                                                01344000
   INTEGER INDEX;                                                       01346000
   << >>                                                                01348000
   INDEX := XDDI.(1:15);                                                01350000
   EXCHANGEDB(IF XDDI<0 THEN ODDDST ELSE IDDDST);                       01352000
   BASE(INDEX).(1:2) := 3;                                              01354000
   EXCHANGEDB(0);                                                       01356000
   END;                                                                 01358000
                                                                        01360000
$PAGE                                                          <<04145>>01362000
<<**********************************************************>> <<04145>>01364000
<< COPYXDD is sent a File ID by MOVEFROMXDD,ALTERXDD and    >> <<04145>>01366000
<< SPOOLOPEN to copy and XDD entry from either the ODD or   >> <<04145>>01368000
<< IDD.  If the sign bit of FID is on, we search the ODD,   >> <<04145>>01370000
<< if it is off, the IDD.  It starts at the value of XDDX,  >> <<04145>>01372000
<< which points the the next XDD subentry to check.  If     >> <<04145>>01374000
<< XDDX is zero, start at the beginning of the subentries,  >> <<04145>>01376000
<< (second word of the table.                               >> <<04145>>01378000
<<**********************************************************>> <<04145>>01380000
                                                               <<04145>>01382000
$CONTROL SEGMENT=SPOOK2                                                 01384000
                                                                        01386000
LOGICAL PROCEDURE COPYXDD(FID);                                         01388000
   VALUE   FID;                                                         01390000
   INTEGER FID;                                                         01392000
   BEGIN                                                                01394000
   INTEGER INDEX,MAX,SIZE;                                              01396000
   INTEGER N,M;                                                         01398000
   LOGICAL UF,AF,OD;                                                    01400000
   ARRAY NAME(0:7)=Q;                                                   01402000
   << >>                                                                01404000
   OD := FID.(0:1);                                                     01406000
   UF := USERF;                                                         01408000
   AF := ACCTF;                                                         01410000
   MOVE NAME := SNAMES,(8);                                             01412000
   INDEX := XDDX;                                                       01414000
   EXCHANGEDB(IF OD THEN ODDDST ELSE IDDDST);                           01416000
   MAX := BASE(0).(8:8)&LSL(7);                                         01418000
   SIZE := BASE(1).(8:8);                                               01420000
L: INDEX := IF INDEX=0 THEN BASE(2) ELSE INDEX+SIZE;                    01422000
   IF INDEX > (MAX-SIZE) THEN                                           01424000
      BEGIN                                                             01426000
      INDEX := 0;                                                       01428000
      GOTO LX;                                                          01430000
      END;                                                              01432000
   IF BASE(INDEX)=0 OR BASE(INDEX+20)=0 THEN GOTO L;                    01434000
                                                               <<04145>>01436000
   <<*******************************************************>> <<04145>>01438000
   << Next, if a USER.ACCOUNT was entered (USERF & ACCTF are>> <<04145>>01440000
   << true), compare words 2 to 9 with that of NAME.  Other->> <<04145>>01442000
   << wise check if the File ID sent matches word 18 of the >> <<04145>>01444000
   << XDD entry.                                            >> <<04145>>01446000
   <<*******************************************************>> <<04145>>01448000
                                                               <<04145>>01450000
   N := IF UF THEN -1 ELSE 3;                                           01452000
   M := IF AF THEN 8 ELSE 4;                                            01454000
   WHILE (N:=N+1)<M DO                                                  01456000
      IF NAME(N) <> BASE(INDEX+2+N) THEN GOTO L;                        01458000
   IF FID.(1:15) <> 0 THEN                                              01460000
      IF LOGICAL(FID) <> BASE(INDEX+18) THEN GOTO L;                    01462000
$PAGE                                                          <<04145>>01464000
                                                               <<04145>>01466000
<<**********************************************************>> <<04145>>01468000
<< Move the entry from the Data Segment (ODD or IDD segment)>> <<04145>>01470000
<< to the users stack via MFDS.                             >> <<04145>>01472000
<<**********************************************************>> <<04145>>01474000
                                                               <<04145>>01476000
LX:EXCHANGEDB(0);                                                       01478000
   IF (XDDX := INDEX) <> 0 THEN                                         01480000
      BEGIN                                                             01482000
      TOS := @XDD;                                                      01484000
      TOS := IF OD THEN ODDDST ELSE IDDDST;                             01486000
      TOS := INDEX;                                                     01488000
      TOS := 30;                                                        01490000
      ASSEMBLE( MFDS 4 );                                               01492000
      COPYXDD := TRUE;                                                  01494000
      END;                                                              01496000
   END;                                                                 01498000
$PAGE                                                          <<04145>>01500000
<<**********************************************************>> <<04145>>01502000
<<  SHOWERRORS outputs any errors encountered while access- >> <<04145>>01504000
<< ing or attempting to access an XDD entry.                >> <<04145>>01506000
<<**********************************************************>> <<04145>>01508000
                                                               <<04145>>01510000
                                                                        01512000
$CONTROL SEGMENT=SPOOK2                                                 01514000
                                                                        01516000
PROCEDURE SHOWERRORS(SHOW);                                    <<04145>>01518000
  VALUE SHOW;LOGICAL SHOW;                                     <<04145>>01520000
   BEGIN                                                                01522000
   INTEGER C,IX,DF,ERRN,ERRF;                                  <<04145>>01524000
   INTEGER POINTER XDDP;                                                01526000
                                                               <<04145>>01528000
   <<*******************************************************>> <<04145>>01530000
   <<  Output DEVFID and error number via ERRFORM.          >> <<04145>>01532000
   <<*******************************************************>> <<04145>>01534000
                                                               <<04145>>01536000
   SUBROUTINE SHOWIT;                                                   01538000
      BEGIN                                                             01540000
      IX := 0;                                                          01542000
      OBUF := "  ";                                                     01544000
      MOVE OBUF(1) := OBUF,(127);                                       01546000
      BOBUF(IX) := "#";                                                 01548000
      BOBUF(IX+1) := IF DF<0 THEN "O" ELSE "I";                         01550000
      ASCII(DF.(1:15),10,BOBUF(IX+2));                                  01552000
      IX := IX+8;                                                       01554000
      IF ERRF = 0 OR ERRF = 255 THEN ERRF := NO'FILE'ERROR;    <<04151>>01556000
      ERRFORM(ERRN,ERRF,IX);                                   <<04145>>01558000
      END;                                                              01562000
   << >>                                                                01564000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>01566000
   ERRN := ERRF := 0;                                          <<04145>>01568000
   C := -1;                                                             01570000
   MOVE OBUF := " "; MOVE OBUF(1):=OBUF,(127);                 <<04145>>01572000
                                                               <<04145>>01574000
   IF NOT FILE'FOUND AND NOT SHOW THEN                         <<04145>>01576000
      BEGIN                                                    <<04145>>01578000
        ERRN :=  5; ERRF := NO'FILE'ERROR; IX:=0;              <<04145>>01580000
        ERRFORM(ERRN,ERRF,IX);                                 <<04145>>01582000
      END;                                                     <<04145>>01584000
                                                               <<04145>>01586000
   <<*******************************************************>> <<04145>>01588000
   <<  For each DEVFID not used in our array DEVFS (not     >> <<04145>>01590000
   << zeroed out) output an error for that DEVFID.          >> <<04145>>01592000
   <<*******************************************************>> <<04145>>01594000
                                                               <<04145>>01596000
   WHILE (C:=C+1) < DEVFC DO                                            01598000
      IF DEVFS(C) <> 0 THEN                                             01600000
         BEGIN                                                          01602000
         DF := DEVFS(C);                                                01604000
         ERRN := 32;                                           <<04145>>01606000
         IF SHOWIO = 1 AND DF > 0 THEN ERRN := 30;             <<04145>>01608000
         SHOWIT;                                                        01610000
         END;                                                           01612000
$PAGE                                                          <<04145>>01614000
                                                               <<04145>>01616000
   <<*******************************************************>> <<04145>>01618000
   <<  For each XDD entried copied into our stack for this  >> <<04145>>01620000
   << command, check XDD(25), which, if non zero, conatins  >> <<04145>>01622000
   << error numbers for ERRN and ERRF, put there as the     >> <<04145>>01624000
   << errors were encountered dealing with the XDD entry.   >> <<04145>>01626000
   <<*******************************************************>> <<04145>>01628000
                                                               <<04145>>01630000
   C := 0;                                                              01632000
   @XDDP := INITXDDP;                                                   01634000
   WHILE (C:=C+1) <= XDDC DO                                            01636000
      BEGIN                                                             01638000
      @XDDP := @XDDP-30;                                                01640000
      IF XDDP <> 0 AND XDDP(25) <> 0 THEN                               01642000
         BEGIN                                                          01644000
         DF := XDDP(18);                                                01646000
         ERRN := XDDP(25).(0:8);                               <<04145>>01648000
         ERRF := XDDP(25).(8:8);                               <<04145>>01650000
         SHOWIT;                                                        01652000
         END;                                                           01654000
      END;                                                              01656000
   CRITFLAG := TRUE;                                           <<B0.00>>01658000
   END;                                                                 01660000
$PAGE                                                          <<04145>>01662000
                                                                        01664000
$CONTROL SEGMENT=SPOOK2                                                 01666000
                                                                        01668000
PROCEDURE SHOWXDD(FLAG,DFID);                                           01670000
   VALUE   FLAG,DFID;                                                   01672000
   LOGICAL FLAG;                                                        01674000
   INTEGER DFID;                                                        01676000
   BEGIN                                                                01678000
   INTEGER IX,IY,DEV,CT,JPRIME;                                         01680000
   LOGICAL OUT;                                                         01682000
   INTEGER POINTER IP;                                                  01684000
   DOUBLE POINTER DP=IP;                                                01686000
   ARRAY CL(0:9)=Q;                                                     01688000
   DOUBLE DCL0=CL+0,DCL1=CL+2;                                          01690000
   BYTE POINTER BCL;                                                    01692000
   ARRAY DAYS(0:11)=PB:=                                                01694000
      0,31,60,91,121,152,182,                                           01696000
      213,244,274,305,335;                                              01698000
   << >>                                                                01700000
   SUBROUTINE SHOWSECT;                                                 01702000
      BEGIN                                                             01704000
      TOS := 0;                                                         01706000
      TOS := XDD(22).(0:8);                                             01708000
      IF = THEN TOS := TOS+1;                                           01710000
      TOS := LOGICAL(TOS-1)**ABSOLUTE(%1104);                           01712000
      TOS := TOS+DOUBLE(XDD(23));                                       01714000
      CT := DASCII(*,10,BCL(4));                                        01716000
      MOVE BOBUF(IX+10-CT-((12-CT)/4)*2) := BCL(4),(CT);                01718000
      IX := IX+11;                                                      01720000
      END;                                                              01722000
   << >>                                                                01724000
   OBUF := "  ";                                                        01726000
   MOVE OBUF(1) := OBUF,(127);                                          01728000
   OUT := XDD(18).(0:1);                                                01730000
   IX := 0;                                                             01732000
   @BCL := @CL&LSL(1);                                                  01734000
   IF FLAG.(12:1) THEN                                                  01736000
      BEGIN                                                             01738000
      BOBUF(IX) := "#";                                                 01740000
      BOBUF(IX+1) := IF DFID < 0 THEN "O" ELSE "I";                     01742000
      ASCII(DFID.(1:15),10,BOBUF(IX+2));                                01744000
      MOVE BOBUF(IX+8) := "===>";                                       01746000
      IX := IX+14;                                                      01748000
      END;                                                              01750000
   BOBUF(IX) := "#";                                                    01752000
   BOBUF(IX+1) := IF OUT THEN "O" ELSE"I";                              01754000
   ASCII(XDD(18).(1:15),10,BOBUF(IX+2));                                01756000
   IX := IX+8;                                                          01758000
   IF NOT FLAG THEN                                                     01760000
      BEGIN                                                             01762000
      IF XDD(1) <> 0 THEN                                               01764000
         BEGIN                                                          01766000
         BOBUF(IX) := "#";                                              01768000
         BOBUF(IX+1) := IF XDD(1).(0:2)<=1 THEN "S" ELSE"J";            01770000
         JPRIME := 0;                                                   01772000
         IF NOT (1<=INTEGER(XDD(1).(0:2))<=2) THEN                      01774000
            BEGIN                                                       01776000
            JPRIME := 1;                                                01778000
            BOBUF(IX+2) := "'";                                         01780000
            END;                                                        01782000
         ASCII(XDD(1).(2:14),10,BOBUF(IX+2+JPRIME));                    01784000
         END;                                                           01786000
      IX := IX+8;                                                       01788000
      IF FLAG.(12:2) = 0 THEN                                           01790000
         BEGIN                                                          01792000
         MOVE BOBUF(IX) := BXDD(28),(8);                                01794000
         IX := IX+9;                                                    01796000
         MOVE BOBUF(IX) := STATES(XDD.(1:2)*6),(6);                     01798000
         IX := IX+7;                                                    01800000
         END;                                                           01802000
      IF FLAG.(12:3) <> 0 THEN                                          01804000
         BEGIN                                                          01806000
         IF XDD.(7:1) THEN                                              01808000
            BEGIN                                                       01810000
            DEV := -XDD.(8:8);                                          01812000
            EXCHANGEDB(LDTDST);                                         01814000
            @IP := BASE(1);                                             01816000
            WHILE (DEV:=DEV+1) < 0 DO                                   01818000
               @IP := @IP+(IP(5).(0:8)&ASR(1))+6;                       01820000
            DCL0 := DP;                                                 01822000
            DCL1 := DP(1);                                              01824000
            EXCHANGEDB(0);                                              01826000
            MOVE BOBUF(IX) := BCL,(8);                                  01828000
            END                                                         01830000
         ELSE                                                           01832000
            ASCII(XDD.(8:8),10,BOBUF(IX));                              01834000
         IX := IX+10;                                                   01836000
         END;                                                           01838000
      IF FLAG.(14:1) THEN                                               01840000
         BEGIN                                                          01842000
         IF OUT THEN                                                    01844000
            BEGIN                                                       01846000
            ASCII(XDD.(3:4),-10,BOBUF(IX));                             01848000
            ASCII(XDD(24).(8:8),-10,BOBUF(IX+4));                       01850000
            END;                                                        01852000
         IX := IX+6;                                                    01854000
         IF XDD(24).(2:1) THEN BOBUF(IX) := "R";                        01856000
         IF XDD(24).(3:1) OR XDD(19).(0:1)                     <<04145>>01858000
            THEN BOBUF(IX+1) := "F";                           <<04145>>01860000
         IF XDD(24).(4:1) THEN BOBUF(IX+2) := "N";             <<04829>>01862000
         IX := IX+4;                                                    01864000
         END;                                                           01866000
      IF FLAG.(13:1) THEN                                               01868000
         BEGIN                                                          01870000
         SHOWSECT;                                                      01872000
         IX := IX+1;                                                    01874000
         END;                                                           01876000
      MOVE BOBUF(IX) := BXDD(4),(8);                                    01878000
      SCAN BOBUF(IX) UNTIL "  ",1;                                      01880000
      IX := TOS-@BOBUF;                                                 01882000
      BOBUF(IX) := ".";                                                 01884000
      MOVE BOBUF(IX+1) := BXDD(12),(8);                                 01886000
      IX := IX+9;                                                       01888000
      END                                                               01890000
   ELSE                                                                 01892000
      BEGIN                                                             01894000
      CT := ASCII(XDD(20).(0:8),8,BCL(4));                              01896000
      IF CT = 0 THEN CT := 1;                                           01898000
      BOBUF(IX) := "%";                                                 01900000
      MOVE BOBUF(IX+1) := BCL(10-CT),(CT);                              01902000
      CL := XDD(20).(8:8);                                              01904000
      CL(1) := XDD(21);                                                 01906000
      CT := DASCII(DCL0,8,BCL(5));                                      01908000
      IF CT = 0 THEN CT := 1;                                           01910000
      CT := CT+1;                                                       01912000
      BCL(16-CT) := "%";                                                01914000
      MOVE BOBUF(IX+4+(12-CT)/2) := BCL(16-CT),(CT);                    01916000
      IX := IX+17;                                                      01918000
      SHOWSECT;                                                         01920000
      TOS := 0;                                                         01922000
      TOS := XDD(26);                                                   01924000
      TOS := XDD(27);                                                   01926000
      CT := DASCII(*,10,BCL(4));                                        01928000
      MOVE BOBUF(IX+12-CT-((12-CT)/4)*2) := BCL(4),(CT);                01930000
      IX := IX+16;                                                      01932000
      CL(0) := XDD(28);                                                 01934000
      CL(1) := XDD(29);                                                 01936000
      IF DCL0 <> 0D THEN                                                01938000
         BEGIN                                                          01940000
         BCL(8) := " ";                                                 01942000
         MOVE BCL(9) := BCL(8),(4);                                     01944000
         ASCII(CL(1).(6:6),-10,BCL(12));                                01946000
         BCL(10) := ":";                                                01948000
         ASCII(CL(1).(1:5),-10,BCL(9));                                 01950000
         MOVE BOBUF(IX) := BCL(8),(5);                                  01952000
         IX := IX+6;                                                    01954000
         DCL0 := DCL0&DLSR(8);                                          01956000
         CL(1) := CL(1)&LSR(7);                                         01958000
         IF CL(0).(14:2) <> 0 AND CL(1) >= 60 THEN                      01960000
            CL(1) := CL(1)+1;                                           01962000
         IY := 12;                                                      01964000
         DO IY := IY-1 UNTIL CL(1) > DAYS(IY);                          01966000
         CL(1) := CL(1)-DAYS(IY);                                       01968000
         IY := IY+1;                                                    01970000
         BCL(8) := " ";                                                 01972000
         MOVE BCL(9) := BCL(8),(7);                                     01974000
         ASCII(CL(0),-10,BCL(15));                                      01976000
         BCL(13) := "/";                                                01978000
         ASCII(CL(1),-10,BCL(12));                                      01980000
         BCL(10) := "/";                                                01982000
         ASCII(IY,-10,BCL(9));                                          01984000
         MOVE BOBUF(IX) := BCL(8),(8);                                  01986000
         IX := IX+10;                                                   01988000
         END;                                                           01990000
      END;                                                              01992000
   IF FLAG.(12:2) = 0 THEN  BEGIN   CRITFLAG := FALSE;         <<B0.00>>01994000
      IF CONTROLYFLAG THEN CONTROLYPROC; END;                  <<B0.00>>01996000
   PRINT(OBUF,-IX,0);                                                   01998000
   IF FLAG.(12:2) = 0 THEN CRITFLAG := TRUE;                   <<B0.00>>02000000
   END;                                                                 02002000
$PAGE                                                          <<04145>>02004000
                                                                        02006000
$CONTROL SEGMENT=SPOOK1                                                 02008000
                                                                        02010000
LOGICAL PROCEDURE GETUSAC;                                              02012000
   BEGIN                                                                02014000
   << >>                                                                02016000
   DEVF := 0;                                                           02018000
   USERF := TRUE;                                                       02020000
   ACCTF := TRUE;                                                       02022000
   SNAMES := "  ";                                                      02024000
   MOVE SNAMES(1) := SNAMES,(7);                                        02026000
   IF BP = CR  OR BP = ";" THEN                                <<04145>>02028000
      MOVE SUSERN := USERN,(16)                                         02030000
   ELSE                                                                 02032000
      BEGIN                                                             02034000
      IF BP = "@" THEN                                                  02036000
         BEGIN                                                          02038000
         USERF := FALSE;                                                02040000
         IF CAP1.(0:2)=0 THEN                                           02042000
            BEGIN                                                       02044000
            WARN := 4;                                                  02046000
            MOVE SUSERN := USERN,(8);                                   02048000
            USERF := 1;                                                 02050000
            END;                                                        02052000
         CNT := 1;                                                      02054000
         END                                                            02056000
      ELSE                                                              02058000
         BEGIN                                                          02060000
         MOVE BP := BP WHILE AS,0;                                      02062000
         IF S0 <> @BP THEN MOVE * := * WHILE ANS,0;                     02064000
         CNT := TOS-@BP;                                                02066000
         DEL;                                                           02068000
         IF NOT (1<=CNT<=8) THEN                                        02070000
            BEGIN ERRN := 34; GOTO LX; END;                             02072000
         MOVE SUSERN := BP,(CNT);                                       02074000
         IF (CAP1.(0:2)=0) AND (SUSERN<>USERN,(8)) THEN                 02076000
            BEGIN ERRN := 35; GOTO LX; END;                             02078000
         END;                                                           02080000
      @BP := @BP+CNT;                                                   02082000
      IF BP = CR  OR BP = ";" THEN                             <<04145>>02084000
         MOVE SACCTN := ACCTN,(8)                                       02086000
      ELSE                                                              02088000
         BEGIN                                                          02090000
         IF BP <> "." THEN                                              02092000
            BEGIN ERRN := 33; GOTO LX; END;                             02094000
         @BP := @BP+1;                                                  02096000
         IF BP = "@" THEN                                               02098000
            BEGIN                                                       02100000
            ACCTF := FALSE;                                             02102000
            IF CAP1.(0:1)=0 THEN                                        02104000
               BEGIN                                                    02106000
               WARN := 4;                                               02108000
               MOVE SACCTN := ACCTN,(8);                                02110000
               ACCTF := 1;                                              02112000
               END;                                                     02114000
            CNT := 1;                                                   02116000
            END                                                         02118000
         ELSE                                                           02120000
            BEGIN                                                       02122000
            MOVE BP := BP WHILE AS,0;                                   02124000
            IF S0 <> @BP THEN MOVE * := * WHILE ANS,0;                  02126000
            CNT := TOS-@BP;                                             02128000
            DEL;                                                        02130000
            IF NOT (1<=CNT<=8) THEN                                     02132000
               BEGIN ERRN := 36; GOTO LX; END;                          02134000
            MOVE SACCTN := BP,(CNT);                                    02136000
            IF (CAP1.(0:1)=0) AND (SACCTN<>ACCTN,(8)) THEN              02138000
               BEGIN ERRN := 37; GOTO LX; END;                          02140000
            END;                                                        02142000
         @BP := @BP+CNT;                                                02144000
         END;                                                           02146000
      END;                                                              02148000
   GETUSAC := TRUE;                                                     02150000
LX:                                                                     02152000
   END;                                                                 02154000
                                                                        02156000
$PAGE                                                          <<04145>>02158000
$CONTROL SEGMENT=SPOOK1                                                 02160000
                                                                        02162000
<<**********************************************************>> <<04145>>02164000
<< GETDEVF obtains a device file id from the command string >> <<04145>>02166000
<< and places it in the device file array DEVFS and updates >> <<04145>>02168000
<< the count DEVFC, assuming no errors.                     >> <<04145>>02170000
<<**********************************************************>> <<04145>>02172000
                                                               <<04145>>02174000
LOGICAL PROCEDURE GETDEVF;                                              02176000
   BEGIN                                                                02178000
   INTEGER DEV'CNT;                                            <<04145>>02180000
   LOGICAL OUTPUT,FOUND;                                       <<04145>>02182000
   << >>                                                                02184000
   ERRN := 32;                                                          02186000
   DEVF := 0;                                                           02188000
   USERF := TRUE;                                                       02190000
   ACCTF := TRUE;                                                       02192000
   SNAMES := "  ";                                                      02194000
   MOVE SNAMES(1) := SNAMES,(7);                                        02196000
                                                               <<04145>>02198000
   <<*******************************************************>> <<04145>>02200000
   << Check for proper string.  If we have a *, then check  >> <<04145>>02202000
   << if a file has been texted in, (DEVice File Number<>0),>> <<04145>>02204000
   << if not, error condition.                              >> <<04145>>02206000
   <<*******************************************************>> <<04145>>02208000
                                                               <<04145>>02210000
   IF BP = "#" OR BP = "*" OR BP = NUMERIC THEN                         02212000
      BEGIN                                                             02214000
      IF BP = "*" THEN                                                  02216000
         BEGIN                                                          02218000
         IF FILEN = 0 THEN                                              02220000
            BEGIN ERRN := 46; GOTO LX; END;                             02222000
         @BP := @BP+1;                                                  02224000
         DEVF := DEVFN;                                                 02226000
         END                                                            02228000
                                                               <<04145>>02230000
      <<****************************************************>> <<04145>>02232000
      << Otherwise we have a device file Id.  If it begins  >> <<04145>>02234000
      << with "#", check Id for "I" or "O" and set FLAG     >> <<04145>>02236000
      << accordingly, TRUE for O, FALSE for I.              >> <<04145>>02238000
      <<****************************************************>> <<04145>>02240000
                                                               <<04145>>02242000
      ELSE                                                              02244000
         BEGIN                                                          02246000
         IF BP = "#" THEN                                               02248000
            BEGIN                                                       02250000
            @BP := @BP+1;                                               02252000
            MOVE BP:=BP WHILE AS; <<UPSHIFT ALPHA         >>   <<01.02>>02254000
            IF BP = "I" THEN OUTPUT := FALSE                   <<04145>>02256000
            ELSE IF BP = "O" THEN OUTPUT := TRUE               <<04145>>02258000
                 ELSE GOTO LX;                                          02260000
                 @BP := @BP+1;                                          02262000
            END                                                         02264000
         ELSE                                                           02266000
            OUTPUT := TRUE;                                    <<04145>>02268000
$PAGE                                                          <<04145>>02270000
        <<**************************************************>> <<04145>>02272000
        << Get ID number and set top bit of DEVF on for     >> <<04145>>02274000
        << OUTPUT and off for INPUT                         >> <<04145>>02276000
        <<**************************************************>> <<04145>>02278000
                                                               <<04145>>02280000
         MOVE BP := BP WHILE N,1;                                       02282000
         CNT := TOS-@BP;                                                02284000
         DEVF := BINARY(BP,CNT);                                        02286000
         IF <> THEN GOTO LX;                                            02288000
         IF DEVF.(0:1) <> 0 THEN GOTO LX;                               02290000
         @BP := @BP+CNT;                                                02292000
         DEVF.(0:1) := OUTPUT;                                 <<04145>>02294000
         END;                                                           02296000
                                                               <<04145>>02298000
      <<****************************************************>> <<04145>>02300000
      <<  Check to see if the Dev ID exists already in the  >> <<04145>>02302000
      << array DEVFS (In case of duplicate Device file      >> <<04145>>02304000
      << ID's.) If not, place it in the array at DEVFC and  >> <<04145>>02306000
      << update the count DEVFC by one.                     >> <<04145>>02308000
      <<****************************************************>> <<04145>>02310000
                                                               <<04145>>02312000
      FOUND := FALSE;                                          <<04145>>02314000
      DEV'CNT := -1;                                           <<04145>>02316000
      WHILE (DEV'CNT:=DEV'CNT+1) < DEVFC DO                    <<04145>>02318000
         IF DEVF = INTEGER(DEVFS(DEV'CNT)) THEN FOUND := TRUE; <<04145>>02320000
      IF NOT FOUND THEN                                        <<04145>>02322000
         BEGIN                                                          02324000
         DEVFS(DEVFC) := DEVF;                                          02326000
         DEVFC := DEVFC+1;                                              02328000
         END;                                                           02330000
      MOVE SUSERN := USERN,(16);                                        02332000
      IF CAP1.(0:2) <> 0 THEN USERF := FALSE;                           02334000
      IF CAP1.(0:1) <> 0 THEN ACCTF := FALSE;                           02336000
      GETDEVF := TRUE;                                                  02338000
      ERRN := 0;                                                        02340000
      END;                                                              02342000
LX:                                                                     02344000
   END;                                                                 02346000
                                                                        02348000
$CONTROL SEGMENT=SPOOK1                                                 02350000
                                                                        02352000
LOGICAL PROCEDURE GETDNUM;                                              02354000
   BEGIN                                                                02356000
   INTEGER Y,Z;                                                         02358000
   << >>                                                                02360000
   Z := 0;                                                              02362000
   IF BP = "+" OR BP = "-" THEN Z := 1;                                 02364000
   MOVE BP(Z) := BP(Z) WHILE N,1;                                       02366000
   Y := TOS-@BP(Z);                                                     02368000
   IF Y = 0 THEN                                                        02370000
      BEGIN                                                             02372000
      IF Z = 0 THEN GETDNUM := 2;                                       02374000
      GOTO LX;                                                          02376000
      END;                                                              02378000
   DNUM := DBINARY(BP,Z+Y);                                             02380000
   IF <> THEN GOTO LX;                                                  02382000
   @BP := @BP+Z+Y;                                                      02384000
   GETDNUM := TRUE;                                                     02386000
LX:                                                                     02388000
   END;                                                                 02390000
                                                                        02392000
$CONTROL SEGMENT=SPOOK1                                                 02394000
                                                                        02396000
LOGICAL PROCEDURE GETLINE(LAST);                                        02398000
   VALUE   LAST;                                                        02400000
   LOGICAL LAST;                                                        02402000
   BEGIN                                                                02404000
   DOUBLE DLINE;                                                        02406000
   << >>                                                                02408000
   ERRN := 39;                                                          02410000
   DLINE := IF FLINE = -1D THEN START'RECNUM  ELSE FLINE;     <<<01549>>02412000
   IF BP <> CR  THEN                                           <<04145>>02414000
      BEGIN                                                             02416000
      IF BP = "*" THEN                                                  02418000
         @BP := @BP+1                                                   02420000
      ELSE                                                              02422000
         IF BP = ALPHA THEN                                             02424000
            BEGIN                                                       02426000
            IF BP = "FIRST" THEN                                        02428000
               BEGIN                                                    02430000
               DLINE := START'RECNUM;                        <<<<01549>>02432000
               @BP := @BP+5;                                            02434000
               END                                                      02436000
            ELSE                                                        02438000
               IF BP = "LAST" THEN                                      02440000
                  BEGIN                                                 02442000
                  DLINE := EOFLINE;                                     02444000
                  @BP := @BP+4;                                         02446000
                  END                                                   02448000
            ELSE                                               <<B0.01>>02450000
               IF BP = "EOF" AND LAST THEN                     <<B0.01>>02452000
                  BEGIN                                        <<B0.01>>02454000
                  DLINE := EOFLINE;                            <<B0.01>>02456000
                  EOFFLAG := TRUE;                             <<B0.01>>02458000
                  @BP := @BP + 3;                              <<B0.01>>02460000
                  END                                          <<B0.01>>02462000
               ELSE                                                     02464000
                  BEGIN ERRN := 38; GOTO LX; END;                       02466000
            END                                                         02468000
         ELSE                                                           02470000
            BEGIN                                                       02472000
            TOS := GETDNUM;                                             02474000
            IF S0 = 0 THEN                                              02476000
               BEGIN                                                    02478000
               DEL;                                                     02480000
               GOTO LX;                                                 02482000
               END;                                                     02484000
            IF LOGICAL(TOS) THEN DLINE := DNUM;                         02486000
            END;                                                        02488000
      WHILE BP = "+" OR BP = "-" DO                                     02490000
         BEGIN                                                          02492000
         IF NOT GETDNUM THEN GOTO LX;                                   02494000
         DLINE := DLINE+DNUM;                                           02496000
         END;                                                           02498000
      IF DLINE < 0D THEN GOTO LX;                                       02500000
      IF DLINE < START'RECNUM THEN                           <<<<01549>>02502000
      BEGIN                                                  <<<<01549>>02504000
         ERRN := 78; <<LINENUM IN A PURGED EXTENT>>          <<<<01549>>02506000
         GO TO LX;                                           <<<<01549>>02508000
      END;                                                   <<<<01549>>02510000
      IF DLINE > EOFLINE THEN GOTO LX;                                  02512000
      END;                                                              02514000
   IF LAST                                                              02516000
      THEN TOLINE := DLINE                                              02518000
      ELSE FRLINE := DLINE;                                             02520000
   GETLINE := TRUE;                                                     02522000
   ERRN := 0;                                                           02524000
LX:                                                                     02526000
   END;                                                                 02528000
$PAGE                                                          <<04145>>02530000
<<**********************************************************>> <<04145>>02532000
<< GET'NEW'FILE, called by LINERANGE, parses the file to be >> <<04145>>02534000
<< copied to and places it in NEW'FILENAME.  The file must  >> <<04145>>02536000
<< begin with a "*", "$", or a alphabetic character.        >> <<04145>>02538000
<<**********************************************************>> <<04145>>02540000
                                                               <<04145>>02542000
$CONTROL SEGMENT = SPOOK1                                      <<B0.01>>02544000
                                                               <<B0.01>>02546000
LOGICAL PROCEDURE GET'NEW'FILE;                                <<B0.01>>02548000
<<>>                                                           <<B0.01>>02550000
BEGIN                                                          <<B0.01>>02552000
INTEGER TCOUNT,T;                                              <<B0.01>>02554000
<<>>                                                           <<B0.01>>02556000
MOVE OLD'FILENAME := NEW'FILENAME,(29);                        <<B0.01>>02558000
IF BP <> CR  THEN                                              <<04145>>02560000
   BEGIN                                                       <<B0.01>>02562000
   IF BP = "," THEN                                            <<B0.01>>02564000
      BEGIN                                                    <<B0.01>>02566000
      @BP := @BP + 1;                                          <<B0.01>>02568000
     IF BP <> "*" AND BP <> "$" AND BP <> ALPHA THEN           <<04145>>02570000
        BEGIN                                                  <<04145>>02572000
          ERRN := 79;                                          <<04145>>02574000
          GO TO LX;                                            <<04145>>02576000
        END;                                                   <<04145>>02578000
      SCAN BP UNTIL %6473,1; <<CR ;>>                          <<B0.01>>02580000
      TCOUNT := TOS;                                           <<B0.01>>02582000
      MOVE NEW'FILENAME := BP,(T:=TCOUNT-@BP+1);               <<B0.01>>02584000
      @BP := @BP+T-1;                                          <<B0.01>>02586000
      IF CARRY THEN GO TO LX1;                                 <<B0.01>>02588000
      END                                                      <<B0.01>>02590000
   ELSE MOVE NEW'FILENAME := "  " ;                            <<B0.01>>02592000
   END                                                         <<B0.01>>02594000
ELSE                                                           <<B0.01>>02596000
   MOVE NEW'FILENAME := "  ";                                  <<B0.01>>02598000
LX1:                                                           <<B0.01>>02600000
   GET'NEW'FILE := TRUE;                                       <<B0.01>>02602000
LX:                                                            <<B0.01>>02604000
   END;                                                        <<B0.01>>02606000
$PAGE                                                          <<04145>>02608000
                                                               <<B0.01>>02610000
                                                                        02612000
$CONTROL SEGMENT=SPOOK1                                                 02614000
                                                                        02616000
LOGICAL PROCEDURE LINERANGE(SKAN);                                      02618000
   VALUE   SKAN;                                                        02620000
   LOGICAL SKAN;                                                        02622000
   BEGIN                                                                02624000
   << >>                                                                02626000
   IF BP = "ALL" THEN                                                   02628000
      BEGIN                                                             02630000
      @BP := @BP+3;                                                     02632000
      FRLINE := START'RECNUM;                                <<<<01549>>02634000
      TOLINE := EOFLINE;                                                02636000
      LINECNT := EOFLINE+1D;                                            02638000
      END                                                               02640000
   ELSE                                                                 02642000
      BEGIN                                                             02644000
      IF NOT GETLINE(FALSE) THEN GOTO LX;                               02646000
      TOLINE := IF SKAN THEN EOFLINE ELSE FRLINE;                       02648000
      LINECNT := TOLINE-FRLINE+1D;                                      02650000
      IF BP <> CR  THEN                                        <<04145>>02652000
         IF BP = "," THEN                                               02654000
            BEGIN                                                       02656000
            ERRN := 40;                                                 02658000
            @BP := @BP+1;                                               02660000
            IF NOT GETDNUM THEN GOTO LX;                                02662000
            IF (LINECNT := DNUM) <= 0D THEN GOTO LX;                    02664000
            TOLINE := FRLINE+LINECNT-1D;                                02666000
            IF TOLINE > EOFLINE THEN GOTO LX;                           02668000
            ERRN := 0;                                                  02670000
            END                                                         02672000
         ELSE                                                           02674000
            BEGIN                                                       02676000
            IF BP <> "/" THEN                                           02678000
               BEGIN ERRN := 33; GOTO LX; END;                          02680000
            @BP := @BP+1;                                               02682000
            IF NOT GETLINE(TRUE) THEN GOTO LX;                          02684000
            LINECNT := TOLINE-FRLINE+1D;                                02686000
            IF LINECNT <= 0D THEN                                       02688000
               BEGIN ERRN := 41; GOTO LX; END;                          02690000
            END;                                                        02692000
      END;                                                              02694000
   IF SKAN = COPY THEN <<COPY CALLED PROCEDURE>>               <<B0.01>>02696000
      IF NOT GET'NEW'FILE THEN GO TO LX;                       <<B0.01>>02698000
   IF BP <> CR  THEN                                           <<04145>>02700000
      BEGIN ERRN := 33; GOTO LX; END;                                   02702000
   LINERANGE := TRUE;                                                   02704000
LX:                                                                     02706000
   END;                                                                 02708000
$PAGE                                                          <<04145>>02710000
$CONTROL SEGMENT=SPOOK1                                                 02712000
                                                                        02714000
LOGICAL PROCEDURE FINDRANGE;                                            02716000
   BEGIN                                                                02718000
   << >>                                                                02720000
   FSTRALL := FALSE;                                                    02722000
   FSTRING := 0;                                                        02724000
   IF BP = "@" THEN                                                     02726000
      BEGIN                                                             02728000
      FSTRALL := TRUE;                                                  02730000
      @BP := @BP+1;                                                     02732000
      END;                                                              02734000
   IF BP = %42 THEN                                                     02736000
      BEGIN                                                             02738000
      @BP := @BP+1;                                                     02740000
      SCAN BP WHILE %6440,1;                                            02742000
      @BP := TOS;                                                       02744000
      SCAN BP(1) UNTIL %6442,1;                                         02746000
      IF CARRY THEN                                                     02748000
         BEGIN ERRN := 42; GOTO LX; END;                                02750000
      FSTRING := TOS-@BP;                                               02752000
      @BFSTR := @FSTR&ASL(1);                                           02754000
      MOVE BFSTR := BP,(FSTRING);                                       02756000
      @BP := @BP+FSTRING+1;                                             02758000
      END;                                                              02760000
   IF BP = "," THEN                                                     02762000
      @BP := @BP+1                                                      02764000
   ELSE                                                                 02766000
      IF BP <> CR  THEN                                        <<04145>>02768000
         BEGIN ERRN := 33; GOTO LX; END;                                02770000
   IF NOT LINERANGE(TRUE) THEN GOTO LX;                                 02772000
   FINDRANGE := TRUE;                                                   02774000
LX:                                                                     02776000
   END;                                                                 02778000
                                                               <<B0.01>>02780000
PROCEDURE SCANBLOCKTAB(ENDLINE,BLOCKNO,RECNO);                 <<B0.01>>02782000
DOUBLE ENDLINE,BLOCKNO,RECNO;                                  <<B0.01>>02784000
<<>>                                                           <<B0.01>>02786000
BEGIN                                                          <<B0.01>>02788000
INTEGER POINTER BLOCKTP;                                       <<B0.01>>02790000
DOUBLE POINTER DBLOCKTP = BLOCKTP;                             <<B0.01>>02792000
INTEGER BCOUNT;                                                <<B0.01>>02794000
<<>>                                                           <<B0.01>>02796000
BCOUNT := 0;                                                   <<B0.01>>02798000
CRITFLAG := FALSE;IF CONTROLYFLAG THEN CONTROLYPROC;           <<B0.01>>02800000
@BLOCKTP := @BLOCKFP;                                          <<B0.01>>02802000
  WHILE (BCOUNT:= BCOUNT + 1) < BENTRIES                       <<B0.01>>02804000
      AND ENDLINE >= DBLOCKTP(1)                     <<B0.01>> <<B0.01>>02806000
      DO BEGIN                                                 <<B0.01>>02808000
      @BLOCKTP := @BLOCKTP + BENTRY'SIZE;                      <<B0.01>>02810000
      IF @BLOCKTP >=  @BLOCKTABLE+BENTRIES * BENTRY'SIZE       <<B0.01>>02812000
         THEN @BLOCKTP := @BLOCKTABLE;                         <<B0.01>>02814000
      END;                                                     <<B0.01>>02816000
IF @BLOCKTP = @BLOCKTABLE THEN                                 <<B0.01>>02818000
   @BLOCKTP := @BLOCKTABLE + (BENTRIES-1)*BENTRY'SIZE          <<B0.01>>02820000
ELSE                                                           <<B0.01>>02822000
   @BLOCKTP := @BLOCKTP - BENTRY'SIZE;                         <<B0.01>>02824000
CRITFLAG := TRUE;                                              <<B0.01>>02826000
BLOCKNO := DBLOCKTP(0);                                        <<B0.01>>02828000
RECNO := DBLOCKTP(1);                                          <<B0.01>>02830000
END;                                                           <<B0.01>>02832000
$PAGE                                                          <<04145>>02834000
$CONTROL SEGMENT=SPOOK2                                        <<B0.01>>02836000
                                                               <<B0.01>>02838000
PROCEDURE COPY'LAST'OPEN;                                      <<B0.01>>02840000
<<>>                                                           <<B0.01>>02842000
BEGIN                                                          <<B0.01>>02844000
INTEGER I;                                                     <<B0.01>>02846000
<<>>                                                           <<B0.01>>02848000
MOVE SBUF(512) := NEW'BUFW,((NEW'BUFW+3)/2);                   <<B0.01>>02850000
SBUF(I:= 512 + (NEW'BUFW+3)/2    ) := -1 ;                     <<B0.01>>02852000
MOVE SBUF(I+1) := SBUF(I),(1024 - I -1);                       <<B0.01>>02854000
FWRITE(NEW'FILEN,SBUF(512),512,0);                             <<B0.01>>02856000
                                                               <<B0.01>>02858000
END;                                                           <<B0.01>>02860000
$CONTROL SEGMENT=SPOOK2                                        <<B0.01>>02862000
                                                               <<B0.01>>02864000
PROCEDURE COMPRESS(BUFFER,BEGINNING,BUFLENGTH);                <<B0.01>>02866000
                                                               <<B0.01>>02868000
VALUE BEGINNING,BUFLENGTH;                                     <<B0.01>>02870000
ARRAY BUFFER;                                                  <<B0.01>>02872000
INTEGER BEGINNING,BUFLENGTH;                                   <<B0.01>>02874000
<<>>                                                           <<B0.01>>02876000
BEGIN                                                          <<B0.01>>02878000
POINTER CP;                                                    <<B0.01>>02880000
INTEGER LEN;                                                   <<B0.01>>02882000
@CP := BEGINNING;                                              <<B0.01>>02884000
MOVE BUFFER := CP,(LEN:=BUFLENGTH-(@CP-@BUFFER));              <<B0.01>>02886000
BUFFER(LEN) :=-1;                                              <<B0.01>>02888000
MOVE BUFFER(LEN+1) := BUFFER(LEN),(BUFLENGTH-LEN-1);           <<B0.01>>02890000
END;                                                           <<B0.01>>02892000
$PAGE                                                          <<04145>>02894000
                                                                        02896000
$CONTROL SEGMENT=SPOOK2                                                 02898000
                                                                        02900000
LOGICAL PROCEDURE SKANTOLINE(SKAN);                                     02902000
   VALUE   SKAN;                                                        02904000
   LOGICAL SKAN;                                                        02906000
   BEGIN                                                                02908000
   INTEGER TEMP;                                                        02910000
   DOUBLE ENDLINE;                                                      02912000
DOUBLE RECNO;                                                  <<B0.01>>02914000
   POINTER P;                                                           02916000
   INTEGER R,Q;                                                <<B0.01>>02918000
   << >>                                                                02920000
SUBROUTINE ADD'BLOCK'ENTRY;                                    <<B0.01>>02922000
BEGIN                                                          <<B0.01>>02924000
<<>>                                                           <<B0.01>>02926000
     @BLOCKCP := @BLOCKCP + BENTRY'SIZE;                       <<B0.01>>02928000
     IF @BLOCKCP - @BLOCKTABLE >=  R:= BENTRIES * BENTRY'SIZE  <<B0.01>>02930000
      THEN BEGIN                                               <<B0.01>>02932000
           @BLOCKCP := @BLOCKTABLE;                            <<B0.01>>02934000
           @BLOCKFP := @BLOCKTABLE + BENTRY'SIZE;              <<B0.01>>02936000
           END                                                 <<B0.01>>02938000
      ELSE                                                     <<B0.01>>02940000
         IF @BLOCKFP <> @BLOCKTABLE THEN                       <<B0.01>>02942000
           @BLOCKFP := IF (Q:=@BLOCKFP+BENTRY'SIZE) >          <<B0.01>>02944000
                @BLOCKTABLE + R THEN @BLOCKTABLE               <<B0.01>>02946000
                ELSE Q;                                        <<B0.01>>02948000
     DBLOCKCP(0) := BLOCKNO;                                   <<B0.01>>02950000
     DBLOCKCP(1) := SBLINE;                                    <<B0.01>>02952000
END;                                                           <<B0.01>>02954000
<<>>  <<END OF ADD'BLOCK'ENTRY>>                               <<B0.01>>02956000
                                                               <<B0.01>>02958000
   ENDLINE := IF SKAN THEN FRLINE ELSE TOLINE;                          02960000
   IF SKAN THEN                                                <<01726>>02962000
   BEGIN  << INCREDIBLY FAST FREADDIR TO RECORD>>              <<01726>>02964000
      READ'RECORD(FILEN,ENDLINE,SBUF,SP,XDDN,BLOCKNO,ERRF);    <<01726>>02966000
      IF <> THEN                                               <<01726>>02968000
      BEGIN <<ERROR, IF CCL THEN BEFORE FIRST EXTENT>>         <<01726>>02970000
         IF < THEN                                             <<01726>>02972000
         BEGIN                                                 <<01726>>02974000
            ERRN := 78; <<BEFORE PURGED EXTENT>>               <<01726>>02976000
            GO TO LX;                                          <<01726>>02978000
         END                                                   <<01726>>02980000
         ELSE                                                  <<01726>>02982000
         IF  > THEN                                            <<01726>>02984000
         BEGIN  << ERROR , IF CCG THEN BEYOND EOF>>            <<01726>>02986000
            ERRN := 41;                                        <<01726>>02988000
            GO TO LX;                                          <<01726>>02990000
         END;                                                  <<01726>>02992000
      END;                                                     <<01726>>02994000
      FLINE := ENDLINE;                                        <<01726>>02996000
      TOS := SBUF(510);                                        <<01726>>02998000
      TOS := SBUF(511);                                        <<01726>>03000000
      SBLINE := TOS;                                           <<01726>>03002000
      GO TO LI;                                                <<01726>>03004000
   END;                                                        <<01726>>03006000
   WHILE FLINE <> ENDLINE DO                                   <<01726>>03008000
      BEGIN                                                             03010000
      IF > THEN                                                         03012000
         BEGIN                                                          03014000
         IF NOT SKAN THEN                                               03016000
            BEGIN ERRN := 19; GOTO LX; END;                             03018000
         IF SBLINE > ENDLINE THEN                                       03020000
            BEGIN                                                       03022000
<< NOTE: THE FOLLOWING CODE IS TURNED OFF UNTIL      >>        <<01549>>03024000
<<      FREADDIR WORKS CORRECTLY WITH SPECIAL        >>        <<01549>>03026000
<<      VARIABLE SPOOLFILES.                         >>        <<01549>>03028000
         IF ENDLINE > DBLOCKFP(1) THEN                         <<01549>>03030000
            BEGIN                                              <<01549>>03032000
            SCANBLOCKTAB(ENDLINE,BLOCKNO,RECNO);               <<01549>>03034000
            READ'DIR'FLAG := TRUE;                             <<01549>>03036000
            END                                                <<01549>>03038000
          ELSE BEGIN                                           <<01549>>03040000
               @BLOCKFP := @BLOCKCP := @BLOCKTABLE  ;          <<01549>>03042000
               DBLOCKFP(0) := 0D;                              <<01549>>03044000
               DBLOCKFP(1) := 0D;                              <<01549>>03046000
               BLOCKNO := 0D;                                  <<01549>>03048000
            FCONTROL(FILEN,5,TEMP);                                     03050000
            IF <> THEN                                                  03052000
               BEGIN ERRN := 26; FCHECK(FILEN,ERRF); GOTO LX; END;      03054000
            FLINE := -1D;                                               03056000
            END;                 <<SEE COMMENT ABOVE>>         <<01549>>03058000
            END                                                         03060000
         ELSE                                                           03062000
            BEGIN                                                       03064000
            @SP := @SBUF;                                               03066000
            FLINE := SBLINE;                                            03068000
            GOTO LI;                                                    03070000
            END;                                                        03072000
         END;                                                           03074000
      IF FLINE >= 0D THEN                                               03076000
         BEGIN                                                 <<B0.01>>03078000
         @P := @SP+INTEGER((SP+3)&ASR(1))                               03080000
                                             ;                 <<B0.01>>03082000
         IF @P > @SBUF + 512 THEN                              <<B0.01>>03084000
            BEGIN ERRN := 61; GO TO LX; END;                   <<B0.01>>03086000
         END                                                   <<B0.01>>03088000
      ELSE                                                              03090000
         BEGIN                                                          03092000
         @P := @SBUF;                                                   03094000
         FREAD(FILEN,SBUF,512); <<GET FIRST BLOCK>>            <<01549>>03096000
         TOS := SBUF(510);                                     <<01549>>03098000
         TOS := SBUF(511);                                     <<01549>>03100000
         FLINE := TOS - 1D;  <<RECORD NUM OF FIRST RECORD>>    <<01549>>03102000
         FCONTROL(FILEN,5,TEMP); <<REWIND FILE>>               <<01549>>03104000
<<>>                                                           <<01549>>03106000
         P := -1;                                                       03108000
         END;                                                           03110000
      WHILE P = -1 DO                                                   03112000
         BEGIN                                                          03114000
         IF NOT READ'DIR'FLAG THEN                             <<B0.01>>03116000
         BEGIN                                                 <<B0.01>>03118000
         FREAD(FILEN,SBUF,512);                                         03120000
         IF <> THEN                                                     03122000
            BEGIN ERRN := 26; FCHECK(FILEN,ERRF); GOTO LX; END;         03124000
         SBLINE := FLINE+1D;                                            03126000
         ADD'BLOCK'ENTRY;                                      <<B0.01>>03128000
         BLOCKNO := BLOCKNO + 1D;                              <<B0.01>>03130000
         END                                                   <<B0.01>>03132000
         ELSE BEGIN                                            <<B0.01>>03134000
              READ'DIR'FLAG := FALSE;                          <<B0.01>>03136000
              FREADDIR(FILEN,SBUF,512,BLOCKNO);                <<B0.01>>03138000
              IF <> THEN                                       <<B0.01>>03140000
            BEGIN ERRN:=26; FCHECK(FILEN,ERRF); GO TO LX;END;  <<B0.01>>03142000
              SBLINE := FLINE := RECNO;                        <<B0.01>>03144000
                FLINE := FLINE - 1D;                           <<01549>>03146000
              END;                                             <<B0.01>>03148000
         @P := @SBUF;                                                   03150000
         END;                                                           03152000
      @SP := @P;                                                        03154000
      IF NOT FILE'FORMSMSG THEN                                <<B0.01>>03156000
         IF SP(2) = 3 <<FOPEN>> THEN                           <<B0.01>>03158000
            MOVE NEW'BUFW := SP,((SP+3)/2);                    <<B0.01>>03160000
         IF SP(3) = 4 <<FCLOSE>> AND EOFFLAG THEN              <<B0.01>>03162000
            BEGIN                                              <<B0.01>>03164000
            EOFFLAG := FALSE;                                  <<B0.01>>03166000
            ENDLINE := TOLINE := FLINE + 1D;                   <<B0.01>>03168000
            END;                                               <<B0.01>>03170000
      FLINE := FLINE+1D;                                                03172000
LI:                                                                     03174000
      FLINECNT := SP-8;                                                 03176000
      IF NOT SKAN THEN ENDLINE := FLINE;                                03178000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>03180000
      CRITFLAG := TRUE;                                        <<B0.00>>03182000
      END;                                                              03184000
   SKANTOLINE := TRUE;                                                  03186000
LX:                                                                     03188000
   END;                                                                 03190000
$PAGE                                                          <<04145>>03192000
$CONTROL SEGMENT=SPOOK2                                                 03194000
                                                                        03196000
LOGICAL PROCEDURE LISTRANGE(SKAN);                                      03198000
   VALUE   SKAN;                                                        03200000
   LOGICAL SKAN;                                                        03202000
   BEGIN                                                                03204000
   INTEGER IX,IY,CT,CTL,LSP,NX;                                         03206000
   LOGICAL UNI,FOUND;                                                   03208000
   ARRAY CL(0:7);                                                       03210000
   BYTE POINTER BSP;                                                    03212000
   BYTE POINTER BCL;                                                    03214000
   LOGICAL FDEVCTL;                                            <<01726>>03216000
    INTEGER LENGTH;                                            <<01726>>03218000
   DEFINE FUNC = SP(2)#,                                       <<01726>>03220000
          P1   = SP(3)#,                                       <<01726>>03222000
          P2   = SP(4)#,                                       <<01726>>03224000
          LEN  = SP(0)#;                                       <<01726>>03226000
                                                               <<04145>>03228000
   DEFINE                                                      <<04145>>03230000
      LIST'COMMAND = NOT SKAN#,                                <<04145>>03232000
      FIND'COMMAND =     SKAN#;                                <<04145>>03234000
                                                               <<01726>>03236000
   << >>                                                                03238000
   UNI := TRUE;                                                         03240000
   FDEVCTL := FALSE;                                           <<01726>>03244000
   @BCL := @CL&ASL(1);                                                  03246000
   NX := DASCII(EOFLINE,10,BCL);                                        03248000
   DO                                                                   03250000
      BEGIN                                                             03252000
       FOUND := FALSE;                                         <<04145>>03254000
      IF UNI THEN                                                       03256000
         UNI := FALSE                                                   03258000
      ELSE                                                              03260000
         IF NOT SKANTOLINE(FALSE) THEN GOTO LX;                         03262000
      @BCL := @CL&ASL(1);                                               03264000
      @BSP := @SP(5)&ASL(1);                                            03266000
      LSP := FLINECNT;                                                  03268000
      OBUF := "  ";                                                     03270000
      MOVE OBUF(1) := OBUF,(127);                                       03272000
      IX := 0;                                                          03274000
      CT := DASCII(FLINE,10,BCL);                                       03276000
      MOVE BOBUF(IX+NX-CT) := BCL,(CT);                                 03278000
      IX := IX+NX+1;                                                    03280000
      CTL := SP(3);                                                     03282000
      IF CTL = 1 AND FUNC = 1 THEN                             <<01886>>03284000
         BEGIN                                                          03286000
         CTL := SP(5).(0:8);                                            03288000
         LSP := LSP-1;                                                  03290000
         @BSP := @BSP+1;                                                03292000
         END;                                                           03294000
      IF FALL THEN                                                      03296000
         BEGIN                                                          03298000
          IF FUNC >= %200 THEN                                 <<01726>>03300000
          BEGIN  <<FDEVICECONTROL>>                            <<01726>>03302000
             FDEVCTL := TRUE;                                  <<01726>>03304000
             MOVE BOBUF(IX) := "FDEVICECONTROL FUNC=";         <<01726>>03306000
             IX := IX + 21;                                    <<01726>>03308000
             ASCII(FUNC,10,BCL);                               <<01726>>03310000
             MOVE BOBUF(IX) := BCL   , (3);                    <<01726>>03312000
             IX := IX + 4;                                     <<01726>>03314000
             MOVE BOBUF(IX) := "P1=% ";                        <<01726>>03316000
             IX := IX + 5;                                     <<01726>>03318000
             ASCII(P1,8,BCL);                                  <<01726>>03320000
             MOVE BOBUF(IX) := BCL , (6);                      <<01726>>03322000
             IX := IX + 7;                                     <<01726>>03324000
             MOVE BOBUF(IX) := "P2=% ";                        <<01726>>03326000
             IX := IX + 5;                                     <<01726>>03328000
             ASCII(P2,8,BCL);                                  <<01726>>03330000
             MOVE BOBUF(IX) := BCL , (6);                      <<01726>>03332000
             IX := IX + 7;                                     <<01726>>03334000
             MOVE BOBUF(IX) := "LEN= ";                        <<01726>>03336000
             IX := IX + 5;                                     <<01726>>03338000
             LENGTH := ASCII(LEN,10,BCL);                      <<01726>>03340000
             MOVE BOBUF(IX) := BCL   , (LENGTH);               <<01726>>03342000
             IX := IX + 7;                                     <<01726>>03344000
                                                               <<01726>>03346000
             CASE FUNC - 128 OF                                <<01726>>03348000
             BEGIN                                             <<01726>>03350000
                   <<128>>                                     <<01726>>03352000
                MOVE BOBUF(IX) :=                              <<01726>>03354000
                    "Select Primary/Secondary Character Set";  <<01726>>03356000
                   <<129>>                                     <<01726>>03358000
                MOVE BOBUF(IX) :=                              <<01726>>03360000
                    "Select Logical Pages/Forms            ";  <<01726>>03362000
                   <<130>>                                     <<01726>>03364000
                MOVE BOBUF(IX) :=                              <<01726>>03366000
                    "Move Pen Relative                     ";  <<01726>>03368000
                   <<131>>                                     <<01726>>03370000
                MOVE BOBUF(IX) :=                              <<01726>>03372000
                    "Move Pen Absolute                     ";  <<01726>>03374000
                   <<132>>                                     <<01726>>03376000
                MOVE BOBUF(IX) :=                              <<01726>>03378000
                    "Define Job Characteristics            ";  <<01726>>03380000
                   <<133>>                                     <<01726>>03382000
                MOVE BOBUF(IX) :=                              <<01726>>03384000
                    "Download Physical Page Definition     ";  <<01726>>03386000
                   <<134>>                                     <<01726>>03388000
                MOVE BOBUF(IX) :=                              <<01726>>03390000
                    "Download/Delete Character Set         ";  <<01726>>03392000
                   <<135>>                                     <<01726>>03394000
                MOVE BOBUF(IX) :=                              <<01726>>03396000
                    "Download/Delete Forms                 ";  <<01726>>03398000
                   <<136>>                                     <<01726>>03400000
                MOVE BOBUF(IX) :=                              <<01726>>03402000
                    "Download Logical Page Table           ";  <<01726>>03404000
                   <<137>>                                     <<01726>>03406000
                MOVE BOBUF(IX) :=                              <<01726>>03408000
                    "Download Multi-Copy Form Overlay Table";  <<01726>>03410000
                   <<138>>                                     <<01726>>03412000
                MOVE BOBUF(IX) :=                              <<01726>>03414000
                    "Download/Delete VFC                   ";  <<01726>>03416000
            END;  <<CASE>>                                     <<01726>>03418000
            IX := IX + 39;                                     <<01726>>03420000
        END                                                    <<01726>>03422000
        ELSE                                                   <<01726>>03424000
        BEGIN                                                  <<01726>>03426000
         ASCII(CTL,8,BCL);                                              03428000
         CASE SP(2) OF                                                  03430000
            BEGIN                                                       03432000
            <<0>>                                                       03434000
            MOVE BOBUF(IX) := "W";                                      03436000
            <<1>>                                                       03438000
               BEGIN                                                    03440000
               MOVE BOBUF(IX) := "W";                                   03442000
               IF CTL <> 0 THEN                                         03444000
                  BEGIN                                                 03446000
                  BOBUF(IX+1) := "%";                                   03448000
                  MOVE BOBUF(IX+2) := BCL(3),(3);                       03450000
                  END;                                                  03452000
               END;                                                     03454000
            <<2>>                                                       03456000
               BEGIN                                                    03458000
               MOVE BOBUF(IX) := "C";                                   03460000
               IF CTL <> 0 THEN                                         03462000
                  BEGIN                                                 03464000
                  BOBUF(IX+1) := "%";                                   03466000
                  MOVE BOBUF(IX+2) := BCL(3),(3);                       03468000
                  END;                                                  03470000
               END;                                                     03472000
            <<3>>                                                       03474000
            MOVE BOBUF(IX) := "FOPEN";                                  03476000
            <<4>>                                                       03478000
            MOVE BOBUF(IX) := "FCLOSE";                                 03480000
            END;                                                        03482000
         IX := IX+7;                                                    03484000
                           END;                                <<01726>>03486000
         END;                                                           03488000
         IF LSP > 256 OR LSP < 0 THEN                          <<01326>>03490000
         BEGIN  <<INVALID LENGTH>>                             <<01326>>03492000
            ERRN := 61;                                        <<01326>>03494000
            GO TO LX;                                          <<01326>>03496000
         END;                                                  <<01326>>03498000
      IF FDEVCTL THEN LSP := 0                                 <<01726>>03500000
      ELSE                                                     <<01726>>03502000
      MOVE BOBUF(IX) := BSP,(LSP);                                      03504000
      FDEVCTL := FALSE;                                        <<01726>>03506000
      CT := LSP+IX;                                                     03508000
      IF FIND'COMMAND THEN                                     <<04145>>03510000
         BEGIN                                                          03512000
         BOBUF(CT+1) := CR ;                                   <<04145>>03514000
         SCAN BOBUF(IX) WHILE %6440,1;                                  03516000
         IX := TOS-@BOBUF;                                              03518000
         BOBUF(CT+1) := " ";                                            03520000
         IY := IX;                                                      03522000
         WHILE IY <= (CT+1-FSTRING) DO                                  03524000
            BEGIN                                                       03526000
            IF BFSTR = BOBUF(IY),(FSTRING) THEN                         03528000
               BEGIN                                                    03530000
               FOUND := TRUE;                                           03532000
               TOLINE := FLINE;                                <<04459>>03536000
               IY := CT+1;                                              03538000
               END;                                                     03540000
            IF NOT FSTRALL THEN IY := CT+1;                    <<04459>>03542000
            IY := IY+1;                                                 03544000
            END;                                                        03546000
         END;                                                           03548000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>03550000
      IF LIST'COMMAND OR FOUND THEN                            <<04145>>03552000
         BEGIN                                                          03554000
         IF FWIDTH <> 0 THEN                                            03556000
            IF CT > FWIDTH THEN CT := FWIDTH;                           03558000
         IF CT > 256 OR CT < 0 THEN                            <<B0.01>>03560000
            BEGIN ERRN := 61; GO TO LX; END;                   <<B0.01>>03562000
         IY := -1;                                                      03564000
         WHILE (IY:=IY+1) < CT DO                                       03566000
            IF NOT (%40<=INTEGER(BOBUF(IY))<=%176) THEN        <<B0.01>>03568000
               BOBUF(IY) := ".";                                        03570000
         PRINT(OBUF,-CT,0);                                             03572000
         IF FIND'COMMAND AND NOT FSTRALL                       <<04145>>03574000
            THEN TOLINE := FLINE;                              <<04145>>03576000
         END;                                                           03578000
      CRITFLAG := TRUE;                                        <<B0.00>>03580000
      END                                                               03582000
   UNTIL FLINE >= TOLINE;                                               03584000
   IF TOLINE < EOFLINE THEN                                    <<04145>>03586000
      BEGIN                                                             03588000
      TOLINE := TOLINE+1D;                                              03590000
      IF NOT SKANTOLINE(FALSE) THEN GOTO LX;                            03592000
      END;                                                              03594000
   LISTRANGE := TRUE;                                                   03596000
LX:                                                                     03598000
   END;                                                                 03600000
$PAGE                                                          <<04145>>03602000
$CONTROL SEGMENT=SPOOK2                                        <<B0.00>>03604000
                                                               <<B0.00>>03606000
LOGICAL PROCEDURE SHIFTUPPER(STRING,COUNT);                    <<B0.00>>03608000
                                                               <<04145>>03610000
<<*************************************************>>          <<04145>>03612000
<< THIS PROCEDURE UPSHIFTS ALPHANUMERIC STRING     >>          <<04145>>03614000
<< EXCEPT FOR QUANTITIES ENCLOSED IN QUOTES.       >>          <<04145>>03616000
<< IF A QUOTE OCCURS WITHIN THE STRING IT MUST     >>          <<04145>>03618000
<< BE A DOUBLE QUOTE:                              >>          <<04145>>03620000
<< FOR EXAMPLE "STRING IS QUOTE = "" IS ALLOWED "  >>          <<B0.00>>03622000
<<*************************************************>>          <<04145>>03624000
                                                               <<04145>>03626000
<<>>                                                           <<B0.00>>03628000
                                                               <<B0.00>>03630000
BYTE ARRAY STRING;                                             <<B0.00>>03632000
INTEGER COUNT;                                                 <<B0.00>>03634000
                                                               <<B0.00>>03636000
BEGIN                                                          <<B0.00>>03638000
INTEGER I, FIRSTQUOTE,SECONDQUOTE,DIFF;                        <<B0.00>>03640000
EQUATE QUOTE = %42;                                            <<B0.00>>03642000
EQUATE CRQUOTE = %6442;                                        <<B0.00>>03644000
<<>>                                                           <<B0.00>>03646000
SHIFTUPPER := TRUE;                <<INITIALIZE>>              <<B0.00>>03648000
I := 0;                                                        <<B0.00>>03650000
DO                                                             <<B0.00>>03652000
  BEGIN  <<UPSHIFT ALPHANUMERICS >>                            <<B0.00>>03654000
    MOVE STRING(I) := STRING(I) WHILE ANS,1;                   <<B0.00>>03656000
    ASSEMBLE(DUP);                                             <<B0.00>>03658000
    IF STRING(I := TOS - @STRING) = QUOTE THEN                 <<B0.00>>03660000
         <<LOOK FOR QUOTE IF >>                                <<B0.00>>03662000
      BEGIN               << NOT ALPHANUMERIC>>                <<B0.00>>03664000
        FIRSTQUOTE := TOS;             <<WE FOUND FIRST QUOTE>><<B0.00>>03666000
SCAN1:  SCAN STRING(I := I+1) UNTIL CRQUOTE,1;                 <<B0.00>>03668000
        SECONDQUOTE := TOS;           <<WE FOUND SECOND QUOTE>><<B0.00>>03670000
        IF CARRY THEN                  <<IF END OF STRING>>    <<B0.00>>03672000
          BEGIN                <<UNDELIMITED STRING>>          <<B0.00>>03674000
            ERRN := 42; SHIFTUPPER := FALSE;                   <<B0.00>>03676000
          END                                                  <<B0.00>>03678000
        ELSE                                                   <<B0.00>>03680000
          BEGIN                                                <<B0.00>>03682000
            DIFF := SECONDQUOTE - FIRSTQUOTE;                  <<B0.00>>03684000
            I := I + DIFF;                                     <<B0.00>>03686000
            IF  STRING(I) = QUOTE THEN                         <<B0.00>>03688000
               BEGIN    << IF ANOTHER QUOTE >>                 <<B0.00>>03690000
           << IMMEDIATELY FOLLOWS THEN KEEP SCANNING>>         <<B0.00>>03692000
                 I := I+1;  <<FOR TERMINAL QUOTE>>             <<B0.00>>03694000
                 GO TO SCAN1;                                  <<B0.00>>03696000
               END;                                            <<B0.00>>03698000
          END;                                                 <<B0.00>>03700000
      END;                                                     <<B0.00>>03702000
  END                                                          <<B0.00>>03704000
UNTIL (I := I + 1) >= COUNT;   <<STOP AT CARRIAGE RETURN>>     <<B0.00>>03706000
                                                               <<B0.00>>03708000
                                                               <<B0.00>>03710000
END;                                                           <<B0.00>>03712000
$PAGE                                                          <<04145>>03714000
$CONTROL SEGMENT=SPOOK2                                                 03716000
                                                                        03718000
LOGICAL PROCEDURE SPOOLOPEN(DEVF,FILEF);                       <<B0.01>>03720000
   VALUE DEVF;                                                 <<B0.01>>03722000
   INTEGER DEVF,FILEF;                                         <<B0.01>>03724000
                                                               <<B0.01>>03726000
   BEGIN                                                                03728000
   INTEGER TEMP;                                               <<01549>>03730000
   << >>                                                                03732000
   OLDSIR := GETSIR(IF DEVF<0 THEN ODDSIR ELSE IDDSIR);                 03734000
   XDDX := 0;                                                           03736000
   IF COPYXDD(DEVF) THEN                                                03738000
      BEGIN                                                             03740000
      XDDX.(0:1) := DEVF.(0:1);                                         03742000
      IF XDD.(1:2) THEN LOCKXDD(XDDX);                                  03744000
      END;                                                              03746000
   RELSIR(IF DEVF<0 THEN ODDSIR ELSE IDDSIR,OLDSIR);                    03748000
   IF XDDX = 0 THEN                                                     03750000
      BEGIN ERRN := 31; GOTO LX; END;                                   03752000
   IF NOT (XDD.(1:2)) THEN                                              03754000
      BEGIN ERRN := 28; GOTO LX; END;                                   03756000
   FILEF := FSOPEN(,%305,%400,XDDX);                                    03758000
   IF <> THEN                                                           03760000
      BEGIN ERRN := 29; FCHECK(FILEF,ERRF); GOTO LX; END;               03762000
   FREAD(FILEF,SBUF,512); <<READ FIRST BLOCK>>                 <<01549>>03764000
   <<STORE RECNUM OF FIRST NON-PURGED EXTENT IN>>              <<01549>>03766000
   <<FLINE FOR FUTURE USE AND THEN REWIND FILE>>               <<01549>>03768000
   TOS := SBUF(510);                                           <<01549>>03770000
   TOS  := SBUF(511);                                          <<01549>>03772000
   FLINE := TOS - 1D;  <<RECNUM OF BEGINNING OF FILE>>         <<01549>>03774000
   FCONTROL(FILEF,5,TEMP);  <<REWIND FILE>>                    <<01549>>03776000
   SPOOLOPEN := TRUE;                                                   03778000
LX:                                                                     03780000
   END;                                                                 03782000
$PAGE                                                          <<04145>>03784000
$CONTROL SEGMENT=SPOOK1                                                 03786000
                                                                        03788000
LOGICAL PROCEDURE GETMODE;                                              03790000
   BEGIN                                                                03792000
   INTEGER TW,TC;                                                       03794000
   INTEGER CT,Z,NUM;                                                    03796000
   LOGICAL FLAG;                                                        03798000
   << >>                                                                03800000
   TW := FWIDTH;                                                        03802000
   TC := FALL;                                                          03804000
   WHILE BP <> CR  DO                                          <<04145>>03806000
      BEGIN                                                             03808000
      ERRN := 43;                                                       03810000
      MOVE BP := BP WHILE AS,1;                                         03812000
      CT := TOS-@BP;                                                    03814000
      IF NOT (1<=CT<=MSIZE) THEN GOTO LX;                               03816000
      Z := 0;                                                           03818000
      WHILE (Z<MNUM) AND (BP<>MMODE(Z*MSIZE),(CT)) DO                   03820000
         Z := Z+1;                                                      03822000
      IF Z = MNUM THEN GOTO LX;                                         03824000
      IF BP(CT) <> "=" THEN                                             03826000
         BEGIN ERRN := 44; GOTO LX; END;                                03828000
      @BP := @BP+CT+1;                                                  03830000
      ERRN := 45;                                                       03832000
      FLAG := FALSE;                                                    03834000
      NUM := -1;                                                        03836000
      IF BP = ALPHA THEN                                                03838000
         BEGIN                                                          03840000
         IF BP = "ON" THEN                                              03842000
            BEGIN                                                       03844000
            FLAG := TRUE;                                               03846000
            @BP := @BP+2;                                               03848000
            END                                                         03850000
         ELSE                                                           03852000
            IF BP = "OFF" THEN                                          03854000
               BEGIN                                                    03856000
               FLAG := FALSE;                                           03858000
               @BP := @BP+3;                                            03860000
               END                                                      03862000
            ELSE                                                        03864000
               GOTO LX;                                                 03866000
         END                                                            03868000
      ELSE                                                              03870000
         BEGIN                                                          03872000
         IF NOT GETDNUM THEN GOTO LX;                                   03874000
         IF DNUM < 0D THEN                                              03876000
            DNUM := -DNUM                                               03878000
         ELSE                                                           03880000
            DNUM := DNUM&DASL(1);                                       03882000
         IF DNUM0 <> 0 THEN GOTO LX;                                    03884000
         NUM := DNUM1;                                                  03886000
         END;                                                           03888000
      CASE Z OF                                                         03890000
         BEGIN                                                          03892000
         <<0>>                                                          03894000
         IF NUM >= 0 THEN                                               03896000
            TW := NUM                                                   03898000
         ELSE                                                           03900000
            IF NOT FLAG THEN                                            03902000
               TW := 0                                                  03904000
            ELSE GOTO LX;                                               03906000
         <<1>>                                                          03908000
         IF NUM < 0 THEN                                                03910000
            TC := FLAG                                                  03912000
         ELSE                                                           03914000
            GOTO LX;                                                    03916000
         END;                                                           03918000
      ERRN := 0;                                                        03920000
      IF BP = "," THEN @BP := @BP+1;                                    03922000
      END;                                                              03924000
   FWIDTH := TW;                                                        03926000
   FALL := TC;                                                          03928000
   GETMODE := TRUE;                                                     03930000
LX:                                                                     03932000
   END;                                                                 03934000
$PAGE                                                          <<04145>>03936000
$CONTROL SEGMENT=SPOOK1                                                 03938000
                                                                        03940000
LOGICAL PROCEDURE GETALTER;                                             03942000
   BEGIN                                                                03944000
   INTEGER CT,Z;                                                        03946000
   INTEGER ARRAY INFO(0:8);                                             03948000
   << >>                                                                03950000
   PRI := 0;                                                            03952000
   COPIES := 0;                                                         03954000
   CLDEV := 0;                                                          03956000
   WHILE BP <> CR  DO                                          <<04145>>03958000
      BEGIN                                                             03960000
      ERRN := 43;                                                       03962000
      MOVE BP := BP WHILE AS,1;                                         03964000
      CT := TOS-@BP;                                                    03966000
      IF NOT (1<=CT<=ASIZE) THEN GOTO LX;                               03968000
      Z := 0;                                                           03970000
      WHILE (Z<ANUM) AND (BP<>AALTER(Z*ASIZE),(CT)) DO                  03972000
         Z := Z+1;                                                      03974000
      IF Z = ANUM THEN GOTO LX;                                         03976000
      IF BP(CT) <> "=" THEN                                             03978000
         BEGIN ERRN := 44; GOTO LX; END;                                03980000
      @BP := @BP+CT+1;                                                  03982000
      ERRN := 45;                                                       03984000
      CASE Z OF                                                         03986000
         BEGIN                                                          03988000
         <<0>>                                                          03990000
            BEGIN                                                       03992000
            IF NOT GETDNUM THEN GOTO LX;                                03994000
            IF DNUM < 0D THEN GOTO LX;                                  03996000
            IF DNUM0 <> 0 THEN GOTO LX;                                 03998000
            IF NOT (1<=DNUM1<=13) THEN GOTO LX;                         04000000
            PRI := DNUM1;                                               04002000
            END;                                                        04004000
         <<1>>                                                          04006000
            BEGIN                                                       04008000
            IF NOT GETDNUM THEN GOTO LX;                                04010000
            IF DNUM < 0D THEN GOTO LX;                                  04012000
            IF DNUM0 <> 0 THEN GOTO LX;                                 04014000
            IF NOT (1<=DNUM1<=127) THEN GOTO LX;                        04016000
            COPIES := DNUM1;                                            04018000
            END;                                                        04020000
         <<2>>                                                          04022000
            BEGIN                                                       04024000
            IF (GETDEVINFO(BP,INFO) <> 0) THEN GOTO LX;                 04026000
            IF SPOOLEDDEV(INFO).(14:2) = 0 THEN GOTO LX;                04028000
            IF BP = "+" OR BP = "-" THEN @BP := @BP+1;                  04030000
            MOVE BP := BP WHILE ANS,1;                                  04032000
            @BP := TOS;                                                 04034000
            TOS := INFO;                                                04036000
            IF < THEN                                                   04038000
               BEGIN                                                    04040000
               TOS := -TOS;                                             04042000
               TOS.(7:1) := 1;                                          04044000
               END;                                                     04046000
            CLDEV := TOS;                                               04048000
            END;                                                        04050000
         END;                                                           04052000
      ERRN := 0;                                                        04054000
      IF BP = "," THEN @BP := @BP+1;                                    04056000
      END;                                                              04058000
   GETALTER := TRUE;                                                    04060000
LX:                                                                     04062000
   END;                                                                 04064000
$PAGE                                                          <<04145>>04066000
$CONTROL SEGMENT=SPOOK2                                                 04068000
                                                                        04070000
<<******************A L T E R X D D ************************>> <<04145>>04072000
<< ALTERXDD is sent a device file id.  It calls COPYXDD to  >> <<04145>>04074000
<< copy an XDD entry into stack.  If then changes one to all>> <<04145>>04076000
<< of the following before copying the entry back into the  >> <<04145>>04078000
<< XDD: number of copies, priority, and device.             >> <<04145>>04080000
<<**********************************************************>> <<04145>>04082000
                                                               <<04145>>04084000
LOGICAL PROCEDURE ALTERXDD(DEVF);                              <<B0.01>>04086000
   VALUE DEVF;                                                 <<B0.01>>04088000
   INTEGER DEVF;                                               <<B0.01>>04090000
                                                               <<B0.01>>04092000
   BEGIN                                                                04094000
   INTEGER INDEX;                                                       04096000
   LOGICAL RLINK;                                                       04098000
   LOGICAL SAVSIR;                                             <<00897>>04100000
   << >>                                                                04102000
   RLINK := FALSE;                                                      04104000
   XDDX := 0;                                                           04106000
   SAVSIR := GETSIR(LDTSIR);                                   <<00897>>04108000
   OLDSIR := GETSIR(IF DEVF<0 THEN ODDSIR ELSE IDDSIR);                 04110000
                                                               <<04145>>04112000
   <<*******************************************************>> <<04145>>04114000
   << Copy the XDD entry onto stack and change the local    >> <<04145>>04116000
   << values to COPIES, PRI or CLDEV if specified.          >> <<04145>>04118000
   <<*******************************************************>> <<04145>>04120000
                                                               <<04145>>04122000
   IF NOT COPYXDD(DEVF) THEN                                            04124000
      BEGIN ERRN := 31; GOTO LX; END;                                   04126000
   IF XDD.(1:2) = 0 THEN                                                04128000
      BEGIN ERRN := 47; GOTO LX; END;                                   04130000
   IF COPIES <> 0 THEN                                                  04132000
      XDD(24).(8:8) := COPIES;                                          04134000
   IF PRI <> 0 THEN                                                     04136000
      BEGIN                                                             04138000
      OLD'PRI := XDD.(3:4); <<SAVE OLD PRIORITY>>              <<B0.01>>04140000
      XDD.(3:4) := PRI;                                                 04142000
      RLINK := TRUE;                                                    04144000
      END;                                                              04146000
   IF CLDEV <> 0 THEN                                                   04148000
      BEGIN                                                             04150000
      XDD.(7:9) := CLDEV;                                               04152000
      RLINK := TRUE;                                                    04154000
      END;                                                              04156000
                                                               <<04145>>04158000
   <<*******************************************************>> <<04145>>04160000
   << If we have changed the device of an ODD entry, then   >> <<04145>>04162000
   << we must relink the ODD via SRELINKODD because the ODD >> <<04145>>04164000
   << is ordered by LDEV and Class name.                    >> <<04145>>04166000
   <<*******************************************************>> <<04145>>04168000
                                                               <<04145>>04170000
                                                               <<04145>>04172000
   <<*******************************************************>> <<04145>>04174000
   << Now copy the changed XDD entry back to the ODD or IDD.>> <<04145>>04176000
   << The offset of the entry in the XDD is pointed to by   >> <<04145>>04178000
   << XDDX, set by COPYXDD, and the stack array is pointed  >> <<04145>>04180000
   << to by XDD, set in the calling procedure.              >> <<04145>>04182000
   <<*******************************************************>> <<04145>>04184000
                                                               <<04145>>04186000
   TOS := IF DEVF < 0 THEN ODDDST ELSE IDDDST;                          04188000
   TOS := XDDX;                                                         04190000
   TOS := @XDD;                                                         04192000
   TOS := 30;                                                           04194000
   ASSEMBLE (MTDS 4);                                                   04196000
   IF RLINK AND DEVF < 0 THEN                                           04198000
      BEGIN                                                             04200000
      INDEX := XDDX;                                                    04202000
      EXCHANGEDB(ODDDST);                                               04204000
      TOS := BASE(INDEX).(8:8);                                         04206000
      IF BASE(INDEX).(7:1) = 1 THEN TOS := -TOS;                        04208000
      ASSEMBLE(DUP);                                                    04210000
      TOS := INDEX;                                                     04212000
      ASSEMBLE(CAB);                                                    04214000
      SRELINKODD(*,*);                                                  04216000
         EXCHANGEDB(0);                                        <<01.02>>04218000
      RELSIR(ODDSIR,OLDSIR);   <<RELEASE SIR          >>       <<01.02>>04220000
      SROOSTER(*);                                                      04222000
   ALTERXDD := TRUE;                                           <<01.02>>04224000
   GO TO LX1;     <<BYPASS REPEAT OF RELSIR>>                  <<01.02>>04226000
<<  >>                                                         <<01.02>>04228000
      END;                                                              04230000
   ALTERXDD := TRUE;                                                    04232000
LX:                                                                     04234000
   RELSIR(IF DEVF<0 THEN ODDSIR ELSE IDDSIR,OLDSIR);                    04236000
LX1:                                                           <<01.02>>04238000
   RELSIR(LDTSIR,SAVSIR);                                      <<00897>>04240000
   END;                                                                 04242000
$PAGE                                                          <<04145>>04244000
$CONTROL SEGMENT=SPOOK2                                        <<01.02>>04246000
INTEGER PROCEDURE FINDODD(XDDNUM);                             <<01.02>>04248000
VALUE XDDNUM;                                                  <<01.02>>04250000
INTEGER XDDNUM;                                                <<01.02>>04252000
BEGIN                                                          <<01.02>>04254000
<<  >>                                                         <<01.02>>04256000
      << PROCEDURE ADDED 6/20/77         >>                    <<01.02>>04258000
   INTEGER INDEX;                                              <<01.02>>04260000
   INDEX:=XDDNUM.(1:15);                                       <<01.02>>04262000
   EXCHANGEDB(ODDDST);                                         <<01.02>>04264000
   TOS:=BASE(INDEX).(8:8);                                     <<01.02>>04266000
      IF BASE(INDEX).(7:1)=1 THEN TOS:=-TOS;                   <<01.02>>04268000
      EXCHANGEDB(0);                                           <<01.02>>04270000
      FINDODD:=TOS;                                            <<01.02>>04272000
      END;                                                     <<01.02>>04274000
                                                                        04276000
$PAGE                                                          <<04145>>04278000
<<**********************************************************>> <<04145>>04280000
<<  GETFILES obtains the device files from the command      >> <<04145>>04282000
<< string and sets up the array DEVFS via GETDEVF.  The     >> <<04145>>04284000
<< value of SHW depends on what is allowed and what type of >> <<04145>>04286000
<< file ID we are dealing with, Input or Output.  SHOWIO is >> <<04145>>04288000
<< set in this procedure and it signifies what types of     >> <<04145>>04290000
<< files we are dealing with.  If bit 15 of SHOWIO is on,   >> <<04145>>04292000
<< we have at least one OUTPUT Dev. ID, if 14 is on we have >> <<04145>>04294000
<< at least one INPUT Dev. ID.                              >> <<04145>>04296000
<<                                                          >> <<04145>>04298000
<<    Command        SHW            Allowed        Type     >> <<04145>>04300000
<<   SHOW             1     DFID,USER.ACCOUNT,*    I & O    >> <<04145>>04302000
<<   OUTPUT & COPY    2     DFID,USER.ACCOUNT,*    O only   >> <<04145>>04304000
<<   PURGE            3     DFID,*                 O only   >> <<04145>>04306000
<<   ALTER            4     DFID,USER.ACCOUNT,*    O only   >> <<04145>>04308000
<<   INPUT            0     DFID,USER.ACCOUNT      O only   >> <<04145>>04310000
<<**********************************************************>> <<04145>>04312000
                                                               <<04145>>04314000
$CONTROL SEGMENT=SPOOK1                                                 04316000
                                                                        04318000
LOGICAL PROCEDURE GETFILES(SHW);                                        04320000
   VALUE   SHW;                                                         04322000
   LOGICAL SHW;                                                         04324000
   BEGIN                                                                04326000
     LOGICAL NOFILES;                                          <<04145>>04328000
   << >>                                                                04330000
   DEVFC := 0;                                                          04332000
                                                               <<04145>>04334000
   <<*******************************************************>> <<04145>>04336000
   << If the command sting gives a list of device ID's or a >> <<04145>>04338000
   << "*", then obtain all the device ID's in the list.     >> <<04145>>04340000
   <<*******************************************************>> <<04145>>04342000
                                                               <<04145>>04344000
   IF BP = "#" OR BP = "*" OR BP = NUMERIC THEN                         04346000
      BEGIN                                                             04348000
      SHOWIO := 0;                                                      04350000
      DO                                                                04352000
         BEGIN                                                          04354000
         IF INTEGER(SHW)=0 AND BP="*" THEN                              04356000
            BEGIN ERRN:=48; GOTO LX; END;                               04358000
         IF NOT GETDEVF THEN GOTO LX;                                   04360000
         TOS := IF DEVF < 0 THEN 1 ELSE 2;                              04362000
         SHOWIO := SHOWIO LOR TOS;                                      04364000
         NOFILES:=TRUE;                                        <<04145>>04366000
         IF BP = "," THEN                                               04368000
            BEGIN                                                       04370000
            NOFILES:=FALSE;                                    <<04145>>04372000
            @BP := @BP+1;                                               04374000
            END;                                                        04376000
         END                                                            04378000
      UNTIL NOFILES;                                           <<04145>>04380000
      SHOWF := TRUE;                                                    04382000
      END                                                               04384000
$PAGE                                                          <<04145>>04386000
                                                               <<04145>>04388000
   <<*******************************************************>> <<04145>>04390000
   <<  If the string gives a USER.ACCOUNT obtains it via    >> <<04145>>04392000
   << GETUSAD. (3 is sent by PURGE, USER.ACCOUNT is illegal >> <<04145>>04394000
   << for PURGE.)  Then, if we have the SHOW command (SHW   >> <<04145>>04396000
   << has value 1) and a ";" follows, look for "@","O" and/ >> <<04145>>04398000
   << or "I".  "@" signifies show all information and the   >> <<04145>>04400000
   << flag SHOWF is set to TRUE.  If no USER.ACCOUNT is     >> <<04145>>04402000
   << specified and we have ALTER command, return error.    >> <<04145>>04404000
   <<*******************************************************>> <<04145>>04406000
                                                               <<04145>>04408000
   ELSE                                                                 04410000
      BEGIN                                                             04412000
      IF SHW = 3 THEN                                                   04414000
         BEGIN ERRN := 56; GOTO LX; END;                                04416000
      IF (BP = ";" OR BP = CR) AND SHW = 4 THEN                <<04145>>04418000
         BEGIN ERRN := 80; GOTO LX; END;                       <<04145>>04420000
      IF NOT GETUSAC THEN GOTO LX;                                      04422000
      SHOWIO := IF SHW THEN 3 ELSE 1;                                   04424000
      SHOWF := FALSE;                                                   04426000
      IF SHW AND BP = ";" THEN                                          04428000
         BEGIN                                                          04430000
         DO                                                             04432000
            BEGIN                                                       04434000
            @BP := @BP+1;                                               04436000
            IF BP = "@" THEN SHOWF := TRUE                              04438000
            ELSE IF BP = "I" THEN SHOWIO := SHOWIO LAND 2               04440000
                 ELSE IF BP = "O" THEN SHOWIO := SHOWIO LAND 1          04442000
                      ELSE IF BP <> CR  THEN                   <<04145>>04444000
                              BEGIN ERRN:=33; GOTO LX; END;             04446000
            END                                                         04448000
         UNTIL BP = CR ;                                       <<04145>>04450000
         IF SHOWIO = 0 THEN SHOWIO := 3;                                04452000
         END;                                                           04454000
      END;                                                              04456000
                                                               <<04145>>04458000
   <<*******************************************************>> <<04145>>04460000
   << Set SHOWIO to output only  unless we are using the    >> <<04145>>04462000
   << "SHOW" command, the only one that uses INPUT Dev. ID's>> <<04145>>04464000
   <<*******************************************************>> <<04145>>04466000
                                                               <<04145>>04468000
   IF INTEGER(SHW) <> 1 THEN SHOWIO := 1;                               04470000
   GETFILES := TRUE;                                                    04472000
LX:                                                                     04474000
   END;                                                                 04476000
                                                                        04478000
$PAGE                                                          <<04145>>04480000
<<**********************************************************>> <<04145>>04482000
<< MOVEFROMXDD moves all the significant entries for the    >> <<04145>>04484000
<< OUTPUT and/or INPUT DEVICE DIRECTORIES into the area be- >> <<04145>>04486000
<< tween DB-2048 and DL(expanding it via DLSIZE as needed), >> <<04145>>04488000
<< or DB-0 and DL, depending on the command being executed. >> <<04145>>04490000
<< It finds the entries that have Device ID's in the array  >> <<04145>>04492000
<< DEVFS or qualify via our USER.ACCOUNT in SNAMES.  Based  >> <<04145>>04494000
<< on SHOWIO, it will search the IDD and/or ODD.  The XDD   >> <<04145>>04496000
<< entries are stored as follows:                           >> <<04145>>04498000
<<           DL----->----------                             >> <<04145>>04500000
<<                   |        |                             >> <<04145>>04502000
<<                   ~        ~                             >> <<04145>>04504000
<<                   |--------|<-----DB-INITXDDP-90         >> <<04145>>04506000
<<                   |  XDD3  |                             >> <<04145>>04508000
<<                   |--------|<-----DB-INITXDDP-60         >> <<04145>>04510000
<<                   |  XDD2  |                             >> <<04145>>04512000
<<                   |--------|<-----DB-INITXDDP-30         >> <<04145>>04514000
<<                   |  XDD1  |                             >> <<04145>>04516000
<<     INITXDDP----->|--------|                             >> <<04145>>04518000
<< (DB-2048 or DB-0) ~        ~                             >> <<04145>>04520000
<<                   |        |                             >> <<04145>>04522000
<<           DB----->|--------|                             >> <<04145>>04524000
<<                                                          >> <<04145>>04526000
<<  Shown below is the value of IO on first and second pass >> <<04145>>04528000
<<  through the main loop based on the value of SHOWIO.     >> <<04145>>04530000
<<                                                          >> <<04145>>04532000
<<   SHOWIO        IO first pass          IO second pass    >> <<04145>>04534000
<<  %2(11) I&O   %2(11) (O in effect)   %2(10) (I in effect)>> <<04145>>04536000
<<     01  O only   01   O "     "      No second pass      >> <<04145>>04538000
<<     10  I only   10   I "     "      No second pass      >> <<04145>>04540000
<<                                                          >> <<04145>>04542000
<<  First obtain proper SIR. Turn to bit of DEVF on for O   >> <<04145>>04544000
<<  and off for I.                                          >> <<04145>>04546000
<<**********************************************************>> <<04145>>04548000
                                                               <<04145>>04550000
$CONTROL SEGMENT=SPOOK2                                                 04552000
                                                                        04554000
LOGICAL PROCEDURE MOVEFROMXDD;                                 <<04145>>04556000
   BEGIN                                                                04558000
   INTEGER COUNT;                                              <<04145>>04560000
   LOGICAL ERROR,F,G,IO,                                       <<04145>>04562000
           FOUND=MOVEFROMXDD;  <<Signify at least one found >> <<04145>>04564000
   INTEGER POINTER XDDP;                                                04566000
   << >>                                                                04568000
   MOVEFROMXDD := FALSE;                                       <<04145>>04570000
   FILE'FOUND := TRUE;                                         <<04145>>04572000
   IO := SHOWIO;                                                        04574000
   XDDC := 0;                                                           04576000
   @XDDP := INITXDDP;                                                   04578000
   ERROR := FALSE;                                             <<04145>>04580000
   DO                                                                   04582000
      BEGIN                                                             04584000
      OLDSIR := GETSIR(IF IO THEN ODDSIR ELSE IDDSIR);                  04586000
      DEVF := IO&LSL(15);                                               04588000
      COUNT := -1;                                             <<04145>>04590000
$PAGE                                                          <<04145>>04592000
      <<****************************************************>> <<04145>>04594000
      << DO UNTIL and ERROR or UNTIL there are still Device >> <<04145>>04596000
      << ID's in the array DEVFS for which to copy thier XDD>> <<04145>>04598000
      << entry (done via COPYXDD).                          >> <<04145>>04600000
      <<****************************************************>> <<04145>>04602000
                                                               <<04145>>04604000
      DO                                                                04606000
         BEGIN                                                          04608000
         F := (DEVFC <> 0);                                             04610000
         G := TRUE;                                                     04612000
         IF F THEN                                                      04614000
            BEGIN                                                       04616000
            G := FALSE;                                                 04618000
            WHILE NOT G DO                                              04620000
               BEGIN                                                    04622000
               IF (COUNT:=COUNT+1) >= DEVFC THEN GOTO L;       <<04145>>04624000
               DEVF := DEVFS(COUNT);                           <<04145>>04626000
               IF < THEN G := IO                                        04628000
                    ELSE IF > THEN G := NOT IO;                         04630000
               END;                                                     04632000
      L:                                                                04634000
            F := G;                                                     04636000
            END;                                                        04638000
         XDDX := 0;                                                     04640000
         WHILE G DO                                                     04642000
            BEGIN                                                       04644000
            TOS := COPYXDD(DEVF);                                       04646000
            IF NOT TOS THEN                                             04648000
               G := FALSE                                               04650000
            ELSE                                                        04652000
               BEGIN                                                    04654000
               XDDC := XDDC+1;                                          04656000
               @XDDP := @XDDP-30;                                       04658000
                                                               <<04145>>04660000
         <<*************************************************>> <<04145>>04662000
         <<  If, after updating the address of the XDD en-  >> <<04145>>04664000
         << tries (XDDPoint), it is set before DL (DL>@XDDP)>> <<04145>>04666000
         << then expand DL via DLSIZE and check for errors. >> <<04145>>04668000
         <<*************************************************>> <<04145>>04670000
                                                               <<04145>>04672000
         LL:                                                            04674000
               PUSH(DL);                                                04676000
               IF S0 > @XDDP THEN                                       04678000
                  BEGIN                                                 04680000
                  DLSIZE(S0-512);                                       04682000
                  IF = THEN                                             04684000
                     BEGIN                                              04686000
                     DEL;                                               04688000
                     GOTO LL;                                           04690000
                     END                                                04692000
                  ELSE                                                  04694000
                     BEGIN                                              04696000
                     WARN := 3;                                         04698000
                     ERROR := TRUE;                            <<04145>>04700000
                     G := FALSE;                                        04702000
                     XDDC := XDDC-1;                                    04704000
                     @XDDP := @XDDP+30;                                 04706000
                     END;                                               04708000
                  END;                                                  04710000
               DEL;                                                     04712000
               END;                                                     04714000
                                                               <<04145>>04716000
             <<*********************************************>> <<04145>>04718000
             << If we copied an XDD entry, blank out the    >> <<04145>>04720000
             << link pointer (XDD(25)), then zero out the   >> <<04145>>04722000
             << entry in our DEVFS array.                   >> <<04145>>04724000
             <<*********************************************>> <<04145>>04726000
                                                               <<04145>>04728000
            IF G THEN                                                   04730000
               BEGIN                                                    04732000
               XDD(25) := 0;                                            04734000
               MOVE XDDP := XDD,(30);                                   04736000
               DEVFS(COUNT) := 0;                              <<04145>>04738000
               MOVEFROMXDD := TRUE;                            <<04145>>04740000
               END;                                                     04742000
            IF F THEN G := FALSE;                                       04744000
            END;                                                        04746000
         END                                                            04748000
      UNTIL NOT F OR ERROR;                                    <<04145>>04750000
      RELSIR(IF IO THEN ODDSIR ELSE IDDSIR,OLDSIR);                     04752000
      IO := IO LAND (IF IO THEN 2 ELSE 0);                              04754000
      END                                                               04756000
   UNTIL IO = 0 OR ERROR;                                      <<04145>>04758000
                                                               <<04145>>04760000
   IF FOUND                                                    <<04145>>04762000
      THEN USERF := ACCTF := FALSE                             <<04145>>04764000
      ELSE IF USERF OR ACCTF                                   <<04145>>04766000
           THEN FILE'FOUND := FALSE;                           <<04145>>04768000
                                                               <<04145>>04770000
   END;                                                                 04772000
$PAGE                                                          <<04145>>04774000
                                                                        04776000
$CONTROL SEGMENT=SPOOK2                                                 04778000
                                                                        04780000
PROCEDURE SHOWFILES;                                                    04782000
   BEGIN                                                                04784000
   INTEGER C;                                                           04786000
   INTEGER POINTER XDDP;                                                04788000
   << >>                                                                04790000
   IF XDDC > 0 THEN                                                     04792000
      BEGIN                                                             04794000
      SHOWP := FALSE;                                                   04796000
      DO                                                                04798000
         BEGIN                                                          04800000
         IF SHOWP THEN PRINT(MSHWX,29,0)                                04802000
         ELSE IF SHOWF THEN PRINT(MSHOW,29,0)                           04804000
                       ELSE PRINT(MSHOWS,19,0);                         04806000
         C := 0;                                                        04808000
         @XDDP := INITXDDP;                                             04810000
         WHILE (C:=C+1) <= XDDC DO                                      04812000
            BEGIN                                                       04814000
            @XDDP := @XDDP-30;                                          04816000
            MOVE XDD := XDDP,(30);                                      04818000
            TOS := 0;                                                   04820000
            IF SHOWP THEN TOS.(15:1) := 1;                              04822000
            IF SHOWF THEN TOS.(14:1) := 1;                              04824000
            SHOWXDD(*,0);                                               04826000
            END;                                                        04828000
         SHOWP := SHOWP+1;                                              04830000
         END                                                            04832000
      UNTIL NOT SHOWP OR NOT SHOWF;                                     04834000
      END;                                                              04836000
   END;                                                                 04838000
                                                                        04840000
$PAGE                                                          <<04145>>04842000
<<**********************************************************>> <<04145>>04844000
<< OPENTAPE is called by the INPUT and OUTPUT commands to   >> <<04145>>04846000
<< open the tape file to read from or write to.  OUT=1 for  >> <<04145>>04848000
<< the OUTPUT command and 0 for the INPUT command.          >> <<04145>>04850000
<<**********************************************************>> <<04145>>04852000
                                                               <<04145>>04854000
$CONTROL SEGMENT=SPOOK3                                                 04856000
                                                                        04858000
LOGICAL PROCEDURE OPENTAPE(OUT);                                        04860000
   VALUE   OUT;                                                         04862000
   LOGICAL OUT;                                                         04864000
   BEGIN                                                                04866000
   INTEGER C,P;                                                         04868000
   INTEGER F,A,R,D,B;                                                   04870000
   INTEGER FX,AX,RX,DX,BX,LD;                                           04872000
   INTEGER SDISC;                                              <<B0.00>>04874000
   << >>                                                                04876000
   SUBROUTINE EOFIN;                                                    04878000
      BEGIN                                                             04880000
      FREAD(FILET,SBUF,1);                                              04882000
      IF < THEN GOTO LY;                                                04884000
      IF = THEN GOTO LZ;                                                04886000
      END;                                                              04888000
   << >>                                                                04890000
   SUBROUTINE EOFOUT;                                                   04892000
      BEGIN                                                             04894000
      FCONTROL(FILET,6,P);                                              04896000
      IF <> THEN GOTO LY;                                               04898000
      END;                                                              04900000
   << >>                                                                04902000
                                                               <<04145>>04904000
   <<*******************************************************>> <<04145>>04906000
   << FOPEN the tape file with the following parms:         >> <<04145>>04908000
   << FOPTION - Undef. recs,ASCII, No labled tapes, Domain= >> <<04145>>04910000
   <<           New file for OUT, Old Perm. for INPUT.      >> <<04145>>04912000
   << AOPTION - NOBUF, EXCLUSIVE, Read for IN, Write for OUT>> <<04145>>04914000
   << Record size - 1024 words.                             >> <<04145>>04916000
   <<*******************************************************>> <<04145>>04918000
                                                               <<04145>>04920000
   F:= IF OUT THEN %204 ELSE %205;                            <<B0.00>> 04922000
   A := OUT LOR %500;                                                   04924000
   R := 1024;                                                           04926000
   D := 24;                                                             04928000
   SDISC := 31;    <<SERIAL DISC>>                             <<B0.00>>04930000
   B := 1024;                                                           04932000
   IF BP = CR  THEN                                            <<04145>>04934000
      BEGIN ERRN := 52; GOTO LX; END;                                   04936000
   FILET := FOPEN(BP,F,A,R);                                            04938000
   IF <> THEN                                                           04940000
      BEGIN ERRN := 50; FCHECK(FILET,ERRF); GOTO LX; END;               04942000
$PAGE                                                          <<04145>>04944000
                                                               <<04145>>04946000
   <<*******************************************************>> <<04145>>04948000
   << Since a FILE command can over-ride the above parms,   >> <<04145>>04950000
   << check for compatibility.                              >> <<04145>>04952000
   <<  REC. and Block size - convert to words.              >> <<04145>>04954000
   <<*******************************************************>> <<04145>>04956000
                                                               <<04145>>04958000
   FGETINFO(FILET,,FX,AX,RX,DX,LD,,,,,,,,BX);                           04960000
   IF RX < 0 THEN RX := (-RX)&ASR(1);                                   04964000
   IF BX < 0 THEN BX := (-BX)&ASR(1);                                   04966000
                                                               <<04145>>04968000
   <<*******************************************************>> <<04145>>04970000
   << Now check for FOPTION,AOPTION,REC. and BLOCK size     >> <<04145>>04972000
   << compatibiltiy.  Also, check for proper type, 24 for   >> <<04145>>04974000
   << mag tape or 31 for serial disc.                       >> <<04145>>04976000
   <<*******************************************************>> <<04145>>04978000
                                                               <<04145>>04980000
   IF F<>FX OR A<>AX OR R<>RX OR B<>BX                         <<B0.00>>04982000
      OR NOT((D=DX.(8:8)) LOR (SDISC = DX.(8:8))) THEN         <<00897>>04984000
      BEGIN ERRN := 52; GOTO LY; END;                                   04986000
   MREEL(11) := "  ";                                                   04988000
   MREEL(12) := "  ";                                                   04990000
   ASCII(LD,10,MREEL(11));                                              04992000
   REEL := 1;                                                           04994000
   EOTMARK := FALSE;                                                    04996000
   LASTREEL := FALSE;                                                   04998000
   FILEEND := TRUE;                                                     05000000
                                                               <<04145>>05002000
   <<*******************************************************>> <<04145>>05004000
   << For INPUT, first skip over 2 EOF's via EOFIN.  Next,  >> <<04145>>05006000
   << read 40 word Label Record.  Compare reel number on    >> <<04145>>05008000
   << tape with REEL and check words 0-13 for TAPEID. Lastly>> <<04145>>05010000
   << obtain DATE and TIME and skip over next EOF.          >> <<04145>>05012000
   <<*******************************************************>> <<04145>>05014000
                                                               <<04145>>05016000
   IF NOT OUT THEN                                                      05018000
      BEGIN                                                             05020000
      ERRN := 54;                                                       05022000
      EOFIN;                                                            05024000
      EOFIN;                                                            05026000
      TCOUNT := FREAD(FILET,TBUF,41);                                   05028000
      IF <> THEN GOTO LY;                                               05030000
      IF TCOUNT <> 40 THEN GOTO LZ;                                     05032000
      IF INTEGER(TBUF(23)) <> REEL THEN GOTO LZ;                        05034000
      C := -1;                                                          05036000
      WHILE (C:=C+1)<14 DO IF TBUF(C) <> TAPEID(C) THEN GOTO LZ;        05038000
      DATE := TBUF(24);                                                 05040000
      TIME1 := TBUF(25);                                                05042000
      TIME2 := TBUF(26);                                                05044000
      EOFIN;                                                            05046000
      END                                                               05048000
$PAGE                                                          <<04145>>05050000
                                                               <<04145>>05052000
   <<*******************************************************>> <<04145>>05054000
   << For OUTPUT, we set up the beginnig of the tape:       >> <<04145>>05056000
   <<      EOF,EOF,                                         >> <<04145>>05058000
   <<      Label Record contains:                           >> <<04145>>05060000
   <<          Words 0-13: "SPOOLFILETAPE LABEL-HP3000."    >> <<04145>>05062000
   <<          Word   23 : Reel number (1 to last)          >> <<04145>>05064000
   <<          Word   24 : DATE                             >> <<04145>>05066000
   <<          Words 25-26: TIME                            >> <<04145>>05068000
   <<      All other words zero.                            >> <<04145>>05070000
   <<*******************************************************>> <<04145>>05072000
                                                               <<04145>>05074000
   ELSE                                                                 05076000
      BEGIN                                                             05078000
      TBUF := 0;                                                        05080000
      MOVE TBUF(1) := TBUF,(39);                                        05082000
      MOVE TBUF := TAPEID,(14);                                         05084000
      TBUF(23) := REEL;                                                 05086000
      DATE := CALENDAR;                                                 05088000
      TIME := CLOCK;                                                    05090000
      TBUF(24) := DATE;                                                 05092000
      TBUF(25) := TIME1;                                                05094000
      TBUF(26) := TIME2;                                                05096000
      ERRN := 55;                                                       05098000
      EOFOUT;                                                           05100000
      EOFOUT;                                                           05102000
      FWRITE(FILET,TBUF,40,0);                                          05104000
      IF <> THEN GOTO LY;                                               05106000
      EOFOUT;                                                           05108000
      END;                                                              05110000
   ERRN := 0;                                                           05112000
   OPENTAPE := TRUE;                                                    05114000
   GOTO LX;                                                             05116000
LZ:                                                                     05118000
   ERRN := 53;                                                          05120000
LY:                                                                     05122000
   FCLOSE(FILET,1,0);                                          <<02724>>05124000
   FILET := 0;                                                          05126000
LX:                                                                     05128000
   END;                                                                 05130000
$PAGE                                                          <<04145>>05132000
$CONTROL SEGMENT=SPOOK3                                                 05134000
                                                                        05136000
LOGICAL PROCEDURE INDIRECTORY;                                          05138000
   BEGIN                                                                05140000
   INTEGER C,IX,P;                                                      05142000
   INTEGER ABSLPDT,DVC,V,DX,VX,D,DD,DC,DT;                              05144000
   LOGICAL F;                                                           05146000
   INTEGER POINTER XDDP;                                                05148000
   INTEGER POINTER DCP;                                                 05150000
   INTEGER POINTER DPTR;                                       <<02686>>05152000
   INTEGER ARRAY ADVC(*)=Q;  <<LAST DECL>>                              05154000
   << >>                                                                05156000
   INTEGER SUBROUTINE TESTLD;                                           05158000
      BEGIN                                                             05160000
      IF ADVC(2).(10:6)=INTEGER(BASE(DVC*5+2)                           05162000
                           .(10:6)) THEN                                05164000
         BEGIN                                                          05166000
         TESTLD := 1;                                                   05168000
         IF ADVC(1).(0:8)=ABSOLUTE(ABSLPDT+DVC*2                        05170000
                             +1).(12:4) THEN                            05172000
            BEGIN                                                       05174000
            TESTLD := 2;                                                05176000
            IF ADVC(2).(0:8)=INTEGER(BASE(DVC*5+2)                      05178000
                                .(0:8)) THEN                            05180000
               TESTLD := 3;                                             05182000
            END;                                                        05184000
         END;                                                           05186000
      IF INTEGER(ABSOLUTE(ABSLPDT+DVC*2)) <= 0 THEN                     05188000
            TESTLD := 0;  <<ILLEGAL OR VIRTUAL>>                        05190000
      END;                                                              05192000
   << >>                                                                05194000
   INTEGER SUBROUTINE TESTCL;                                           05196000
      BEGIN                                                             05198000
      V := 0;                                                           05200000
      DC := BASE(D+5).(0:8);                                            05202000
      WHILE DC > 0 DO                                                   05204000
         BEGIN                                                          05206000
         DVC := IF LOGICAL(DC) THEN BASE(D+5+(DC/2)).(8:8)              05208000
                               ELSE BASE(D+5+(DC/2)).(0:8);             05210000
         DT := BASE(DVC*5+2).(10:6);                                    05212000
         DD := ADVC(7);                                                 05214000
         WHILE (DD:=DD-1) >= 0 DO                                       05216000
            IF ADVC(8+DD) = DT THEN V := V+1;                           05218000
         DC := DC-1;                                                    05220000
         END;                                                           05222000
      IF V <> 0 THEN                                                    05224000
         BEGIN                                                          05226000
         V := 0;                                                        05228000
         DC := 4;                                                       05230000
         WHILE (DC:=DC-1) >= 0 DO                              <<01.01>>05232000
            IF INTEGER(BASE(D+DC)) <> ADVC(2+DC) THEN                   05234000
               V := V+1;                                                05236000
         TESTCL := IF V=0 THEN 2 ELSE 1;                                05238000
         END;                                                           05240000
      END;                                                              05242000
   << >>                                                       <<02686>>05244000
   INTEGER SUBROUTINE GETTYPE;                                 <<02686>>05246000
      BEGIN                                                    <<02686>>05248000
      GETTYPE:=0;                                              <<02686>>05250000
      @DPTR:=INITXDDP;                                         <<02686>>05252000
      WHILE DPTR<>0 DO                                         <<02686>>05254000
         BEGIN                                                 <<02686>>05256000
         IF DPTR=DVC THEN                                      <<02686>>05258000
            BEGIN                                              <<02686>>05260000
            GETTYPE:=DPTR(2).(10:6);                           <<02686>>05262000
            RETURN;                                            <<02686>>05264000
            END;                                               <<02686>>05266000
         @DPTR:=@DPTR+DPTR(1).(8:8);                           <<02686>>05268000
         END;                                                  <<02686>>05270000
      END;                                                     <<02686>>05272000
   << >>                                                                05274000
   XDDC := 0;                                                           05276000
   @XDDP := INITXDDP;                                                   05278000
   FILE'FOUND := TRUE;                                         <<04329>>05280000
   F := FALSE;                                                          05282000
   DO                                                                   05284000
      BEGIN                                                             05286000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 05288000
      IF < THEN GOTO LZ;                                                05290000
      IF > THEN GOTO LY;                                                05292000
      IF TCOUNT <> 1020 THEN                                            05294000
         F := TRUE                                                      05296000
      ELSE                                                              05298000
         BEGIN                                                          05300000
         IX := 0;                                                       05302000
         DO                                                             05304000
            BEGIN                                                       05306000
            IF SBUF(IX) = 0 THEN                                        05308000
               F := TRUE                                                05310000
            ELSE                                                        05312000
               BEGIN                                                    05314000
               XDDC := XDDC+1;                                          05316000
               @XDDP := @XDDP-30;                                       05318000
         LL:                                                            05320000
               PUSH(DL);                                                05322000
               IF S0 > @XDDP THEN                                       05324000
                  BEGIN                                                 05326000
                  DLSIZE(S0-512);                                       05328000
                  IF = THEN                                             05330000
                     BEGIN                                              05332000
                     DEL;                                               05334000
                     GOTO LL;                                           05336000
                     END                                                05338000
                  ELSE                                                  05340000
                     BEGIN                                              05342000
                     WARN := 3;                                         05344000
                     F := TRUE;                                         05346000
                     XDDC := XDDC-1;                                    05348000
                     @XDDP := @XDDP+30;                                 05350000
                     END;                                               05352000
                  END;                                                  05354000
               DEL;                                                     05356000
               IF NOT F THEN MOVE XDDP := SBUF(IX),(12);                05358000
               END;                                                     05360000
            END                                                         05362000
         UNTIL F OR (IX:=IX+12) >= 1020;                                05364000
         END;                                                           05366000
      END                                                               05368000
   UNTIL F;                                                             05370000
   WHILE TCOUNT = 1020 DO                                               05372000
      BEGIN                                                             05374000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 05376000
      IF < THEN GOTO LZ;                                                05378000
      IF > THEN GOTO LY;                                                05380000
      END;                                                              05382000
   IF TCOUNT <> 1024 THEN GOTO LY;                                      05384000
   @DCP := INITXDDP;                                                    05386000
   MOVE DCP := SBUF,(1024);                                             05388000
   TCOUNT := FREAD(FILET,SBUF,1024);                                    05390000
   IF < THEN GOTO LZ;                                                   05392000
   IF = THEN                                                            05394000
      BEGIN                                                             05396000
      IF TCOUNT <> 1024 THEN GOTO LY;                                   05398000
      MOVE DCP(1024) := SBUF,(1024);                                    05400000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 05402000
      IF < THEN GOTO LZ;                                                05404000
      IF = THEN GOTO LY;                                                05406000
      END;                                                              05408000
   ABSLPDT := %1000+ABSOLUTE(%1010);                                    05410000
   @DCP := INITXDDP;                                                    05412000
   WHILE DCP <> 0 DO                                                    05414000
      BEGIN                                                             05416000
      TOS := DCP(1).(8:8);                                              05418000
      ASSEMBLE(ADDS 0);                                                 05420000
      MOVE ADVC := DCP,(DCP(1).(8:8));                                  05422000
      DX := 0;                                                          05426000
      VX := 0;                                                          05428000
      IF ADVC > 0 THEN                                                  05430000
         BEGIN                                                          05432000
         EXCHANGEDB(LDTDST);                                   <<02686>>05434000
         DVC := 1;                                                      05436000
         DO                                                             05438000
            BEGIN                                                       05440000
            V := TESTLD;                                                05442000
            IF V>VX OR (V=VX LAND DVC=ADVC) THEN                        05444000
               BEGIN VX := V; DX := DVC; END;                           05446000
            END                                                         05448000
         UNTIL (DVC := DVC+1) > INTEGER(BASE.(0:8));                    05450000
      END                                                               05452000
      ELSE                                                              05454000
         BEGIN                                                          05456000
         V := ADVC(7).(0:8);                                            05458000
         TOS := V+8-ADVC(1).(8:8);                                      05460000
         ASSEMBLE(ADDS 0);                                              05462000
         ADVC(1).(8:8) := V+8;                                          05464000
         DD := V;                                                       05466000
         WHILE DD > 0 DO                                                05468000
            BEGIN                                                       05470000
            DVC := IF LOGICAL(DD) THEN ADVC(7+(DD/2)).(8:8)             05472000
                                  ELSE ADVC(7+(DD/2)).(0:8);            05474000
            ADVC(7+DD) := GETTYPE;                             <<02686>>05476000
            DD := DD-1;                                                 05478000
            END;                                                        05480000
         ADVC(7) := V;                                                  05482000
         EXCHANGEDB(LDTDST);                                   <<02686>>05484000
         D := BASE(1);                                                  05486000
         C := 0;                                                        05488000
         WHILE (C:=C+1) <= INTEGER(BASE(2)) DO                          05490000
            BEGIN                                                       05492000
            V := TESTCL;                                                05494000
            IF V > VX THEN                                              05496000
               BEGIN VX := V; DX := C; END;                             05498000
            D := D+6+INTEGER(BASE(D+5).(0:8)&ASR(1));                   05500000
            END;                                                        05502000
         END;                                                           05504000
      EXCHANGEDB(0);                                                    05506000
      TOS := ADVC(1).(8:8);                                             05508000
      ASSEMBLE(SUBS 0);                                                 05510000
      DCP(1).(0:8) := IF VX=0 THEN 0 ELSE DX;                           05512000
      @DCP := @DCP+DCP(1).(8:8);                                        05514000
      END;                                                              05516000
   INDIRECTORY := TRUE;                                                 05518000
                                                               <<04329>>05520000
   << If USER.ACCOUNT was specified, and no files found,    >> <<04329>>05522000
   << then FILE'FOUND  signifies this.  Used in SHOWERRORS. >> <<04329>>05524000
                                                               <<04329>>05526000
   IF XDDC = 0 AND (USERF OR ACCTF)                            <<04329>>05528000
      THEN FILE'FOUND := FALSE;   << No files found U.A     >> <<04329>>05530000
                                                               <<04329>>05532000
   GOTO LX;                                                             05534000
LY:                                                                     05536000
   ERRN := 53;                                                          05538000
   GOTO LYZ;                                                            05540000
LZ:                                                                     05542000
   ERRN := 54;                                                          05544000
LYZ:                                                                    05546000
   FCLOSE(FILET,1,0);                                          <<02724>>05548000
   FILET := 0;                                                          05550000
LX:                                                                     05552000
   END;                                                                 05554000
$PAGE                                                          <<04145>>05556000
$CONTROL SEGMENT=SPOOK3                                                 05558000
                                                                        05560000
LOGICAL PROCEDURE OUTDIRECTORY;                                         05562000
   BEGIN                                                                05564000
   INTEGER C,IX,P;                                                      05566000
   INTEGER ABSLPDT,DVC,DC,D,DN;                                         05568000
   INTEGER POINTER XDDP;                                                05570000
   INTEGER POINTER DCP,DP;                                              05572000
   << >>                                                                05574000
   LOGICAL SUBROUTINE GOTLDCL;                                          05576000
      BEGIN                                                             05578000
      D := 0;                                                           05580000
      @DP := INITXDDP;                                                  05582000
      WHILE (D:=D+1) <= DC DO                                           05584000
        BEGIN                                                           05586000
        IF DP = DVC THEN GOTLDCL := TRUE;                               05588000
        @DP := @DP +DP(1).(8:8);                                        05590000
        END;                                                            05592000
      END;                                                              05594000
   << >>                                                                05596000
   SUBROUTINE PUTLD;                                                    05598000
      BEGIN                                                             05600000
      DCP := DVC;                                                       05602000
      TOS := ABSOLUTE(ABSLPDT+DVC*2+1).(12:4);                          05604000
      TOS := TOS&LSL(8)+3;                                              05606000
      DCP(1) := TOS;                                                    05608000
      EXCHANGEDB(LDTDST);                                               05610000
      TOS := BASE(DVC*5+2);                                             05612000
      EXCHANGEDB(0);                                                    05614000
      TOS.(8:2) := 0;                                                   05616000
      DCP(2) := TOS;                                                    05618000
      @DCP := @DCP+3;                                                   05620000
      DC := DC+1;                                                       05622000
      END;                                                              05624000
   << >>                                                                05626000
    SUBROUTINE PUTCL;                                                   05628000
      BEGIN                                                             05630000
      DCP := DVC;                                                       05632000
      EXCHANGEDB(LDTDST);                                               05634000
      D := BASE(1);                                                     05636000
      WHILE (DVC:=DVC+1) < 0 DO                                         05638000
         D := D+6+INTEGER(BASE(D+5).(0:8)&ASR(1));                      05640000
      DN := BASE(D+5).(0:8)&ASR(1)+5;                                   05642000
      IX := DN;                                                         05644000
      DO TOS := BASE(D+IX) UNTIL (IX:=IX-1) < 0;                        05646000
      EXCHANGEDB(0);                                                    05648000
      IX := 0;                                                          05650000
      DO DCP(IX+2) := TOS UNTIL (IX:=IX+1) > DN;                        05652000
      DCP(1) := DN+3;                                                   05654000
      TOS := @DCP+7;                                                    05656000
      @DCP := @DCP+DN+3;                                                05658000
      DC := DC+1;                                                       05660000
      DN := PS0.(0:8);                                                  05662000
      IX := 1;                                                          05664000
      DO                                                                05666000
         BEGIN                                                          05668000
         DVC := IF LOGICAL(IX) THEN PS0(IX/2).(8:8)                     05670000
                               ELSE PS0(IX/2).(0:8);                    05672000
         IF NOT GOTLDCL THEN PUTLD;                                     05674000
         END                                                            05676000
      UNTIL (IX:=IX+1) > DN;                                   <<02686>>05678000
      DEL;                                                              05680000
      END;                                                              05682000
   << >>                                                                05684000
   IX := 0;                                                             05686000
   C := 0;                                                              05688000
   @XDDP := INITXDDP;                                                   05690000
   WHILE (C:=C+1) <= XDDC DO                                            05692000
      BEGIN                                                             05694000
      @XDDP := @XDDP-30;                                                05696000
      IF IX = 0 THEN                                                    05698000
         BEGIN                                                          05700000
         SBUF := 0;                                                     05702000
         MOVE SBUF(1) := SBUF,(1023);                                   05704000
         END;                                                           05706000
      IF XDDP > 0 THEN                                                  05708000
         BEGIN                                                          05710000
         SBUF(IX) := XDDP(18);                                          05712000
         MOVE SBUF(IX+4) := XDDP(2),(8);                                05714000
         IX := IX+12;                                                   05716000
         END;                                                           05718000
      IF IX >= 1020 THEN                                                05720000
         BEGIN                                                          05722000
         FWRITE(FILET,SBUF,1020,0);                                     05724000
         IF <> THEN GOTO LY;                                            05726000
         IX := 0;                                                       05728000
         END;                                                           05730000
      END;                                                              05732000
   IF IX > 0 THEN                                                       05734000
      BEGIN                                                             05736000
      FWRITE(FILET,SBUF,1020,0);                                        05738000
      IF <> THEN GOTO LY;                                               05740000
      END;                                                              05742000
   ABSLPDT := %1000+ABSOLUTE(%1010);                                    05744000
   C := 0;                                                              05746000
   DC := 0;                                                             05748000
   @XDDP := INITXDDP;                                                   05750000
   @DCP := INITXDDP;                                                    05752000
   WHILE (C:=C+1) <= XDDC DO                                            05754000
      BEGIN                                                             05756000
      @XDDP := @XDDP-30;                                                05758000
      IF XDDP > 0 THEN                                                  05760000
         BEGIN                                                          05762000
         DVC := XDDP.(8:8);                                             05764000
         IF XDDP.(7:1)=1 THEN DVC := -DVC;                              05766000
         IF NOT GOTLDCL THEN                                            05768000
            IF DVC > 0 THEN PUTLD                                       05770000
                       ELSE PUTCL;                                      05772000
         END;                                                           05774000
      END;                                                              05776000
   DCP := 0;                                                            05778000
   DN := @DCP-INITXDDP+1;                                               05780000
   @DCP := INITXDDP;                                                    05782000
   FWRITE(FILET,DCP,1024,0);                                            05784000
   IF <> THEN GOTO LY;                                                  05786000
   IF DN > 1024 THEN                                                    05788000
      BEGIN                                                             05790000
      FWRITE(FILET,DCP(1024),1024,0);                                   05792000
      IF <> THEN GOTO LY;                                               05794000
      END;                                                              05796000
   FCONTROL(FILET,6,P);                                                 05798000
   IF <> THEN GOTO LY;                                                  05800000
   OUTDIRECTORY := TRUE;                                                05802000
   GOTO LX;                                                             05804000
LY:                                                                     05806000
   ERRN := 55;                                                          05808000
   FCLOSE(FILET,1,0);                                          <<02724>>05810000
   FILET := 0;                                                          05812000
LX:                                                                     05814000
   END;                                                                 05816000
$PAGE                                                          <<04145>>05818000
$CONTROL SEGMENT=SPOOK3                                       <<<01549>>05820000
                                                              <<<01549>>05822000
LOGICAL PROCEDURE VERIFY'BLOCK'STRUCTURE(BUFFER,INDEX,NUMRECS);<<01726>>05824000
                                                              <<SP.MP4>>05826000
   LOGICAL ARRAY BUFFER;                                      <<SP.MP4>>05828000
   INTEGER INDEX,NUMRECS;                                     <<SP.MP4>>05830000
                                                              <<SP.MP4>>05832000
   BEGIN                                                      <<<01549>>05834000
                                                              <<<01549>>05836000
      INTEGER SCOUNT := 0;                                    <<<01549>>05838000
      INTEGER REC'LEN, I;                                     <<<01549>>05840000
      EQUATE END'OF'DATA = 509;                               <<<01549>>05842000
                                                              <<<01549>>05844000
      VERIFY'BLOCK'STRUCTURE := TRUE;                         <<<01549>>05846000
      NUMRECS := 0; <<NUMBER OF RECORDS IN BLOCK>>             <<01726>>05848000
      DO                                                      <<<01549>>05850000
      BEGIN                                                   <<<01549>>05852000
         REC'LEN := BUFFER(SCOUNT);                           <<<01549>>05854000
         INDEX := SCOUNT;                                     <<<01549>>05856000
         SCOUNT := SCOUNT + (REC'LEN + 3)&ASR(1);             <<<01549>>05858000
         NUMRECS := NUMRECS + 1;                               <<01726>>05860000
      END                                                     <<<01549>>05862000
      UNTIL (SCOUNT > END'OF'DATA) OR                         <<<01549>>05864000
         (INTEGER(BUFFER(SCOUNT)) = -1);                      <<<01549>>05866000
      IF SCOUNT > END'OF'DATA THEN                            <<<01549>>05868000
         VERIFY'BLOCK'STRUCTURE := FALSE;                     <<<01549>>05870000
   END; <<VERIFY'BLOCK'STRUCTURE>>                            <<<01549>>05872000
$PAGE                                                          <<04145>>05874000
                                                              <<<01549>>05876000
$CONTROL SEGMENT=SPOOK3                                       <<<01549>>05878000
                                                              <<<01549>>05880000
LOGICAL PROCEDURE REWRITE'BLOCK(FILENUM,BUFFER,INDEX);        <<<01549>>05882000
                                                              <<<01549>>05884000
   VALUE FILENUM;                                             <<<01549>>05886000
   LOGICAL ARRAY BUFFER;                                      <<<01549>>05888000
   INTEGER INDEX,FILENUM;                                     <<<01549>>05890000
                                                              <<<01549>>05892000
   BEGIN                                                      <<<01549>>05894000
                                                              <<<01549>>05896000
      LOGICAL I,J,K;                                          <<<01549>>05898000
                                                              <<<01549>>05900000
      REWRITE'BLOCK := TRUE;                                  <<<01549>>05902000
      I := BUFFER(INDEX);                                     <<<01549>>05904000
      BUFFER(INDEX) := -1;  <<END OF BLOCK>>                  <<<01549>>05906000
      J := BUFFER(510); <<STORE LAST 2 WORDS BEFORE>>         <<<01549>>05908000
      K := BUFFER(511); <<FILE SYS OVERLAYS WITH >>           <<<01549>>05910000
                        <<RECORD COUNT>>                      <<<01549>>05912000
                                                              <<<01549>>05914000
      FWRITE(FILENUM,BUFFER,512,0); <<WRITE BUFFER UP TO>>    <<<01549>>05916000
       IF <> THEN REWRITE'BLOCK := FALSE;                     <<<01549>>05918000
                                    <<LAST RECORD THAT FITS>> <<<01549>>05920000
      BUFFER(INDEX) := I;                                     <<<01549>>05922000
      BUFFER(510) := J;                                       <<<01549>>05924000
      BUFFER(511) := K;                                       <<<01549>>05926000
                                                              <<<01549>>05928000
      MOVE BUFFER := BUFFER(INDEX), (512-INDEX);              <<<01549>>05930000
   END;  <<REWRITE'BLOCK>>                                    <<<01549>>05932000
$PAGE                                                          <<04145>>05934000
$CONTROL SEGMENT=SPOOK3                                                 05936000
                                                                        05938000
LOGICAL PROCEDURE INFILES;                                              05940000
   BEGIN                                                                05942000
   INTEGER C,P,D,N,M,DF,I;                                              05944000
   INTEGER DVC,NER,FER,CNTX;                                            05946000
   LOGICAL E,F,G,L,GOT,GOTX;                                            05948000
   INTEGER POINTER XDDP;                                                05950000
   INTEGER POINTER XDDSUBP;                                             05952000
   DOUBLE POINTER XDDPD=XDDP;                                           05954000
   INTEGER POINTER DCP;                                                 05956000
   INTEGER INDEX,FILENUM;                                     <<<01549>>05958000
   INTEGER NUMRECS;                                            <<01726>>05960000
   INTEGER NUMSPULABS,J;                                       <<01886>>05962000
   LOGICAL PAST'ULABS;                                         <<01886>>05964000
   << >>                                                                05966000
   SUBROUTINE NEXTREEL;                                                 05968000
      BEGIN                                                             05970000
      REEL := REEL+1;                                                   05972000
      TBUF(23) := REEL;                                                 05974000
      I := PRINTOPREPLY(MREEL,17,0,RBUF,-1);                            05976000
      IF BRBUF = "N" THEN GOTO LA;                                      05978000
   RL:                                                                  05980000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 05982000
      IF < THEN GOTO LY;                                                05984000
      IF > OR TCOUNT<>40 OR BTBUF<>BSBUF,(80) THEN                      05986000
         BEGIN                                                          05988000
         FCONTROL(FILET,9,P);                                           05990000
         IF <> THEN GOTO LY;                                            05992000
         I := PRINTOPREPLY(EREEL,18,0,RBUF,-1);                         05994000
         IF BRBUF = "N" THEN GOTO LA;                                   05996000
         GOTO RL;                                                       05998000
         END;                                                           06000000
      FREAD(FILET,SBUF,1024);                                           06002000
      IF <= THEN GOTO LZ;                                               06004000
      END;                                                              06006000
   << >>                                                                06008000
   SUBROUTINE READTAPE(RF);                                             06010000
      VALUE   RF;                                                       06012000
      LOGICAL RF;                                                       06014000
      BEGIN                                                             06016000
      IF LASTREEL THEN GOTO LZ;                                         06018000
   RLY:                                                                 06020000
      IF RF THEN                                                        06022000
         BEGIN                                                          06024000
         IF GOTX THEN                                                   06026000
            BEGIN                                                       06028000
            GOTX := FALSE;                                              06030000
            TCOUNT := CNTX;                                             06032000
            GOTO RLX;                                                   06034000
            END;                                                        06036000
         TCOUNT := FREAD(FILET,SBUF,1024);                              06038000
         IF < THEN GOTO LY;                                             06040000
         IF = THEN GOTO RLX;                                            06042000
         END                                                            06044000
      ELSE                                                              06046000
         BEGIN                                                          06048000
         GOTX := FALSE;                                                 06050000
         FCONTROL(FILET,7,P);                                           06052000
         IF <> THEN GOTO LY;                                            06054000
         END;                                                           06056000
      TCOUNT := FREAD(FILET,SBUF,1024);                                 06058000
      IF <> THEN GOTO LY;                                               06060000
      IF TCOUNT <> 40 THEN                                              06062000
         BEGIN                                                          06064000
         FILEEND := TRUE;                                               06066000
         GOTX := TRUE;                                                  06068000
         CNTX := TCOUNT;                                                06070000
         END                                                            06072000
      ELSE                                                              06074000
         BEGIN                                                          06076000
         FILEEND := (SBUF(21) = 1);                                     06078000
         LASTREEL := (SBUF(22) = 1);                                    06080000
         FCONTROL(FILET,9,P);                                           06082000
         IF <> THEN GOTO LY;                                            06084000
         IF NOT LASTREEL THEN                                           06086000
            BEGIN                                                       06088000
            NEXTREEL;                                                   06090000
            IF NOT FILEEND THEN GOTO RLY;                               06092000
            END;                                                        06094000
         END;                                                           06096000
      TCOUNT := 0;                                                      06098000
   RLX:                                                                 06100000
      END;                                                              06102000
   << >>                                                                06104000
   SUBROUTINE ERRORSET;                                                 06106000
      BEGIN                                                             06108000
      E := TRUE;                                                        06110000
      XDDP(25).(0:8) := NER;                                            06112000
      XDDP(25).(8:8) := FER;                                            06114000
      READTAPE(FALSE);                                                  06116000
      F := TRUE;                                                        06118000
      G := TRUE;                                                        06120000
      END;                                                              06122000
   << >>                                                                06124000
   SUBROUTINE ERRORFILE(A);                                             06126000
      VALUE   A;                                                        06128000
      INTEGER A;                                                        06130000
      BEGIN                                                             06132000
      NER := A;                                                         06134000
      FCHECK(FILEF,FER);                                                06136000
            ERRF := FER;                                       <<01326>>06138000
      ERRORSET;                                                         06140000
      END;                                                              06142000
   << >>                                                                06144000
   SUBROUTINE ERRORIN;                                                  06146000
      BEGIN                                                             06148000
      NER := SBUF;                                                      06150000
      FER := SBUF(1);                                                   06152000
      ERRORSET;                                                         06154000
      END;                                                              06156000
   << >>                                                                06158000
   SUBROUTINE TRANSFORM;                                                06160000
      BEGIN                                                             06162000
      DF := XDDP(18);                                                   06164000
      TOS := XDDP(1);                                                   06166000
      IF < THEN TOS.(0:2) := 3                                          06168000
           ELSE TOS.(0:2) := 0;                                         06170000
      XDDP(1) := TOS;                                                   06172000
      XDDPD(10) := 0D;                                                  06174000
      XDDPD(11) := 0D;                                                  06176000
      XDDPD(13) := 0D;                                                  06178000
      DVC := XDDP.(8:8);                                                06180000
      IF XDDP.(7:1)=1 THEN DVC := -DVC;                                 06182000
      @DCP := INITXDDP;                                                 06184000
      WHILE DCP <> 0 AND DCP <> DVC DO                                  06186000
         @DCP := @DCP+DCP(1).(8:8);                                     06188000
      DVC := DCP(1).(0:8);                                              06190000
      IF DCP = 0 OR DVC = 0 THEN                                        06192000
         BEGIN                                                          06194000
         NER := IF DCP >= 0 THEN 57 ELSE 58;                            06196000
         ERRORSET;                                                      06198000
         END                                                            06200000
      ELSE                                                              06202000
         BEGIN                                                          06204000
         XDDP.(2:1) := 0;                                               06206000
         XDDP.(8:8) := DVC;                                             06208000
         XDDP.(7:1) := IF DCP < 0 THEN 1 ELSE 0;                        06210000
         END;                                                           06212000
      END;                                                              06214000
   << >>                                                                06216000
   SUBROUTINE OPENSP;                                                   06218000
      BEGIN                                                             06220000
      DVC := DCP(1).(0:8);                                              06222000
      IF DCP < 0 THEN DVC := -DVC;                                      06224000
      IF SPUTXDD(1,DVC,XDDP,XDDSUBP) <> 0 THEN                          06226000
         BEGIN                                                          06228000
         NER := 59;                                                     06230000
         ERRORSET;                                                      06232000
         END                                                            06234000
      ELSE                                                              06236000
         BEGIN                                                          06238000
         FILEF := FSOPEN(,%304,%501,@XDDSUBP);                          06240000
         IF < THEN                                                      06242000
            BEGIN                                                       06244000
            ERRORFILE(29);                                              06246000
            SREMOVEXDD(XDDSUBP);                                        06248000
            FILEF := 0;                                                 06250000
            END                                                         06252000
         ELSE                                                           06254000
            BEGIN                                                       06256000
            TOS := @XDDP;                                               06258000
            TOS := ODDDST;                                              06260000
            TOS := @XDDSUBP.(1:15);                                     06262000
            TOS := 30;                                                  06264000
            ASSEMBLE(MFDS 4);                                           06266000
            XDDP(25) := 0;                                              06268000
            END;                                                        06270000
         END;                                                           06272000
      END;                                                              06274000
   << >>                                                                06276000
                                                               <<01886>>06278000
   SUBROUTINE READUSERLABELS;                                  <<01886>>06280000
      BEGIN                                                    <<01886>>06282000
         PAST'ULABS := FALSE;                                  <<01886>>06284000
         READTAPE(TRUE);                                       <<01886>>06286000
         IF SBUF(2) = 3 <<FOPEN>> AND SBUF(4) <> 0 <<NUMULABS>><<01930>>06288000
            AND SBUF((SBUF+3)&ASR(1)) = -1 <<END OF BLOCK>>    <<01930>>06290000
            THEN                                               <<01930>>06292000
         BEGIN <<THERE ARE USERLABELS>>                        <<01886>>06294000
            NUMSPULABS := SBUF(4);                             <<01930>>06296000
           J := 1;                                             <<01930>>06298000
            DO                                                 <<01886>>06300000
            BEGIN                                              <<01886>>06302000
               TCOUNT := FREAD(FILET,SBUF,1024);               <<01930>>06304000
               IF < THEN GO TO LY;                             <<01886>>06306000
               FWRITELABEL(FILEF,SBUF(128),,J-1);              <<01930>>06308000
               IF J < NUMSPULABS - 1 THEN                      <<01930>>06310000
               FWRITELABEL(FILEF,SBUF(128*2),,J);              <<01930>>06312000
               IF J+1 < NUMSPULABS - 1 THEN                    <<01930>>06314000
               FWRITELABEL(FILEF,SBUF(128*3),,J+1);            <<01930>>06316000
               IF J+2 < NUMSPULABS - 1 THEN                    <<01930>>06318000
               FWRITELABEL(FILEF,SBUF(512+128),,J+2);          <<01930>>06320000
               IF J+3 < NUMSPULABS - 1 THEN                    <<01930>>06322000
               FWRITELABEL(FILEF,SBUF(512+(128*2)),,J+3);      <<01930>>06324000
               IF J+4 < NUMSPULABS - 1 THEN                    <<01930>>06326000
               FWRITELABEL(FILEF,SBUF(512+(128*3)),,J+4);      <<01930>>06328000
            END                                                <<01930>>06330000
            UNTIL (J := J + 6) > NUMSPULABS;                   <<01930>>06332000
         END                                                   <<01886>>06334000
         ELSE                                                  <<01886>>06336000
             PAST'ULABS := TRUE;                               <<01886>>06338000
       END; <<SUBROUTINE READUSERLABELS>>                      <<01886>>06340000
<<>>                                                           <<01886>>06342000
                                                               <<01886>>06344000
   C := 0;                                                              06346000
   GOTX := FALSE;                                                       06348000
   GOT := FALSE;                                                        06350000
   FILEF := 0;                                                          06352000
   @XDDP := INITXDDP;                                                   06354000
   PRINT(MIN,23,0);                                                     06356000
   WHILE (C:=C+1) <= XDDC DO                                            06358000
      BEGIN                                                             06360000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>06362000
      CRITFLAG := TRUE;                                        <<B0.00>>06364000
      @XDDP := @XDDP-30;                                                06366000
      F := FALSE;                                                       06368000
      E := FALSE;                                                       06370000
      NER := 0;                                                         06372000
      FER := 0;                                                         06374000
      FILEEND := FALSE;                                                 06376000
      IF DEVFC <> 0 THEN                                                06378000
         BEGIN                                                          06380000
         L := FALSE;                                                    06382000
         IF NOT GOT THEN                                                06384000
            BEGIN                                                       06386000
            D := -1;                                                    06388000
            GOT := TRUE;                                                06390000
            WHILE (D:=D+1) < DEVFC DO                                   06392000
               IF DEVFS(D) <> 0 THEN                                    06394000
                  BEGIN                                                 06396000
                  GOT := FALSE;                                         06398000
                  IF XDDP = INTEGER(DEVFS(D)) THEN                      06400000
                     BEGIN                                              06402000
                     L := TRUE;                                         06404000
                     DEVFS(D) := 0;                                     06406000
                     END;                                               06408000
                  END;                                                  06410000
            END;                                                        06412000
         END                                                            06414000
      ELSE                                                              06416000
         BEGIN                                                          06418000
         L := TRUE;                                                     06420000
         N := IF USERF THEN -1 ELSE 3;                                  06422000
         M := IF ACCTF THEN 8 ELSE 4;                                   06424000
         WHILE (N:=N+1) < M DO                                          06426000
            IF XDDP(4+N) <> INTEGER(SNAMES(N)) THEN L := FALSE;         06428000
         END;                                                           06430000
      IF NOT L THEN                                                     06432000
         BEGIN                                                          06434000
         XDDP := 0;                                                     06436000
         IF NOT GOT THEN READTAPE(FALSE);                               06438000
         END                                                            06440000
      ELSE                                                              06442000
         BEGIN                                                          06444000
         G := FALSE;                                                    06446000
         READTAPE(TRUE);                                                06448000
         IF TCOUNT = 0 THEN GOTO LZ;                                    06450000
         IF TCOUNT = 20 THEN ERRORIN;                                   06452000
         IF TCOUNT = 30 THEN                                            06454000
            BEGIN                                                       06456000
            MOVE XDDP := SBUF,(30);                                     06458000
            TRANSFORM;                                                  06460000
            OPENSP;                                                     06462000
            G := TRUE;                                                  06464000
               READUSERLABELS;                                 <<01886>>06466000
            END;                                                        06468000
         IF NOT G THEN GOTO LZ;                                         06470000
         WHILE NOT F DO                                                 06472000
            BEGIN                                              <<01886>>06474000
            IF NOT PAST'ULABS THEN                             <<01886>>06476000
            READTAPE(TRUE);                                             06478000
            PAST'ULABS := FALSE;                               <<01886>>06480000
            IF TCOUNT = 0 THEN                                          06482000
               F := TRUE                                                06484000
            ELSE                                                        06486000
                    BEGIN                                               06488000
                    G := FALSE;                                         06490000
                    IF TCOUNT = 20 THEN ERRORIN;                        06492000
                    IF TCOUNT = 512 OR TCOUNT = 1024 THEN               06494000
                       BEGIN                                            06496000
                       G := TRUE;                                       06498000
                       IF NOT VERIFY'BLOCK'STRUCTURE(SBUF,    <<<01549>>06500000
                            INDEX,NUMRECS) THEN                <<01726>>06502000
                         IF NOT REWRITE'BLOCK(FILEF,SBUF,     <<<01549>>06504000
                            INDEX) THEN                       <<<01549>>06506000
                            ERRORFILE(27);                    <<<01549>>06508000
                       FWRITE(FILEF,SBUF,512,0);              <<<01549>>06510000
                       IF <> THEN                                       06512000
                          ERRORFILE(27)                                 06514000
                       ELSE                                             06516000
                          IF TCOUNT = 1024 THEN                         06518000
                             BEGIN                                      06520000
                    IF NOT VERIFY'BLOCK'STRUCTURE(SBUF(512),  <<<01549>>06522000
                            INDEX,NUMRECS) THEN                <<01726>>06524000
                         IF NOT REWRITE'BLOCK(FILEF,SBUF(512),<<<01549>>06526000
                            INDEX) THEN                       <<<01549>>06528000
                            ERRORFILE(27);                    <<<01549>>06530000
                             FWRITE(FILEF,SBUF(512),512,0);   <<<01549>>06532000
                             IF <> THEN ERRORFILE(27);                  06534000
                             END;                                       06536000
                       END;                                             06538000
                    IF NOT G THEN GOTO LZ;                              06540000
                    END;                                                06542000
            END;                                                        06544000
         IF FILEF <> 0 THEN                                             06546000
            BEGIN                                                       06548000
            FSCLOSE(FILEF,IF E THEN 4 ELSE 0,0);                        06550000
            IF < THEN ERRORFILE(25);                                    06552000
            FILEF := 0;                                                 06554000
            END;                                                        06556000
         IF NOT E THEN                                                  06558000
            BEGIN                                                       06560000
            MOVE XDD := XDDP,(30);                                      06562000
            SHOWXDD(%10,DF);                                            06564000
            END;                                                        06566000
         END;                                                           06568000
      END;                                                              06570000
   INFILES := TRUE;                                                     06572000
   GOTO LX;                                                             06574000
LA:                                                                     06576000
   ERRN := 60;                                                          06578000
   GOTO LYZ;                                                            06580000
LZ:                                                                     06582000
   ERRN := 53;                                                          06584000
   GOTO LYZ;                                                            06586000
LY:                                                                     06588000
   ERRN := 54;                                                          06590000
LYZ:                                                                    06592000
   IF FILEF <> 0 THEN FSCLOSE(FILEF,4,0);                               06594000
   FCLOSE(FILET,1,0);                                          <<02724>>06596000
   FILET := 0;                                                          06598000
LX:                                                                     06600000
   END;                                                                 06602000
                                                                        06604000
$CONTROL SEGMENT=SPOOK3                                                 06606000
                                                                        06608000
LOGICAL PROCEDURE OUTFILES;                                             06610000
   BEGIN                                                                06612000
   INTEGER C,P,I;                                                       06614000
   INTEGER NER,FER;                                                     06616000
   INTEGER NUMSPULABS,J;                                       <<01886>>06618000
   LOGICAL F;                                                           06620000
   INTEGER POINTER XDDP;                                                06622000
   << >>                                                                06624000
   LOGICAL SUBROUTINE WRITETAPE(ADDR,COUNT);                            06626000
      VALUE   COUNT;                                                    06628000
      INTEGER COUNT;                                                    06630000
      ARRAY   ADDR;                                                     06632000
      BEGIN                                                             06634000
      WRITETAPE := TRUE;                                                06636000
      IF COUNT <> 0 THEN FWRITE(FILET,ADDR,COUNT,0)                     06638000
                    ELSE FCONTROL(FILET,6,P);                           06640000
      IF <> THEN                                                        06642000
         BEGIN                                                          06644000
         FCHECK(FILET,P);                                               06646000
         IF P = 23 THEN EOTMARK := TRUE                                 06648000
                   ELSE WRITETAPE := FALSE;                             06650000
         END;                                                           06652000
      END;                                                              06654000
   << >>                                                                06656000
   SUBROUTINE NEXTREEL;                                                 06658000
      BEGIN                                                             06660000
      IF EOTMARK OR LASTREEL THEN                                       06662000
         BEGIN                                                          06664000
         IF NOT FILEEND THEN                                            06666000
            IF NOT WRITETAPE(SBUF,0) THEN GOTO LZ;                      06668000
         TBUF(21) := IF FILEEND THEN 1 ELSE 0;                          06670000
         TBUF(22) := IF LASTREEL THEN 1 ELSE 0;                         06672000
         IF NOT WRITETAPE(TBUF,40) THEN GOTO LZ;                        06674000
         I := -1;                                                       06676000
         WHILE (I:=I+1) <= 3 DO                                         06678000
            IF NOT WRITETAPE(SBUF,0) THEN GOTO LZ;                      06680000
         IF NOT LASTREEL THEN                                           06682000
            BEGIN                                                       06684000
            FCONTROL(FILET,9,P);                                        06686000
            IF <> THEN GOTO LZ;                                         06688000
            REEL := REEL+1;                                             06690000
            I := PRINTOPREPLY(MREEL,17,0,RBUF,-1);                      06692000
            IF BRBUF = "N" THEN GOTO LA;                                06694000
            EOTMARK := FALSE;                                           06696000
            TBUF(21) := 0;                                              06698000
            TBUF(22) := 0;                                              06700000
            TBUF(23) := REEL;                                           06702000
            IF NOT WRITETAPE(TBUF,40) THEN GOTO LZ;                     06704000
            IF NOT WRITETAPE(SBUF,0) THEN GOTO LZ;                      06706000
            END;                                                        06708000
         END;                                                           06710000
      END;                                                              06712000
   << >>                                                                06714000
   SUBROUTINE ERROROUT;                                                 06716000
      BEGIN                                                             06718000
      XDDP(25).(0:8) := NER;                                            06720000
      XDDP(25).(8:8) := FER;                                            06722000
      SBUF := NER;                                                      06724000
      SBUF(1) := FER;                                                   06726000
      NER := 0;                                                         06728000
      FER := 0;                                                         06730000
      IF NOT WRITETAPE(SBUF,20) THEN GOTO LZ;                           06732000
      END;                                                              06734000
   << >>                                                                06736000
   SUBROUTINE ERRORFILE;                                                06738000
      BEGIN                                                             06740000
      NER := 26;                                                        06742000
      FCHECK(FILEF,FER);                                                06744000
            ERRF := FER;                                       <<01326>>06746000
      ERROROUT;                                                         06748000
      END;                                                              06750000
   << >>                                                                06752000
                                                               <<01886>>06754000
   SUBROUTINE WRITEUSERLABELS;                                 <<01886>>06756000
      BEGIN                                                    <<01886>>06758000
         FFILEINFO(FILEF, 17, NUMSPULABS);                     <<01886>>06760000
         IF NUMSPULABS > 0 THEN                                <<01886>>06762000
         BEGIN                                                 <<01886>>06764000
            SBUF := 8;  <<LENGTH>>                             <<01930>>06766000
            SBUF(1) := 0;                                      <<01930>>06768000
            SBUF(2) := 3; <<FOPEN>>                            <<01930>>06770000
            SBUF(3) := 0; <<P1>>                               <<01930>>06772000
            SBUF(4) := NUMSPULABS; <<P2>>                      <<01930>>06774000
            SBUF(5) := -1; <<END OF BLOCK>>                    <<01930>>06776000
            MOVE SBUF(512) := SBUF, (6);                       <<01930>>06778000
            IF NOT WRITETAPE(SBUF,1024) THEN GO TO LZ;         <<01930>>06780000
            J := 1 ;                                           <<01930>>06782000
            DO                                                 <<01886>>06784000
            BEGIN                                              <<01886>>06786000
               FREADLABEL(FILEF,SBUF(128),, J-1);              <<01930>>06788000
               FREADLABEL(FILEF, SBUF(128*2),,J);              <<01930>>06790000
               FREADLABEL(FILEF, SBUF(128*3),,J+1);            <<01930>>06792000
               FREADLABEL(FILEF,SBUF(512+128),, J+2);          <<01930>>06794000
               FREADLABEL(FILEF, SBUF(512+(128*2)),,J+3);      <<01930>>06796000
               FREADLABEL(FILEF, SBUF(512+(128*3)),,J+4);      <<01930>>06798000
               IF NOT WRITETAPE(SBUF,1024) THEN GO TO LZ;      <<01930>>06800000
            END                                                <<01930>>06802000
            UNTIL (J := J+6) > NUMSPULABS;                     <<01930>>06804000
         END;                                                  <<01886>>06806000
      END; <<SUBROUTINE WRITEUSERLABELS>>                      <<01886>>06808000
<<>>                                                           <<01886>>06810000
                                                               <<01886>>06812000
   FILEF := 0;                                                          06814000
   C := 0;                                                              06816000
   @XDDP := INITXDDP;                                                   06818000
   PRINT(MOUT,22,0);                                                    06820000
   WHILE (C:=C+1) <= XDDC DO                                            06822000
      BEGIN                                                             06824000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>06826000
      CRITFLAG := TRUE;                                        <<B0.00>>06828000
      @XDDP := @XDDP-30;                                                06830000
      IF XDDP > 0 THEN                                                  06832000
         BEGIN                                                          06834000
         DEVF := XDDP(18);                                              06836000
         F := TRUE;                                                     06838000
         FILEEND := FALSE;                                              06840000
      TOS := SPOOLOPEN(DEVF,FILEF);                            <<B0.01>>06842000
         XDD.(1:2) := 3;                                                06844000
         XDD.(3:4) := 1;                                                06846000
         XDD(25) := 0;                                                  06848000
         MOVE XDDP := XDD,(30);                                         06850000
         IF NOT TOS THEN                                                06852000
            BEGIN                                                       06854000
            NER := ERRN;                                                06856000
            FER := ERRF;                                                06858000
            ERRN := 0;                                                  06860000
            ERRF := NO'FILE'ERROR;                             <<04145>>06862000
            ERROROUT                                                    06864000
            END                                                         06866000
         ELSE                                                           06868000
            BEGIN                                                       06870000
            IF NOT WRITETAPE(XDD,30) THEN GOTO LZ;                      06872000
            WRITEUSERLABELS;                                   <<01886>>06874000
            DO                                                          06876000
               BEGIN                                                    06878000
               F := TRUE;                                               06880000
               FREAD(FILEF,SBUF,512);                                   06882000
               IF < THEN                                                06884000
                  ERRORFILE                                             06886000
               ELSE                                                     06888000
                  IF = THEN                                             06890000
                     BEGIN                                              06892000
                     NEXTREEL;                                          06894000
                     FREAD(FILEF,SBUF(512),512);                        06896000
                     IF < THEN                                          06898000
                        ERRORFILE                                       06900000
                     ELSE                                               06902000
                        IF > THEN                                       06904000
                           BEGIN                                        06906000
                           IF NOT WRITETAPE(SBUF,512) THEN              06908000
                              GOTO LZ;                                  06910000
                           END                                          06912000
                        ELSE                                            06914000
                           BEGIN                                        06916000
                           IF NOT WRITETAPE(SBUF,1024) THEN             06918000
                              GOTO LZ;                                  06920000
                           F := FALSE;                                  06922000
                           END;                                         06924000
                     END;                                               06926000
               END                                                      06928000
            UNTIL F;                                                    06930000
            END;                                                        06932000
         IF NOT WRITETAPE(SBUF,0) THEN GOTO LZ;                         06934000
         FILEEND := TRUE;                                               06936000
         NEXTREEL;                                                      06938000
         IF FILEF <> 0 THEN                                             06940000
            BEGIN                                                       06942000
            PRI := 1;                                                   06944000
            COPIES := 0;                                                06946000
            CLDEV := 0;                                                 06948000
            ALTERXDD(DEVF);                                    <<B0.01>>06950000
            FSCLOSE(FILEF,IF PURGEFLAG THEN 4 ELSE 0,0);      <<00204>> 06952000
            FILEF := 0;                                                 06954000
            END;                                                        06956000
         MOVE XDD := XDDP,(30);                                         06958000
         IF XDD(25) = 0 THEN SHOWXDD(%4,0);                             06960000
         END;                                                           06962000
      END;                                                              06964000
   LASTREEL := TRUE;                                                    06966000
   NEXTREEL;                                                            06968000
   OUTFILES := TRUE;                                                    06970000
   GOTO LX;                                                             06972000
LA:                                                                     06974000
   ERRN := 60;                                                          06976000
   GOTO LY;                                                             06978000
LZ:                                                                     06980000
   ERRN := 55;                                                          06982000
LY:                                                                     06984000
   IF FILEF <> 0 THEN FSCLOSE(FILEF,0,0);                               06986000
   FCLOSE(FILET,1,0);                                          <<02724>>06988000
   FILET := 0;                                                          06990000
   PURGEFLAG := FALSE;                                        <<00204>> 06992000
LX:                                                                     06994000
   END;                                                                 06996000
                                                                        06998000
$CONTROL SEGMENT=SPOOK2                                                 07000000
                                                                        07002000
PROCEDURE PURGEFILES;                                                   07004000
   BEGIN                                                                07006000
   INTEGER C;                                                           07008000
   INTEGER POINTER XDDP;                                                07010000
   << >>                                                                07012000
   SUBROUTINE ERRORPURG;                                                07014000
      BEGIN                                                             07016000
      XDDP(25).(0:8) := ERRN;                                           07018000
      XDDP(25).(8:8) := ERRF;                                           07020000
      ERRN := 0;                                                        07022000
      ERRF := NO'FILE'ERROR;                                   <<04145>>07024000
      FILEF := 0;                                                       07026000
      END;                                                              07028000
   << >>                                                                07030000
   C := 0;                                                              07032000
   @XDDP := INITXDDP;                                                   07034000
   PRINT(MOUT,22,0);                                                    07036000
   WHILE (C:=C+1) <= XDDC DO                                            07038000
      BEGIN                                                             07040000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>07042000
      CRITFLAG := TRUE;                                        <<B0.00>>07044000
      @XDDP := @XDDP-30;                                                07046000
      IF XDDP > 0 THEN                                                  07048000
         BEGIN                                                          07050000
         DEVF := XDDP(18);                                              07052000
         IF FILEN <> 0 AND DEVF = DEVFN THEN                            07054000
            BEGIN                                                       07056000
            FILEF := FILEN;                                             07058000
            FILEN := 0;                                                 07060000
            END                                                         07062000
         ELSE                                                           07064000
         IF NOT SPOOLOPEN(DEVF,FILEF) THEN ERRORPURG;          <<B0.01>>07066000
         IF FILEF <> 0 THEN                                             07068000
            BEGIN                                                       07070000
            FSCLOSE(FILEF,4,0);                                         07072000
            IF < THEN                                                   07074000
               BEGIN                                                    07076000
               ERRN := 25;                                              07078000
               FCHECK(FILEF,ERRF);                                      07080000
               ERRORPURG;                                               07082000
               END                                                      07084000
            ELSE                                                        07086000
               BEGIN                                                    07088000
               MOVE XDD := XDDP,(30);                                   07090000
               SHOWXDD(%4,0);                                           07092000
               END;                                                     07094000
            END;                                                        07096000
         END;                                                           07098000
      END;                                                              07100000
   END;                                                                 07102000
                                                                        07104000
$PAGE "SPOOK CONTROLY ROUTINES"                                <<B0.00>>07106000
$CONTROL SEGMENT=SPOOK1                                                 07108000
                                                                        07110000
PROCEDURE CONTROLY;                                                     07112000
   BEGIN                                                                07114000
   << >>                                                                07116000
      TOS:=EXCHANGEDB(0);                                      <<B0.00>>07118000
      IF CRITFLAG THEN                                         <<B0.00>>07120000
        BEGIN                                                  <<B0.00>>07122000
        CONTROLYFLAG := TRUE;                                  <<B0.00>>07124000
        ASSEMBLE(ZERO,XCH);                                    <<B0.01>>07126000
        EXCHANGEDB(*);                                         <<B0.00>>07128000
        TOS := TOS.(8:8) + EXITINSTR;                          <<B0.01>>07130000
        ASSEMBLE(XEQ 0);                                       <<B0.01>>07132000
        END                                                    <<B0.00>>07134000
      ELSE                                                     <<B0.00>>07136000
         DDEL;                                                 <<B0.01>>07138000
        CONTROLYPROC;                                          <<B0.00>>07140000
        END;                                                   <<B0.00>>07142000
                                                               <<B0.00>>07144000
                                                               <<B0.00>>07146000
$CONTROL SEGMENT=SPOOK1                                        <<B0.00>>07148000
                                                               <<B0.00>>07150000
PROCEDURE CONTROLYPROC;                                        <<B0.00>>07152000
                                                               <<B0.00>>07154000
   BEGIN                                                       <<B0.00>>07156000
<<>>                                                           <<B0.00>>07158000
                                                               <<B0.00>>07160000
   EXCHANGEDB(0) ;                                             <<B0.01>>07162000
   DELTAP.(2:14) := CYADDR;                                             07164000
   QMSTAT := STATVAL;                                                   07166000
   PUSH(Q);                                                             07168000
   DELTAQ := TOS-QVAL;                                                  07170000
   IF DELTAQ < 4 THEN DEBUG;                                   <<B0.01>>07172000
   CONTROLYFLAG := FALSE;                                      <<B0.00>>07174000
   RESETCONTROL;                                                        07176000
   END;                                                                 07178000
$PAGE "SPOOK SUBTASKING INTERFACE ROUTINE"                     <<B0.00>>07180000
$CONTROL SEGMENT=SPOOK1                                        <<B0.00>>07182000
<<  PROCEDURE ATTACH WILL ATTEMPT >>                           <<B0.00>>07184000
<<  TO ATTACH (CREATE AND/OR ACTIVATE >>                       <<B0.00>>07186000
<<  A TASK            >>                                       <<B0.00>>07188000
                                                               <<B0.00>>07190000
LOGICAL PROCEDURE ATTACH(PROGNAME,PINNUM);                     <<B0.00>>07192000
BYTE ARRAY PROGNAME;                                           <<B0.00>>07194000
INTEGER PINNUM;                                                <<B0.00>>07196000
                                                               <<B0.00>>07198000
BEGIN                                                          <<B0.00>>07200000
   INTEGER COUNT;                                              <<B0.00>>07202000
   DOUBLE PROCINFO;                                            <<B0.00>>07204000
<<  >>                                                         <<B0.00>>07206000
   SCAN PROGNAME UNTIL %6440,1;                                <<B0.00>>07208000
   COUNT := TOS - @PROGNAME;                                   <<B0.00>>07210000
   ATTACH:=FALSE;                                              <<B0.00>>07212000
   IF LASTCREATE = PROGNAME ,(COUNT)  THEN                     <<B0.00>>07214000
      BEGIN                                                    <<B0.00>>07216000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>07218000
      IF (LASTPIN := GETPROCID(1)) = 0                         <<B0.00>>07220000
      THEN GO TO CREATE'TASK;                                  <<B0.00>>07222000
      ACTIVATE(PINNUM,3);                                      <<B0.00>>07224000
      IF < THEN GO TO CREATE'TASK;                             <<B0.00>>07226000
      IF (LASTPIN := GETPROCID(1)) = 0                         <<B0.00>>07228000
      THEN LASTCREATE := 0;    <<SON HAS TERMINATED>>          <<B0.00>>07230000
      XCONTRAP(CYLABEL,CYOLD); <<REARM CONTROLY>>              <<B0.00>>07232000
      ATTACH:=TRUE;                                            <<B0.00>>07234000
      CRITFLAG := TRUE;;                                       <<B0.00>>07236000
      RETURN;                                                  <<B0.00>>07238000
      END;                                                     <<B0.00>>07240000
CREATE'TASK:                                                   <<B0.00>>07242000
          IF LASTPIN <> 0 THEN                                 <<B0.00>>07244000
             KILL(LASTPIN);                                    <<B0.00>>07246000
   ERRORON; INTRINS := 100;NUMPARMS :=2;                       <<B0.00>>07248000
   CREATE (PROGNAME,,PINNUM,SUBTASK'LEVEL,1);                  <<B0.00>>07250000
      IF < OR CARRY  THEN                                      <<B0.00>>07252000
            BEGIN                                              <<B0.00>>07254000
            ATTACH:=FALSE;                                     <<B0.00>>07256000
            ERROREXIT(INTRWORD,0,0);                           <<B0.00>>07258000
            RETURN;                                            <<B0.00>>07260000
            END                                                <<B0.00>>07262000
     ELSE BEGIN                                                <<B0.00>>07264000
     CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;     <<B0.00>>07266000
          ACTIVATE(PINNUM,3);                                  <<B0.00>>07268000
         XCONTRAP(CYLABEL,CYOLD); <<REARM CONTROLY>>           <<B0.00>>07270000
          IF (LASTPIN := GETPROCID(1)) = 0                     <<B0.00>>07272000
      THEN LASTCREATE := 0     <<SON HAS TERMINATED>>          <<B0.00>>07274000
      ELSE                                                     <<B0.00>>07276000
          MOVE LASTCREATE:=PROGNAME,(27);                      <<B0.00>>07278000
      CRITFLAG := TRUE;                                        <<B0.00>>07280000
            ATTACH:=TRUE;                                      <<B0.00>>07282000
      ERROREXIT(INTRWORD,0,0);                                 <<B0.00>>07284000
          END;                                                 <<B0.00>>07286000
END;                                                           <<B0.00>>07288000
$PAGE "SPOOK MPE COMMAND PROCESSING ROUTINE"                   <<00897>>07290000
$CONTROL SEGMENT=SPOOK1                                        <<B0.00>>07292000
<< PROCEDURE MPECOMMAND WILL ATTEMPT>>                         <<B0.00>>07294000
<< TO EXECUTE PROGRAMMATICALLY A    >>                         <<B0.00>>07296000
<< COMMAND STRING THAT IS NOT       >>                         <<B0.00>>07298000
<< A SPOOK COMMAND                  >>                         <<B0.00>>07300000
                                                               <<B0.00>>07302000
LOGICAL PROCEDURE MPECOMMAND(COMMAND'STRING);                  <<B0.00>>07304000
BYTE ARRAY   COMMAND'STRING;                                   <<B0.00>>07306000
                                                               <<B0.00>>07308000
BEGIN                                                          <<B0.00>>07310000
   INTEGER ERROR,PARM,I,J;                                     <<B0.00>>07312000
   BYTE POINTER BP1;                                           <<B0.00>>07314000
<<>>                                                           <<B0.00>>07316000
MPECOMMAND := FALSE;                                           <<B0.00>>07318000
COMMAND(COMMAND'STRING,ERROR, PARM);                           <<B0.00>>07320000
   IF = THEN MPECOMMAND := TRUE ELSE                           <<B0.00>>07322000
      IF > THEN                                                <<B0.00>>07324000
         BEGIN                                                 <<B0.00>>07326000
            IF ERROR < 0 THEN ERROR := -ERROR;                          07328000
            J := GENMSG(2,ERROR);                              <<B0.00>>07330000
            MPECOMMAND := TRUE;                                <<B0.00>>07332000
        END;                                                   <<B0.00>>07334000
END;                                                           <<B0.00>>07336000
$PAGE "SPOOK COPY/APPEND ROUTINES"                             <<00897>>07338000
$CONTROL SEGMENT=SPOOK3                                        <<B0.01>>07340000
                                                               <<B0.01>>07342000
LOGICAL PROCEDURE NEW'FILE'CLOSE(OLD);                         <<B0.01>>07344000
<<>>                                                           <<B0.01>>07346000
   VALUE OLD;                                                  <<B0.01>>07348000
   LOGICAL OLD;                                                <<B0.01>>07350000
                                                               <<04145>>07352000
<<****************************************************>>       <<04145>>07354000
<< THIS PROCEDURE CLOSES THE NEWLY CREATED COPIED FILE>>       <<B0.01>>07356000
<< THAT WAS OPENED AS A RESULT OF COPY/APPEND         >>       <<B0.01>>07358000
<< IF THE FILE IS A SPOOLFILE, THEN A CALL TO FSCLOSE >>       <<B0.01>>07360000
<< IS MADE AND THE APPROPRIATE SPOOLER IS AWAKENED.   >>       <<B0.01>>07362000
<< IF THE FILE IS A PERMANENT FILE, THEN IF A FILE    >>       <<B0.01>>07364000
<< WITH THE SAME NAME ALREADY EXISTS, THE USER IS     >>       <<B0.01>>07366000
<< PROMPTED FOR ITS REPLACEMENT.                      >>       <<B0.01>>07368000
<<****************************************************>>       <<04145>>07370000
                                                               <<04145>>07372000
BEGIN                                                          <<B0.01>>07374000
INTEGER DISP;  <<CLOSE DISPOSITION>>                           <<B0.01>>07376000
ARRAY FILENAME(0:13);                                          <<04145>>07378000
BYTE ARRAY FILENAME'B(*)=FILENAME;                             <<04145>>07380000
LOGICAL TRY'AGAIN;                                             <<B0.01>>07382000
<<>>                                                           <<B0.01>>07384000
                                                               <<B0.01>>07386000
NEW'FILE'CLOSE := FALSE;                                       <<B0.01>>07388000
DISP := %11;                                                   <<B0.01>>07390000
TRY'AGAIN := FALSE;                                            <<B0.01>>07392000
                                                               <<04145>>07394000
<<**********************************************************>> <<04145>>07396000
<<  If we have a new spoolfile, close it out.               >> <<04145>>07398000
<<**********************************************************>> <<04145>>07400000
                                                               <<04145>>07402000
IF NEW'SPOOLFILE THEN                                          <<B0.01>>07404000
   IF NEW'FILEN <> 0 THEN                                      <<B0.01>>07406000
   BEGIN                                                       <<B0.01>>07408000
   TOS := 0;                                                   <<B0.01>>07410000
   TOS := NEW'XDDN;                                            <<B0.01>>07412000
   ODDN := FINDODD(*);                                         <<B0.01>>07414000
   FSCLOSE(NEW'FILEN,0,0);                                     <<B0.01>>07416000
   IF < THEN                                                   <<B0.01>>07418000
      BEGIN                                                    <<B0.01>>07420000
      ERRN := 73; FCHECK(NEW'FILEN,ERRF); GO TO LX;            <<B0.01>>07422000
      END;                                                     <<B0.01>>07424000
   TOS := ODDN;                                                <<B0.01>>07426000
   SROOSTER(*);                                                <<B0.01>>07428000
   NEW'SPOOLFILE := FALSE;                                     <<B0.01>>07430000
   END                                                         <<B0.01>>07432000
   ELSE GO TO LX                                               <<B0.01>>07434000
$PAGE                                                          <<04145>>07436000
<<**********************************************************>> <<04145>>07438000
<< Permanent file, try closing it permanent, freeing space  >> <<04145>>07440000
<< after EOF.                                               >> <<04145>>07442000
<<**********************************************************>> <<04145>>07444000
                                                               <<04145>>07446000
ELSE                                                           <<B0.01>>07448000
PERM'CLOSE:                                                    <<B0.01>>07450000
   BEGIN                                                       <<B0.01>>07452000
   FCLOSE(NEW'FILEN,DISP,0);                                   <<B0.01>>07454000
   IF < THEN                                                   <<B0.01>>07456000
      BEGIN                                                    <<B0.01>>07458000
      IF TRY'AGAIN THEN                                        <<B0.01>>07460000
        BEGIN                                                  <<B0.01>>07462000
        DISP := -1;                                            <<B0.01>>07464000
        GO TO PERM'CLOSE;                                      <<B0.01>>07466000
        END;                                                   <<B0.01>>07468000
      TRY'AGAIN := TRUE;                                       <<B0.01>>07470000
      ERRN := 73; FCHECK(NEW'FILEN,ERRF);                      <<B0.01>>07472000
                                                               <<04145>>07474000
      <<****************************************************>> <<04145>>07476000
      << If the file already exists (perm or temp), ask the >> <<04145>>07478000
      << user if he wants the file purged.                  >> <<04145>>07480000
      <<****************************************************>> <<04145>>07482000
                                                               <<04145>>07484000
      IF ERRF = 100 OR ERRF = 101 THEN                         <<B0.01>>07486000
         BEGIN                                                 <<B0.01>>07488000
REPLACE'FILE:                                                  <<B0.01>>07490000
         FGETINFO(NEW'FILEN,FILENAME'B);                       <<04145>>07492000
         MOVE CBUF := PRINTFILE,2;                             <<04145>>07494000
         I := TOS - @CBUF;                                     <<04145>>07496000
         MOVE CBUF(3) := FILENAME,(13);                        <<04145>>07498000
         PRINT(CBUF,I,0);                                      <<04145>>07500000
         MOVE CBUF := REPLACEFILE,2;                           <<B0.01>>07502000
         I := TOS - @CBUF;                                     <<B0.01>>07504000
         PRINT(CBUF,I,%320);                                   <<B0.01>>07506000
         CRITFLAG := FALSE; IF CONTROLYFLAG THEN               <<B0.01>>07508000
            CONTROLYPROC;                                      <<B0.01>>07510000
         COUNT := READ(CBUF,-72);                              <<B0.01>>07512000
         CRITFLAG := TRUE;                                     <<B0.01>>07514000
             ERRF := NO'FILE'ERROR;                            <<04145>>07516000
         @BP := @BCBUF;                                        <<B0.01>>07518000
         BP(COUNT) := CR ;                                     <<04145>>07520000
         IF NOT SHIFTUPPER(BP,COUNT) THEN GO REPLACE'FILE;     <<B0.01>>07522000
         SCAN BP WHILE %6440 ,1; <<CR,BLANK>>                  <<B0.01>>07524000
         @BP := TOS;                                           <<B0.01>>07526000
                                                               <<04145>>07528000
         <<*************************************************>> <<04145>>07530000
         <<  If so, purge the file via MPECOMMAND and re-   >> <<04145>>07532000
         << close the file via PERM'CLOSE.                  >> <<04145>>07534000
         <<*************************************************>> <<04145>>07536000
                                                               <<04145>>07538000
         IF NOCARRY AND BP = "Y" THEN                          <<B0.01>>07540000
            BEGIN                                              <<B0.01>>07542000
            IF OLD THEN MOVE BCBUF(6) := OLD'FILENAME,(29)     <<B0.01>>07544000
                   ELSE MOVE BCBUF(6) := NEW'FILENAME,(29);    <<B0.01>>07546000
            MOVE BCBUF(6+28) := CR ;                           <<04145>>07548000
            MOVE BCBUF := "PURGE ";                            <<B0.01>>07550000
            MPECOMMAND(BCBUF);                                 <<B0.01>>07552000
            DISP := %11;                                       <<B0.01>>07554000
            GO TO PERM'CLOSE;                                  <<B0.01>>07556000
            END                                                <<B0.01>>07558000
                                                               <<04145>>07560000
       <<***************************************************>> <<04145>>07562000
       <<  Otherwise, prompt the user for a new file name,  >> <<04145>>07564000
       << a CR signifies user wants the new file purged.    >> <<04145>>07566000
       <<***************************************************>> <<04145>>07568000
                                                               <<04145>>07570000
       ELSE                                                    <<B0.01>>07572000
RENAME'FILE:                                                   <<B0.01>>07574000
          BEGIN                                                <<B0.01>>07576000
          CRITFLAG := FALSE;                                   <<B0.01>>07578000
          IF CONTROLYFLAG THEN CONTROLYPROC;                   <<B0.01>>07580000
          MOVE CBUF := RENAMEFILE,2;                           <<B0.01>>07582000
          I := TOS - @CBUF;                                    <<B0.01>>07584000
          PRINT(CBUF,I,%320);                                  <<B0.01>>07586000
          COUNT := READ(CBUF,-72);                             <<B0.01>>07588000
          CRITFLAG := TRUE;                                    <<B0.01>>07590000
          @BP := @BCBUF;                                       <<B0.01>>07592000
          BP(COUNT) := CR ;                                    <<04145>>07594000
          IF NOT SHIFTUPPER(BP,COUNT) THEN                     <<B0.01>>07596000
             GO RENAME'FILE;                                   <<B0.01>>07598000
          SCAN BP WHILE %6440 ,1; <<CR , BLANK>>               <<B0.01>>07600000
          @BP := TOS;                                          <<B0.01>>07602000
          IF CARRY THEN                                        <<B0.01>>07604000
            BEGIN                                              <<B0.01>>07606000
            DISP := %4;  <<DELETE FILE>>                       <<B0.01>>07608000
            GO TO PERM'CLOSE;                                  <<B0.01>>07610000
            END;                                               <<B0.01>>07612000
                                                               <<04145>>07614000
          <<************************************************>> <<04145>>07616000
          << Otherwise rename the file and reclose it.  If  >> <<04145>>07618000
          << RENAME failed, return to RENAME'FILE to        >> <<04145>>07620000
          << prompt the user again.                         >> <<04145>>07622000
          <<************************************************>> <<04145>>07624000
                                                               <<04145>>07626000
          FRENAME(NEW'FILEN,BP);                               <<B0.01>>07628000
          IF <> THEN                                           <<B0.01>>07630000
             BEGIN                                             <<B0.01>>07632000
             MOVE CBUF := BAD'RENAME,2;                        <<04145>>07634000
             I := TOS - @CBUF;                                 <<04145>>07636000
             PRINT(CBUF,I,0);                                  <<04145>>07638000
             GO TO RENAME'FILE;                                <<04145>>07640000
             END                                               <<B0.01>>07642000
          ELSE                                                 <<B0.01>>07644000
             MOVE CBUF := RENAMED'MESSAGE,2;                   <<B0.01>>07646000
             I:= TOS - @CBUF;                                  <<B0.01>>07648000
             PRINT(CBUF,I,0);                                  <<B0.01>>07650000
             ERRN := 0;                                        <<B0.01>>07652000
             ERRF := NO'FILE'ERROR;                            <<04145>>07654000
             DISP := %11;                                      <<04145>>07656000
             TRY'AGAIN:=FALSE;                                 <<04145>>07658000
             GO TO PERM'CLOSE;                                 <<04145>>07660000
          END;  << Rename file >>                              <<04145>>07662000
                                                               <<04145>>07664000
          END; <<IF ERROR = 100 OR 101 >>                      <<04145>>07666000
                                                               <<04145>>07668000
      FCLOSE(NEW'FILEN,0,0); <<Give back file space>>          <<04145>>07670000
      NEW'FILEN:=0;                                            <<04145>>07672000
      GO TO LX; <<IF Other than Error 100 or 101>>             <<04145>>07674000
                                                               <<04145>>07676000
      END; <<IF < ON THE FCLOSE>>                              <<04145>>07678000
                                                               <<04145>>07680000
   END;  <<IF PERMENENT FILE>>                                 <<04145>>07682000
                                                               <<04145>>07684000
<<GOOD FCLOSE>>                                                <<04145>>07686000
                                                               <<04145>>07688000
LX1:                                                           <<B0.01>>07690000
NEW'FILE'CLOSE := TRUE;                                        <<B0.01>>07692000
NEW'FILEN := 0;                                                <<B0.01>>07694000
                                                               <<04145>>07696000
<<Bad FCLOSE>>                                                 <<04145>>07698000
                                                               <<04145>>07700000
LX:                                                            <<B0.01>>07702000
END;                                                           <<B0.01>>07704000
                                                               <<B0.01>>07706000
$CONTROL SEGMENT=SPOOK3                                        <<B0.01>>07708000
                                                               <<B0.01>>07710000
LOGICAL PROCEDURE NEW'FILE'OPEN;                               <<B0.01>>07712000
<<>>                                                           <<B0.01>>07714000
<< THIS PROCEDURE IS INVOKED TO CREATE A NEW FILE>>            <<B0.01>>07716000
<< FOR COPY/APPEND OR IN THE CASE OF APPEND TO   >>            <<B0.01>>07718000
<< USE FILE ALREADY OPENED FOR OUTPUT.           >>            <<B0.01>>07720000
<<>>                                                           <<B0.01>>07722000
BEGIN                                                          <<B0.01>>07724000
INTEGER DEV;                                                   <<B0.01>>07726000
INTEGER TEMP;                                                           07728000
INTEGER FILEX, ORIG'FILEN ;                                    <<01886>>07730000
INTEGER POINTER IP;                                            <<B0.01>>07732000
DOUBLE POINTER DP = IP;                                        <<B0.01>>07734000
ARRAY CL(0:9) = Q;                                             <<B0.01>>07736000
DOUBLE DCL0 = CL + 0,DCL1 = CL+2;                              <<B0.01>>07738000
BYTE ARRAY BCL(*) = CL + 0;                                    <<B0.01>>07740000
LOGICAL STDLIST, CONTINUE;                                     <<01886>>07742000
<<>>                                                           <<B0.01>>07744000
NEW'FILE'OPEN := FALSE;                                        <<B0.01>>07746000
STDLIST := FALSE;   <<INITIALIZE>>                             <<00123>>07748000
IF NEW'FILEN <> 0 THEN  <<PREVIOUSLY OPENED FILE>>             <<B0.01>>07750000
   IF APPEND THEN      <<APPEND COMMAND>>                      <<B0.01>>07752000
      BEGIN                                                    <<B0.01>>07754000
      NEW'FILE'OPEN := TRUE;                                   <<B0.01>>07756000
      GO TO LX;                                                <<B0.01>>07758000
      END                                                      <<B0.01>>07760000
   ELSE                                                        <<B0.01>>07762000
      BEGIN          <<NEW FILE, MUST CLOSE OLD FILE>>         <<B0.01>>07764000
      IF NOT NEW'FILE'CLOSE(TRUE) THEN GO TO LX;               <<B0.01>>07766000
      END;                                                     <<B0.01>>07768000
MOVE NEW'DEVICE := "DISC"; <<DEFAULT>>                         <<B0.01>>07770000
NEW'DEVICE(4):=0;                                              <<B0.01>>07772000
NEW'NUMBUFS := 0;                                              <<B0.01>>07774000
IF NEW'FILENAME = "  " THEN                                    <<B0.01>>07776000
      BEGIN                                                    <<B0.01>>07778000
      <<ENSURE THAT XDD ARRAY REFLECTS TEXT FILE>>             <<B0.01>>07780000
                                                               <<B0.01>>07782000
      SPOOLOPEN(DEVFN,FILEX);                                  <<B0.01>>07784000
      FSCLOSE(FILEX,0,0);                                      <<B0.01>>07786000
     <<>>                                                      <<B0.01>>07788000
      MOVE NEW'FILENAME := BXDD(28),(8);   <<FILENAME>>        <<B0.01>>07790000
      IF NEW'FILENAME = "$STDLIST" THEN                        <<00123>>07792000
         BEGIN                                                 <<00123>>07794000
         STDLIST := TRUE;                                      <<00123>>07796000
         NEW'FILENAME := "S";      <<CHANGE "$" TO "S" >>      <<00123>>07798000
         END;                                                  <<00123>>07800000
      NEW'NUMBUFS.(4:7):=NEW'COPIES:=XDD(24).(8:8); <<COPIES>> <<B0.01>>07802000
      NEW'NUMBUFS.(0:4):=NEW'OUTPRI:=XDD.(3:4); <<OUTPRI>>     <<B0.01>>07804000
      IF XDD.(7:1) =1 THEN   <<CLASS BITS>>                    <<B0.01>>07806000
         BEGIN                                                 <<B0.01>>07808000
         DEV := -XDD.(8:8);                                    <<B0.01>>07810000
         EXCHANGEDB(LDTDST);                                   <<B0.01>>07812000
         @IP := BASE(1);                                       <<B0.01>>07814000
         WHILE (DEV := DEV +1) < 0 DO                          <<B0.01>>07816000
            @IP := @IP + (IP(5).(0:8)&ASR(1)) + 6;             <<B0.01>>07818000
         DCL0 := DP;                                           <<B0.01>>07820000
         DCL1 := DP(1);                                        <<B0.01>>07822000
         EXCHANGEDB(0);                                        <<B0.01>>07824000
         MOVE NEW'DEVICE := BCL,(8);                           <<B0.01>>07826000
         END                                                   <<B0.01>>07828000
      ELSE                                                     <<B0.01>>07830000
         ASCII(XDD.(8:8),10,NEW'DEVICE);  <<LDEV>>             <<B0.01>>07832000
      END;                                                     <<B0.01>>07834000
                                                               <<B0.01>>07836000
                                                               <<B0.01>>07838000
NEW'FILEN := FOPEN(NEW'FILENAME,%504,%1004,-132,                        07840000
                  NEW'DEVICE,,,,NEW'NUMBUFS);                  <<B0.01>>07842000
IF <> THEN                                                     <<B0.01>>07844000
   BEGIN ERRN:= 74; FCHECK(NEW'FILEN,ERRF); GO TO LX;          <<B0.01>>07846000
   END;                                                        <<B0.01>>07848000
FGETINFO(NEW'FILEN,NEW'FILENAME,NEW'FOPTIONS,                  <<B0.01>>07850000
         NEW'AOPTIONS,NEW'RECSIZE,NEW'DEVTYPE,                 <<B0.01>>07852000
         NEW'LDEV,NEW'HDADDR,NEW'DFID);                        <<B0.01>>07854000
   NEW'ENV := 0; <<INITIALIZE>>                                <<01886>>07856000
FFILEINFO(NEW'FILEN,38,NEW'DFID,43, NEW'ENV);                  <<01886>>07858000
PUSH(DL);                                                      <<00131>>07860000
TOS := TOS - 4 - NEW'FILEN * 4; <<AFTENTRY>>                   <<00131>>07862000
REMOTE'FILE := PS0.(0:4) = 1 <<ENTRY TYPE 1>>;                 <<00131>>07864000
DEL;                                                           <<00131>>07866000
IF REMOTE'FILE THEN                                                     07868000
   BEGIN                                                                07870000
   ERRN := 77;  <<DS COPY NOT AVAILABLE>>                               07872000
   FCLOSE(NEW'FILEN,4,0); <<PURGE NEW FILE>>                            07874000
   NEW'FILEN := 0;                                                      07876000
   GO TO LX;                                                            07878000
   END;                                                                 07880000
IF NOT REMOTE'FILE THEN                                        <<00131>>07882000
IF NEW'HDADDR.(0:8) = 0 THEN                                   <<B0.01>>07884000
   <<NEW SPOOLFILE>>                                           <<B0.01>>07886000
   BEGIN                                                       <<B0.01>>07888000
   IF NOT SFINDODD(NEW'DFID,NEW'XDDN) THEN                     <<B0.01>>07890000
      BEGIN ERRN:= 75; GO TO LX; END;                          <<B0.01>>07892000
   PRI := 1;                                                   <<B0.01>>07894000
   COPIES := 0;                                                <<B0.01>>07896000
   CLDEV := 0;                                                 <<B0.01>>07898000
   ALTERXDD(NEW'DFID);     <<TEMPORARY DEFER>>                 <<B0.01>>07900000
   FCLOSE(NEW'FILEN,0,0);                                      <<B0.01>>07902000
   IF NOT SPOOLOPEN(NEW'DFID,NEW'FILEN) THEN                   <<B0.01>>07904000
      GO TO LX;                                                <<B0.01>>07906000
   MOVE SBUF(512) := SBUF, (512); <<STORE CURRENT BLOCK>>      <<B0.01>>07908000
   FREAD(NEW'FILEN,SBUF,512);  <<GET FOPEN RECORD>>            <<B0.01>>07910000
   MOVE NEW'BUFW := SBUF,((SBUF+3)/2);<<FOPEN RECORD>>         <<B0.01>>07912000
   FILE'FORMSMSG := IF SBUF > 8 THEN TRUE                      <<B0.01>>07914000
        ELSE FALSE;      <<IF FORMSMSG THEN TRUE>>             <<B0.01>>07916000
   INHIBIT'FOPEN := FALSE;                                     <<01726>>07918000
   ORIG'FILEN := NEW'FILEN;                                    <<01886>>07920000
   XDD.(3:4) := OLD'PRI; <<RESTORE ORIGINAL PRIORITY>>         <<B0.01>>07922000
   DEV := XDD.(8:8);                                           <<B0.01>>07924000
   IF XDD.(7:1) = 1 THEN DEV := -DEV;                          <<B0.01>>07926000
   XDD.(1:2) := 2;  <<SET NEW FILE AS OPEN IN XDD>>            <<B0.01>>07928000
   IF STDLIST THEN BEGIN <<CHANGE "S" BACK TO "$">>            <<00123>>07930000
                   STDLIST := FALSE; XDD(14) := "$S";          <<00123>>07932000
                   END;                                        <<00123>>07934000
    IF SPUTXDD(1,DEV,XDD,NEW'XDDNP) <> 0 THEN                  <<B0.01>>07936000
      BEGIN ERRN:=59; GO TO LX; END;                           <<B0.01>>07938000
   NEW'FILEN := FSOPEN(,%304,%501,NEW'XDDN);                   <<B0.01>>07940000
   IF < THEN                                                   <<B0.01>>07942000
      BEGIN ERRN := 74; SREMOVEXDD(NEW'XDDNP);                 <<B0.01>>07944000
       NEW'FILEN := 0;                                         <<B0.01>>07946000
      END;                                                     <<B0.01>>07948000
   FCONTROL(ORIG'FILEN,5,TEMP); <<REWIND SPOOLFILE>>                    07950000
   CONTINUE := TRUE;                                           <<01886>>07952000
   DO                                                          <<01886>>07954000
   BEGIN  <<READ ORIGINAL FILE AND WRITE FOPEN, ENV RECS>>     <<01886>>07956000
      FREAD(ORIG'FILEN, SBUF, 512);                            <<01886>>07958000
      IF <> THEN BEGIN CONTINUE := FALSE; GO TO LX1; END;      <<01886>>07960000
      FWRITE(NEW'FILEN, SBUF, 512, 0);                         <<01886>>07962000
      IF <> THEN                                               <<01886>>07964000
      BEGIN ERRN := 27; GO TO LX; END;                         <<01886>>07966000
   END                                                         <<01886>>07968000
   UNTIL  NOT CONTINUE;                                        <<01886>>07970000
LX1:                                                           <<01886>>07972000
   FSCLOSE(ORIG'FILEN,4,0);  <<PURGE FILE>>                    <<01886>>07974000
   NEW'SPOOLFILE := TRUE;                                      <<B0.01>>07976000
   END;                                                        <<B0.01>>07978000
NEW'FILE'OPEN := TRUE;                                         <<B0.01>>07980000
LX:                                                            <<B0.01>>07982000
END;                                                           <<B0.01>>07984000
                                                               <<B0.01>>07986000
                                                               <<B0.01>>07988000
$PAGE                                                          <<04145>>07990000
$CONTROL SEGMENT=SPOOK2                                        <<B0.01>>07992000
                                                               <<B0.01>>07994000
LOGICAL PROCEDURE COPYRANGE(SKAN);                             <<B0.01>>07996000
   VALUE   SKAN;                                               <<B0.01>>07998000
   LOGICAL SKAN;                                               <<B0.01>>08000000
   BEGIN                                                       <<B0.01>>08002000
   INTEGER IX,IY,CT,CTL,LSP,NX;                                <<B0.01>>08004000
   INTEGER                                                     <<04626>>08006000
      OLD'REC'SIZE;   << # of bytes to xfer from old spoofle>> <<04626>>08008000
   LOGICAL UNI;                                                <<B0.01>>08010000
   BYTE POINTER BSP,NEW'BUF'PNTR;                              <<04626>>08012000
   LOGICAL POINTER SP'NEXT;                                    <<B0.01>>08014000
   DEFINE NEW'VAR'FILE = NEW'FOPTIONS.(8:2)=1#;                <<04626>>08016000
   << >>                                                       <<B0.01>>08018000
   UNI := TRUE;                                                <<B0.01>>08020000
   DO                                                          <<B0.01>>08022000
      BEGIN                                                    <<B0.01>>08024000
      IF UNI THEN                                              <<B0.01>>08026000
      BEGIN                                                    <<B0.01>>08028000
         UNI := FALSE ;                                        <<B0.01>>08030000
      IF NEW'SPOOLFILE THEN                                    <<B0.01>>08032000
         BEGIN                                                 <<B0.01>>08034000
         IF NOT FILE'FORMSMSG AND NOT INHIBIT'FOPEN THEN       <<01726>>08036000
         COPY'LAST'OPEN;                                       <<B0.01>>08038000
                                                               <<B0.01>>08040000
         INHIBIT'FOPEN := TRUE; <<JUST COPY FIRST FOPEN>>      <<01726>>08042000
         FILE'FORMSMSG := FALSE; <<RESET FOR SUBSEQENT FOPENS>><<B0.01>>08044000
         COMPRESS(SBUF,@SP,512);                               <<B0.01>>08046000
         @SP := @SBUF;                                         <<B0.01>>08048000
         END;                                                  <<B0.01>>08050000
      END                                                      <<B0.01>>08052000
      ELSE                                                     <<B0.01>>08054000
         IF NOT SKANTOLINE(FALSE) THEN GOTO LX;                <<B0.01>>08056000
                                                               <<04145>>08058000
      <<****************************************************>> <<04145>>08060000
      << Now, SP(word pointer) points to the beginning of   >> <<04145>>08062000
      << the next spoolfile record to copy and BSP(byte ptr)>> <<04145>>08064000
      << points to the beginning of the data of the record. >> <<04145>>08066000
      << The spoolfile record looks like the following:     >> <<04145>>08068000
      <<                                                    >> <<04145>>08070000
      <<   SP----->------------------------------------     >> <<04145>>08072000
      <<    Word 0 | Byte count of entire record - 2  |     >> <<04145>>08074000
      <<           |----------------------------------|     >> <<04145>>08076000
      <<    Word 1 | Byte cnt data portion, w/blanks  |     >> <<04145>>08078000
      <<           |----------------------------------|     >> <<04145>>08080000
      <<    Word 2 | Function code of ATTACHIO        |     >> <<04145>>08082000
      <<           |----------------------------------|     >> <<04145>>08084000
      <<    Word 3 | P1 ATTACHIO parameter            |     >> <<04145>>08086000
      <<           |----------------------------------|     >> <<04145>>08088000
      <<    Word 4 | P2 ATTACHIO parameter            |     >> <<04145>>08090000
      <<   BSP---->|----------------------------------|     >> <<04145>>08092000
      <<    Word 5+| DATA portion of record           |     >> <<04145>>08094000
      <<           ~                                  ~     >> <<04145>>08096000
      <<           |----------------------------------|     >> <<04145>>08098000
      <<****************************************************>> <<04145>>08100000
                                                               <<04145>>08102000
      @BSP := @SP(5)&ASL(1);                                   <<B0.01>>08104000
      LSP := FLINECNT;                                         <<B0.01>>08106000
$PAGE                                                          <<04145>>08108000
      <<****************************************************>> <<04145>>08110000
      << If we are copying to a new spoolfile, then check if>> <<04145>>08112000
      << we are at the end of a block (-1 after record).    >> <<04145>>08114000
      <<****************************************************>> <<04145>>08116000
                                                               <<04145>>08118000
      IF NEW'SPOOLFILE THEN                                    <<B0.01>>08120000
      BEGIN                                                    <<B0.01>>08122000
      @SP'NEXT := LOGICAL(@SP) + LOGICAL((SP +3)/2);           <<B0.01>>08124000
      IF  SP'NEXT = -1 THEN                                    <<B0.01>>08126000
         BEGIN                                                 <<B0.01>>08128000
         FWRITE(NEW'FILEN,SBUF,512,0);                         <<B0.01>>08130000
         IF <> THEN                                            <<B0.01>>08132000
            BEGIN                                              <<B0.01>>08134000
            ERRN := 27; FCHECK(NEW'FILEN,ERRF); GO TO LX;      <<B0.01>>08136000
            END;                                               <<B0.01>>08138000
                                                               <<B0.01>>08140000
         END;                                                  <<B0.01>>08142000
      END                                                      <<B0.01>>08144000
                                                               <<04145>>08146000
      <<****************************************************>> <<04145>>08148000
      << Otherwise, we have a regular disc file.  The start->> <<04626>>08150000
      << ing byte location of the new file buffer and the   >> <<04626>>08152000
      << old file buffer BSP, will be different when copying>> <<04626>>08154000
      << from NOCCTL to CCTL or vise-versa.  When copying   >> <<04626>>08156000
      << to a file with CCTL, transform the FCONTROL func-  >> <<04626>>08158000
      << tions to a record with only a CCTL byte in it,     >> <<04626>>08160000
      << equal to the FCONTROL function.                    >> <<04626>>08162000
      <<****************************************************>> <<04145>>08164000
                                                               <<04145>>08166000
      ELSE                                                     <<B0.01>>08168000
         BEGIN                                                 <<B0.01>>08170000
         NEW'BUF(0) := " ";  << Blank out the new buffer.   >> <<04626>>08172000
         MOVE NEW'BUF(1) := NEW'BUF(0),(255);                  <<04626>>08174000
         OLD'REC'SIZE := SP(0) - 8; << Size of actual data. >> <<04626>>08176000
         @NEW'BUF'PNTR := @NEW'BUF; << Assume no change.    >> <<04626>>08178000
                                                               <<04626>>08180000
         << For variable files, record size in neg. bytes.  >> <<04626>>08182000
                                                               <<04626>>08184000
         IF NEW'VAR'FILE                                       <<04626>>08186000
            THEN NEW'RECSIZE := -OLD'REC'SIZE;                 <<04626>>08188000
         IF CCTLOPTION THEN                                    <<04626>>08190000
            BEGIN << New file has carriage control          >> <<04626>>08192000
            IF SP(2) = 2 AND OLD'REC'SIZE = 0 THEN             <<04626>>08194000
               BEGIN   << FCONTROL function! Place in CCTL  >> <<04626>>08196000
               OLD'REC'SIZE := 1;   << Transfer one byte    >> <<04626>>08198000
               IF NEW'VAR'FILE                                 <<04626>>08200000
                  THEN NEW'RECSIZE := -1;                      <<04626>>08202000
               @BSP := @BSP - 3;    << Point P1 control byte>> <<04626>>08204000
               END                                             <<04626>>08206000
                                                               <<04626>>08208000
            <<**********************************************>> <<04626>>08210000
            << New file has CCTL, old file does not, skip   >> <<04626>>08212000
            << past CCTL byte of new file.                  >> <<04626>>08214000
            <<**********************************************>> <<04626>>08216000
                                                               <<04626>>08218000
            ELSE IF NOCCTL'INPUT THEN                          <<04626>>08220000
               @NEW'BUF'PNTR := @NEW'BUF'PNTR + 1;             <<04626>>08222000
            END                                                <<04626>>08224000
         ELSE IF NOT NOCCTL'INPUT THEN                         <<04626>>08226000
            BEGIN << New does not have CCTL, old file does! >> <<04626>>08228000
            @BSP := @BSP + 1;  << Skip over CCTL byte.      >> <<04626>>08230000
            IF OLD'REC'SIZE > 1                                <<04626>>08232000
               THEN OLD'REC'SIZE := OLD'REC'SIZE - 1;          <<04626>>08234000
            IF NEW'VAR'FILE << Decrement variable count.  >>   <<04626>>08236000
               THEN NEW'RECSIZE := NEW'RECSIZE + 1;            <<04626>>08238000
            END;                                               <<04626>>08240000
                                                               <<04626>>08242000
         <<*************************************************>> <<04626>>08244000
         << Now do the MOVE and write the record.  The de-  >> <<04626>>08246000
         << fault CCTL for new files is single space (" "). >> <<04626>>08248000
         <<*************************************************>> <<04626>>08250000
                                                               <<04626>>08252000
          IF NEW'RECSIZE <> 0 AND OLD'REC'SIZE <> 0 THEN       <<04626>>08254000
             BEGIN                                             <<04626>>08256000
             MOVE NEW'BUF'PNTR := BSP,(OLD'REC'SIZE);          <<04626>>08258000
             IF NEW'BUF(0) = 0 AND CCTLOPTION                  <<04626>>08260000
                THEN NEW'BUF(0) := " ";                        <<04626>>08262000
             FWRITE(NEW'FILEN,NEW'BUFW,NEW'RECSIZE,1);         <<04626>>08264000
             IF <> THEN                                        <<04626>>08266000
                BEGIN                                          <<04626>>08268000
                ERRN := 27;                                    <<04626>>08270000
                FCHECK(NEW'FILEN,ERRF);                        <<04626>>08272000
                GO TO LX;                                      <<04626>>08274000
                END;                                           <<04626>>08276000
             END;                                              <<04626>>08278000
         CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC; <<04145>>08280000
         CRITFLAG := TRUE;                                     <<04145>>08282000
         END; <<ELSE OF IF NEW'SPOOLFILE>>                     <<04145>>08284000
      END   <<OF DO UNTIL FLINE >= TOLINE >>                   <<04145>>08286000
   UNTIL FLINE >= TOLINE;                                      <<B0.01>>08288000
$PAGE                                                          <<04145>>08290000
   <<*******************************************************>> <<04145>>08292000
   << If you can explain the below code, be my guest!!!     >> <<04145>>08294000
   <<*******************************************************>> <<04145>>08296000
                                                               <<04145>>08298000
   IF NEW'SPOOLFILE THEN                                       <<B0.01>>08300000
      IF TOLINE < EOFLINE AND SP'NEXT <> -1 THEN               <<B0.01>>08302000
      BEGIN                                                    <<B0.01>>08304000
      MOVE SBUF(512) := SBUF,(512);                            <<B0.01>>08306000
       SP'NEXT := -1;                                          <<B0.01>>08308000
      MOVE  SP'NEXT(1) :=  SP'NEXT,(  512-( @SP'NEXT-@SBUF)-1);<<B0.01>>08310000
      FWRITE(NEW'FILEN,SBUF,512,0);                            <<B0.01>>08312000
      IF <> THEN                                               <<B0.01>>08314000
        BEGIN                                                  <<B0.01>>08316000
        ERRN := 27; FCHECK(NEW'FILEN,ERRF);                    <<B0.01>>08318000
        GO TO LX;                                              <<B0.01>>08320000
        END;                                                   <<B0.01>>08322000
      MOVE SBUF := SBUF(512),(512); <<RESTORE LAST BLOCK>>     <<B0.01>>08324000
<<    FREADDIR(FILEN,SBUF,512,BLOCKNO);   RESTORE LAST BLOCK>> <<B0.01>>08326000
<<    IF <> THEN  >>                                           <<B0.01>>08328000
<<    BEGIN      >>                                            <<B0.01>>08330000
<<       ERRN:= 26; FCHECK(FILEN,ERRF); GO TO LX;   >>         <<B0.01>>08332000
<<       END;  >>                                              <<B0.01>>08334000
      END;                                                     <<B0.01>>08336000
                                                               <<B0.01>>08338000
   COPYRANGE := TRUE;                                          <<B0.01>>08340000
LX:                                                            <<B0.01>>08342000
   END;                                                        <<B0.01>>08344000
$CONTROL SEGMENT=SPOOK2                                        <<00897>>08346000
                                                               <<00897>>08348000
LOGICAL PROCEDURE TEXT'NEXT'FILE(XDDP);                        <<00897>>08350000
  INTEGER POINTER XDDP;                                        <<00897>>08352000
                                                               <<00897>>08354000
BEGIN                                                          <<00897>>08356000
                                                               <<00897>>08358000
   TEXT'NEXT'FILE := FALSE;                                    <<00897>>08360000
   @XDDP := @XDDP - 30;                                        <<00897>>08362000
   IF FILEN <> 0 THEN                                          <<00897>>08364000
      BEGIN   <<RELEASE THE CURRENTLY TEXTED FILE>>            <<00897>>08366000
         TOS := 0;                                             <<00897>>08368000
         TOS := XDDN;                                          <<00897>>08370000
         ODDN := FINDODD(*);                                   <<00897>>08372000
         FSCLOSE(FILEN,0,0);                                   <<00897>>08374000
         IF < THEN                                             <<00897>>08376000
         BEGIN                                                 <<00897>>08378000
            ERRN := 24;                                        <<00897>>08380000
            FCHECK(FILEN,ERRF);                                <<00897>>08382000
            GO TO LX;                                          <<00897>>08384000
         END;                                                  <<00897>>08386000
         TOS := ODDN;                                          <<00897>>08388000
         SROOSTER(*);                                          <<00897>>08390000
         FILEN := 0;                                           <<00897>>08392000
         XDDN := 0;                                            <<00897>>08394000
         DEVFN := 0;                                           <<00897>>08396000
      END;                                                     <<00897>>08398000
   IF NOT SPOOLOPEN(DEVF := XDDP(18),FILEF) THEN               <<00897>>08402000
      GO TO LX ;                                               <<00897>>08404000
   START'RECNUM := FLINE + 1D; <<INITIALIZE START'RECNUM>>   <<<<01549>>08406000
   @BLOCKFP := @BLOCKCP := @BLOCKTABLE;                        <<00897>>08408000
   BLOCKNO := 0D;                                              <<00897>>08410000
   BLOCKFP := 0;                                               <<00897>>08412000
   MOVE BLOCKFP(1) := BLOCKFP, (BENTRIES*BENTRY'SIZE-1);       <<00897>>08414000
   FILEN := FILEF;                                             <<00897>>08416000
   XDDN := XDDX;                                               <<00897>>08418000
   DEVFN := DEVF;                                              <<00897>>08420000
   FLINE := -1D;                                               <<00897>>08422000
   FGETINFO(FILEN,,,,,,,,,,EOFLINE);                           <<00897>>08424000
   EOFLINE := EOFLINE - 1D;                                    <<00897>>08426000
   TEXT'NEXT'FILE := TRUE;                                     <<00897>>08428000
LX:                                                            <<00897>>08430000
END;   <<TEXT'NEXT'FILE>>                                      <<00897>>08432000
                                                               <<00897>>08434000
$CONTROL SEGMENT = SPOOK2                                      <<00897>>08436000
                                                               <<00897>>08438000
LOGICAL PROCEDURE ALTER'FILES;                                 <<00897>>08440000
                                                               <<00897>>08442000
BEGIN                                                          <<00897>>08444000
                                                               <<00897>>08446000
INTEGER POINTER XDDP;                                          <<00897>>08448000
                                                               <<00897>>08450000
   ALTER'FILES := FALSE;                                       <<00897>>08452000
   COUNT := 0;                                                 <<00897>>08454000
   @XDDP := INITXDDP;                                          <<00897>>08456000
   WHILE (COUNT := COUNT+1)<= XDDC                             <<00897>>08458000
   DO                                                          <<00897>>08460000
      BEGIN                                                    <<00897>>08462000
         @XDDP := @XDDP -30;                                   <<00897>>08464000
         MOVE XDD := XDDP,(30);                                <<00897>>08466000
         IF NOT ALTERXDD(XDD(XD'DFID)) THEN                    <<01326>>08468000
         BEGIN <<STORE ERRORS IN XDD COPY IN STACK>>           <<01326>>08470000
            XDDP(25).(0:8) := ERRN;                            <<01326>>08472000
            XDDP(25).(8:8) := ERRF;                            <<01326>>08474000
            ERRN := 0;                                         <<04145>>08476000
            ERRF := NO'FILE'ERROR;                             <<04145>>08478000
         END                                                   <<01726>>08480000
         ELSE                                                  <<01726>>08482000
         BEGIN                                                 <<01726>>08484000
             XDDP := XDD; XDDP(24) := XDD(24);                 <<01726>>08486000
         END;                                                  <<01726>>08488000
      END;                                                     <<00897>>08490000
   ALTER'FILES := TRUE;                                        <<00897>>08492000
EXIT1:                                                         <<00897>>08494000
END;    <<ALTER'FILES>>                                        <<00897>>08496000
                                                               <<00897>>08498000
$CONTROL SEGMENT = SPOOK2                                      <<00897>>08500000
                                                               <<00897>>08502000
LOGICAL PROCEDURE COPY'FILES;                                  <<00897>>08504000
                                                               <<00897>>08506000
BEGIN                                                          <<00897>>08508000
                                                               <<00897>>08510000
INTEGER POINTER XDDP;                                          <<00897>>08512000
                                                               <<00897>>08514000
COPY'FILES := FALSE;                                           <<00897>>08516000
   COUNT := 0;                                                 <<00897>>08518000
   @XDDP := INITXDDP;                                          <<00897>>08520000
   WHILE (COUNT := COUNT + 1) <=XDDC                           <<00897>>08522000
   DO  BEGIN                                                   <<00897>>08524000
      @BP := @SECONDPARM;                                      <<00897>>08526000
      IF COPY'FILES'FLAG THEN                                  <<00897>>08528000
      IF NOT TEXT'NEXT'FILE(XDDP) THEN GO TO EXIT1;            <<00897>>08530000
      IF NOT LINERANGE(COPY) THEN  GO TO EXIT1;                <<00897>>08532000
      IF NOT NEW'FILE'OPEN THEN GO TO EXIT1;                   <<00897>>08534000
      IF NOT SKANTOLINE(TRUE) THEN GO TO EXIT1;                <<00897>>08536000
      IF NOT COPYRANGE(FALSE) THEN GO TO EXIT1;                <<00897>>08538000
      IF NOT APPEND THEN                                       <<00897>>08540000
         IF NOT NEW'FILE'CLOSE(FALSE) THEN GO TO EXIT1;        <<00897>>08542000
   END;                                                        <<00897>>08544000
   COPY'FILES := TRUE;                                         <<00897>>08546000
                                                               <<00897>>08548000
EXIT1:                                                         <<00897>>08550000
END;  <<COPY'FILES>>                                           <<00897>>08552000
                                                               <<01726>>08554000
$PAGE "READ'RECORD WITH FREADDIR PROCEDURE"                    <<01726>>08556000
                                                               <<01726>>08558000
$CONTROL SEGMENT = SPOOK2                                      <<01726>>08560000
                                                               <<01726>>08562000
   PROCEDURE READ'RECORD(FILENUM, RECORDNUM, BUFFER, RECP,     <<01726>>08564000
        XDDP,BLOCKNUM, ERRNUM);                                <<01726>>08566000
                                                               <<01726>>08568000
      VALUE RECORDNUM, FILENUM, XDDP;                          <<01726>>08570000
      DOUBLE RECORDNUM, BLOCKNUM;                              <<01726>>08572000
      INTEGER POINTER RECP;                                    <<01726>>08574000
      INTEGER ERRNUM, FILENUM;                                 <<01726>>08576000
      LOGICAL XDDP;                                            <<01726>>08578000
      LOGICAL ARRAY BUFFER;                                    <<01726>>08580000
                                                               <<01726>>08582000
   BEGIN                                                       <<01726>>08584000
      COMMENT                                                  <<01726>>08586000
        THIS PROCEDURE READS A BLOCK CONTAINING                <<01726>>08588000
        THE RECORDNUM INTO BUFFER AND POINTS TO                <<01726>>08590000
        RECORDNUM WITH RECP, PLACES THE BLOCK                  <<01726>>08592000
        NUMBER IN BLOCKNUM.                                    <<01726>>08594000
        IF FILESYS ERROR THEN ERRNUM CONTAINS THE ERROR        <<01726>>08596000
        OTHERWISE ERRNUM = NO'FILE'ERROR.                      <<04145>>08598000
        IF RECORDNUM IS < FIRST NON PURGED RECORDNUM           <<01726>>08600000
        THEN WE RETURN CCL.                                    <<01726>>08602000
        IF RECORDUM IS PAST THE END OF FILE WE                 <<01726>>08604000
        RETURN CCG. OTHERWISE CCE.                             <<01726>>08606000
                                                               <<01726>>08608000
                                        ;                      <<01726>>08610000
                                                               <<01726>>08612000
   DOUBLE REC'FIRST'BLOCK,                                     <<01726>>08614000
          BLOCK'EOF,                                           <<01726>>08616000
          REC'EOF,                                             <<01726>>08618000
          REC'CURR'BLOCK,                                      <<01726>>08620000
          FIRST'BLOCK,                                         <<01726>>08622000
          TOT'SECTORS,                                         <<01726>>08624000
          TARGET'BLOCK,                                        <<01726>>08626000
          LAST'TARGET'BLOCK,                                   <<01726>>08628000
          HI'H2O,                                              <<01726>>08630000
          LO'H2O,                                              <<01726>>08632000
          DCOUNT;                                              <<01726>>08634000
                                                               <<01726>>08636000
   INTEGER REC'CNT'IN'BLOCK,                                   <<01726>>08638000
          NUMSPULABS,                                          <<01726>>08640000
          DEVICEFILE'ID,                                       <<01726>>08642000
          FIRST'EXTENT,                                        <<01726>>08644000
          LENGTH,                                              <<01726>>08646000
          CC,                                                  <<01726>>08648000
          INDEX,                                               <<01726>>08650000
          SCOUNT;                                              <<01726>>08652000
                                                               <<01726>>08654000
   LOGICAL STATUS = Q-1;                                       <<01726>>08656000
   LOGICAL CONTINUE,                                           <<01726>>08658000
            SINGLE'STEP,                                       <<01730>>08660000
          EXTENT'IN'SECTORS;                                   <<01726>>08662000
                                                               <<01726>>08664000
                                                               <<01726>>08666000
   LOGICAL ARRAY XDDENTRY(0:30);                               <<01726>>08668000
                                                               <<01726>>08670000
   DEFINE CONDCODE = STATUS.(6:2)#;                            <<01726>>08672000
                                                               <<01726>>08674000
   EQUATE  CCE = 2,                                            <<01726>>08676000
           CCG = 0,                                            <<01726>>08678000
           CCL = 1,                                            <<01726>>08680000
           ULAB = 17,   <<INTEGER>>                            <<01726>>08682000
           EOF = 10,    <<DOUBLE>>                             <<01726>>08684000
           NZEXTENT = 39, <<LOGICAL>>                          <<01726>>08686000
           EXTENTSIZE = 15, <<LOGICAL>>                        <<01726>>08688000
           DEVID = 38,  <<LOGICAL>>                            <<01726>>08690000
           XDD'ENTRY'LEN = 30;                                 <<01726>>08692000
                                                               <<01726>>08694000
SUBROUTINE DEF'MOVEFROMDSEG;                                   <<01726>>08696000
                                                               <<01726>>08698000
SUBROUTINE POINT'TO'RECORD;                                    <<01726>>08700000
   BEGIN                                                       <<01726>>08702000
       COMMENT                                                 <<01726>>08704000
           GIVEN A BUFFER THE LAST TWO WORDS ARE               <<01726>>08706000
           THE RECORDNUMBER OF THE FIRST RECORD                <<01726>>08708000
           IN BLOCK.                                           <<01726>>08710000
           POINT TO TARGET RECNUM WITH RECP                    <<01726>>08712000
                                            ;                  <<01726>>08714000
                                                               <<01726>>08716000
      SCOUNT := 0;                                             <<01726>>08718000
      TOS := BUFFER(510);                                      <<01726>>08720000
      TOS := BUFFER(511);                                      <<01726>>08722000
      DCOUNT := TOS;                                           <<01726>>08724000
      @RECP := @BUFFER;                                        <<01726>>08726000
      CONTINUE := TRUE;                                        <<01726>>08728000
      DO                                                       <<01726>>08730000
      BEGIN                                                    <<01726>>08732000
         IF DCOUNT >= RECORDNUM THEN                           <<01726>>08734000
            CONTINUE := FALSE                                  <<01726>>08736000
         ELSE                                                  <<01726>>08738000
            BEGIN                                              <<01726>>08740000
               LENGTH := BUFFER(SCOUNT);                       <<01726>>08742000
               INDEX := SCOUNT;                                <<01726>>08744000
               SCOUNT := SCOUNT + (LENGTH+3)&ASR(1);           <<01726>>08746000
               DCOUNT := DCOUNT + 1D;                          <<01726>>08748000
            END;                                               <<01726>>08750000
       END                                                     <<01726>>08752000
       UNTIL (NOT CONTINUE) LOR (INTEGER(BUFFER(SCOUNT))       <<01726>>08754000
                 = -1);                                        <<01726>>08756000
       @RECP := @BUFFER + SCOUNT;                              <<01726>>08758000
   END;  <<SUBROUTINE POINT'TO'RECORD>>                        <<01726>>08760000
                                                               <<01726>>08762000
   << FIND INITIAL PARAMETERS DEFINING SPOOLFILE>>             <<01726>>08764000
                                                               <<01726>>08766000
   CONDCODE := CCE;                                            <<01726>>08768000
   FFILEINFO(FILENUM, ULAB,       NUMSPULABS,                  <<01726>>08770000
                      EOF,        REC'EOF,                     <<01726>>08772000
                      EXTENTSIZE, EXTENT'IN'SECTORS,           <<01726>>08774000
                      NZEXTENT,   FIRST'EXTENT);               <<01726>>08776000
                                                               <<01726>>08778000
                                                               <<01726>>08780000
   MOVEFROMDSEG(@XDDENTRY, ODDDST, XDDP.(1:15),                <<01726>>08782000
       XDD'ENTRY'LEN);                                         <<01726>>08784000
                                                               <<01726>>08786000
   TOS := 0;                                                   <<01726>>08788000
   TOS := XDDENTRY(22).(0:8);  <<NUM EXTENTS>>                 <<01726>>08790000
   IF = THEN TOS := TOS + 1;                                   <<01726>>08792000
   TOS := LOGICAL( TOS - 1)**EXTENT'IN'SECTORS;                <<01726>>08794000
   TOS := TOS + DOUBLE(XDDENTRY(23));                          <<01726>>08796000
   TOT'SECTORS := TOS;   <<TOTAL SECTORS IN FILE>>             <<01726>>08798000
   BLOCK'EOF := (DOUBLE(((FIRST'EXTENT                         <<01726>>08800000
          -(IF FIRST'EXTENT = 0 THEN 0 ELSE 1))                <<01726>>08802000
          * INTEGER(EXTENT'IN'SECTORS))                        <<01726>>08804000
                - (NUMSPULABS + 1))                                     08806000
                + TOT'SECTORS)&DASR(2);                                 08808000
   FIRST'BLOCK := DOUBLE((FIRST'EXTENT *                       <<01726>>08810000
          INTEGER(EXTENT'IN'SECTORS)                           <<01726>>08812000
          - (IF FIRST'EXTENT = 0 THEN 0 ELSE                   <<01726>>08814000
            (NUMSPULABS + 1)))&ASR(2));                        <<01726>>08816000
   REC'CURR'BLOCK := TARGET'BLOCK := 0D;                       <<01726>>08818000
   IF RECORDNUM > REC'EOF THEN                                 <<01726>>08820000
   BEGIN                                                       <<01726>>08822000
      CONDCODE := CCG;                                         <<01726>>08824000
      RETURN;                                                  <<01726>>08826000
   END                                                         <<01726>>08828000
   ELSE                                                        <<01726>>08830000
   BEGIN                                                       <<01726>>08832000
      FREADDIR(FILENUM,BUFFER, 512, FIRST'BLOCK);              <<01726>>08834000
      IF <> THEN                                               <<01726>>08836000
      BEGIN                                                    <<01726>>08838000
         FCHECK(FILENUM, ERRNUM);  <<ERROR IN FIRST BLOCK>>    <<01726>>08840000
         CONDCODE := CCL;                                      <<01726>>08842000
         CONTINUE := FALSE;                                    <<01726>>08844000
      END                                                      <<01726>>08846000
      ELSE                                                     <<01726>>08848000
      BEGIN  <<READ WENT OK, GET RECORDNUM OF FIRST BLOCK>>    <<01726>>08850000
         TOS := BUFFER(510);                                   <<01726>>08852000
         TOS := BUFFER(511);                                   <<01726>>08854000
         REC'FIRST'BLOCK := TOS;                               <<01726>>08856000
         IF RECORDNUM < REC'FIRST'BLOCK THEN                   <<01726>>08858000
         BEGIN  <<TARGET RECORD BEFORE BEGINNING OF FILE>>     <<01726>>08860000
            CONDCODE := CCL;                                   <<01726>>08862000
            RETURN;                                            <<01726>>08864000
         END;                                                  <<01726>>08866000
      END;                                                     <<01726>>08868000
  END;                                                         <<01726>>08870000
                                                               <<01726>>08872000
   CONTINUE := TRUE;   <<INITIALIZE>>                          <<01726>>08874000
    LO'H2O := FIRST'BLOCK;                                     <<01726>>08876000
    HI'H2O := BLOCK'EOF - 1D;                                  <<01730>>08878000
    SINGLE'STEP := FALSE;                                      <<01730>>08880000
   DO                                                          <<01726>>08882000
   BEGIN << ITERATIVELY FIND BLOCK OF TARGETREC>>              <<01726>>08884000
      LAST'TARGET'BLOCK := TARGET'BLOCK;                       <<01726>>08886000
      TARGET'BLOCK := TARGET'BLOCK +                           <<01726>>08888000
              (BLOCK'EOF * (RECORDNUM - REC'CURR'BLOCK))       <<01726>>08890000
              / REC'EOF;                                       <<01726>>08892000
                                                               <<01726>>08894000
      IF FIRST'BLOCK > TARGET'BLOCK THEN                       <<01726>>08896000
         TARGET'BLOCK := FIRST'BLOCK                           <<01726>>08898000
               + (LAST'TARGET'BLOCK - FIRST'BLOCK)&DASR(1)     <<01726>>08900000
      ELSE                                                     <<01726>>08902000
      IF TARGET'BLOCK > BLOCK'EOF THEN                         <<01726>>08904000
         TARGET'BLOCK := LAST'TARGET'BLOCK +                   <<01726>>08906000
               (BLOCK'EOF - LAST'TARGET'BLOCK)&DASR(1) ;       <<01726>>08908000
                                                               <<01726>>08910000
                                                               <<01726>>08912000
             << READ TARGET BLOCK, SEE IF IN BALLPARK>>        <<01726>>08914000
            IF LAST'TARGET'BLOCK <  TARGET'BLOCK THEN          <<01730>>08916000
            LO'H2O := LAST'TARGET'BLOCK + 1D                   <<01726>>08918000
            ELSE                                               <<01726>>08920000
            IF LAST'TARGET'BLOCK >  TARGET'BLOCK THEN          <<01730>>08922000
            HI'H2O := LAST'TARGET'BLOCK - 1D;                  <<01726>>08924000
            IF LAST'TARGET'BLOCK = TARGET'BLOCK THEN           <<01730>>08926000
            BEGIN                                              <<01730>>08928000
               SINGLE'STEP := TRUE;                            <<01730>>08930000
            END;                                               <<01730>>08932000
            IF TARGET'BLOCK < LO'H2O THEN                      <<01726>>08934000
               TARGET'BLOCK := LO'H2O;                         <<01726>>08936000
            IF TARGET'BLOCK > HI'H2O THEN                      <<01726>>08938000
               TARGET'BLOCK := HI'H2O;                         <<01726>>08940000
TRY'READ:                                                      <<01730>>08942000
         CRITFLAG := FALSE;                                    <<01726>>08944000
         IF CONTROLYFLAG THEN CONTROLYPROC;                    <<01726>>08946000
         CRITFLAG := TRUE;                                     <<01726>>08948000
         FREADDIR(FILENUM, BUFFER, 512, TARGET'BLOCK);         <<01726>>08950000
         IF <> THEN                                            <<01726>>08952000
         BEGIN                                                 <<01726>>08954000
            FCHECK(FILENUM, ERRNUM);                           <<01726>>08956000
            CONDCODE := CCL;                                   <<01726>>08958000
            CONTINUE := FALSE;                                 <<01726>>08960000
         END                                                   <<01726>>08962000
         ELSE                                                  <<01726>>08964000
         BEGIN  <<SEE IF WE ARE IN RIGHT BLOCK>>               <<01726>>08966000
            TOS := BUFFER(510);                                <<01726>>08968000
            TOS := BUFFER(511);                                <<01726>>08970000
            REC'CURR'BLOCK := TOS;                             <<01726>>08972000
            VERIFY'BLOCK'STRUCTURE(BUFFER, INDEX,              <<01726>>08974000
                 REC'CNT'IN'BLOCK);                            <<01726>>08976000
            IF REC'CURR'BLOCK <= RECORDNUM AND                 <<01726>>08978000
               RECORDNUM <  REC'CURR'BLOCK +                   <<01726>>08980000
                DOUBLE(REC'CNT'IN'BLOCK   ) THEN               <<01726>>08982000
            BEGIN << A HIT !!!>>                               <<01726>>08984000
               ERRNUM := NO'FILE'ERROR;                        <<04145>>08986000
               CONDCODE := CCE;                                <<01726>>08988000
               BLOCKNUM := TARGET'BLOCK;                       <<01726>>08990000
               POINT'TO'RECORD;                                <<01726>>08992000
               CONTINUE := FALSE;                              <<01726>>08994000
            END                                                <<01730>>08996000
            ELSE                                               <<01730>>08998000
            IF SINGLE'STEP THEN                                <<01730>>09000000
            BEGIN                                              <<01730>>09002000
               IF RECORDNUM < REC'CURR'BLOCK THEN              <<01730>>09004000
                  TARGET'BLOCK := TARGET'BLOCK -1D             <<01730>>09006000
               ELSE                                            <<01730>>09008000
                  TARGET'BLOCK := TARGET'BLOCK + 1D;           <<01730>>09010000
               GO TO TRY'READ;                                 <<01730>>09012000
            END;                                               <<01730>>09014000
         END;                                                  <<01726>>09016000
                                                               <<01726>>09018000
  END                                                          <<01726>>09020000
                                                               <<01726>>09022000
  UNTIL NOT CONTINUE;                                          <<01726>>09024000
END; <<READ'RECORD>>                                           <<01726>>09026000
                                                               <<01726>>09028000
$PAGE  "SPOOK OUTER BLOCK"                                     <<B0.00>>09030000
<< - - -   MAIN PROGRAM   - - - >>                             <<01.02>>09032000
                                                                        09034000
SPOOK:                                                         <<B0.00>>09036000
   PINOFFATHER:=FATHER;                                        <<B0.00>>09038000
   IF = THEN SUBTASK:=TRUE;                                    <<B0.00>>09040000
   SUBTASK'LEVEL := IF SUBLEVEL = 0 THEN "1"                   <<B0.00>>09042000
        ELSE SUBLEVEL+1;                                       <<B0.00>>09044000
   CRITFLAG := TRUE;                                           <<B0.00>>09046000
   CYLABEL := @CONTROLY;                                                09048000
   PUSH(Q);                                                             09050000
   QVAL := TOS;                                                         09052000
   PUSH(S);                                                             09054000
   SVAL := TOS;                                                         09056000
   ARITRAP(FALSE);                                             <<01.02>>09058000
   PUSH(STATUS);                                                        09060000
   STATVAL := TOS;                                                      09062000
   XCONTRAP(CYLABEL,CYOLD);                                             09064000
   IF CYLABEL = 0 THEN                                                  09066000
      BEGIN                                                             09068000
         <<*************************************************>> <<04145>>09070000
         << Entrance from Control Y procedure.              >> <<04145>>09072000
         <<*************************************************>> <<04145>>09074000
                                                               <<04145>>09076000
CYNEXT:                                                                 09078000
      PUSH(S);                                                          09080000
      TOS := TOS-SVAL;                                                  09082000
      ASSEMBLE(SUBS 0);                                                 09084000
      IF FILET <> 0 THEN                                                09086000
         BEGIN                                                          09088000
         FCLOSE(FILET,1,0);                                    <<02724>>09090000
         FILET := 0;                                                    09092000
         END;                                                           09094000
       MOVE CBUF := "  ** Control Y ** ";                      <<04145>>09096000
      PRINT(CBUF,-17,0);                                       <<04145>>09098000
      GOTO NEXT;                                                        09100000
      END                                                               09102000
   ELSE                                                                 09104000
      CYADDR := @CYNEXT;                                                09106000
                                                               <<04145>>09108000
   <<*******************************************************>> <<04145>>09110000
   << Obtain a variety of information from the "WHO", inclu->> <<04145>>09112000
   << ding CAPabilities, names, LDEV etc.  Initialize global>> <<04145>>09114000
   << variables and print title.                            >> <<04145>>09116000
   <<*******************************************************>> <<04145>>09118000
                                                               <<04145>>09120000
   WHO(MODE,CAP,LAT,NAMES(0),NAMES(8),NAMES(4),                         09122000
                    NAMES(12),LDEV);                                    09124000
   IF CAP1.(5:1) THEN CAP1.(0:1) := 1;                                  09126000
   ERRN := 0;                                                           09128000
   ERRF := NO'FILE'ERROR;                                      <<04145>>09130000
   WARN := 0;                                                           09132000
   FILEN := 0;                                                          09134000
   FILET := 0;                                                          09136000
   XDDN := 0;                                                           09138000
   DEVFN := 0;                                                          09140000
   FALL := FALSE;                                                       09142000
   FWIDTH := 0;                                                         09144000
SPOOK'TITLE:                                                            09146000
   MOVE CBUF := PTITLE,2;                                      <<01.02>>09148000
   I := TOS-@CBUF;                                             <<01.02>>09150000
   MOVE BCBUF(VUUFF'COL) := OFFICIAL'VUUFF;                    <<04151>>09152000
   PRINT(CBUF,I,0);                                            <<01.02>>09154000
$PAGE                                                          <<04145>>09156000
<<**********************************************************>> <<04145>>09158000
<<                                                          >> <<04145>>09160000
<<    ############ C O M M A N D     L O O P ##########     >> <<04145>>09162000
<<                                                          >> <<04145>>09164000
<<**********************************************************>> <<04145>>09166000
                                                               <<04145>>09168000
NEXT:                                                                   09170000
   IF WARN <> 0 THEN                                                    09172000
      BEGIN                                                             09174000
      ERRMSG(WARN,NO'FILE'ERROR);                              <<04145>>09176000
      WARN := 0;                                                        09178000
      END;                                                              09180000
   DLSIZE(0);                                                           09182000
   INITXDDP := 0;                                                       09184000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>09186000
   CBUF := "> ";                                                        09188000
   I := 1;                                                     <<B0.00>>09190000
                                                               <<04145>>09192000
   <<*******************************************************>> <<04145>>09194000
   << Output prompt ">" and (sublevel).  Read Command and   >> <<04145>>09196000
   << check for errors on the way!!                         >> <<04145>>09198000
   <<*******************************************************>> <<04145>>09200000
                                                               <<04145>>09202000
   IF SUBLEVEL <> 0 THEN BEGIN                                 <<B0.00>>09204000
      CBUF.(8:8) := "(";                                       <<B0.00>>09206000
      CBUF(1).(0:8) := SUBLEVEL;                               <<B0.00>>09208000
      CBUF(1).(8:8) := ")";                                    <<B0.00>>09210000
      I := 2;                                                  <<B0.00>>09212000
      END;                                                     <<B0.00>>09214000
   PRINT(CBUF,I,%320);                                         <<B0.00>>09216000
   IF > THEN                                                   <<04145>>09218000
      TERMINATE                                                <<04145>>09220000
   ELSE IF < THEN                                              <<04145>>09222000
      BEGIN                                                    <<04145>>09224000
         ERRN := 22;                                           <<04145>>09226000
         GO TO ERROR;                                          <<04145>>09228000
      END;                                                     <<04145>>09230000
   COUNT := READ(CBUF(1),-72);                                          09232000
   IF < THEN                                                            09234000
      BEGIN ERRN := 23; GOTO ERROR; END;                                09236000
   IF > THEN                                                            09238000
      BEGIN ERRMSG(2,NO'FILE'ERROR); GO TO QUITL; END;         <<04145>>09240000
   IF NOT LOGICAL(MODE.(14:1)) THEN  <<NOT DUPLICATIVE>>       <<00897>>09242000
      PRINT(CBUF(1),-COUNT,0);                                 <<00897>>09244000
   CRITFLAG := TRUE;                                           <<B0.00>>09246000
                                                               <<04145>>09248000
   @BP := @BCBUF(2);                                                    09250000
   BP(COUNT) := CR ;                                           <<04145>>09252000
   CNT := 0;                                                            09254000
   SCAN BP(CNT) WHILE %6440,1; <<Skip past blanks, if empty >> <<04145>>09256000
   @BP := TOS;                  << go to command loop      >>  <<04145>>09258000
   IF CARRY THEN GOTO NEXT;                                             09260000
   MOVE BP := BP WHILE AS,1; << Scan for Alpha charactera an>> <<04145>>09262000
   CNT := TOS-@BP;           <<upshift.                     >> <<04145>>09264000
   IF CNT = 0 THEN                                             <<B0.01>>09266000
      BEGIN                                                    <<B0.01>>09268000
      ERRN := 20; GO TO ERROR;                                 <<B0.01>>09270000
      END;                                                     <<B0.01>>09272000
   I := 0;                                                              09274000
                                                               <<04145>>09276000
   <<*******************************************************>> <<04145>>09278000
   << Check for proper command name.  If not command, try   >> <<04145>>09280000
   << MPE command.                                          >> <<04145>>09282000
   <<*******************************************************>> <<04145>>09284000
                                                               <<04145>>09286000
   WHILE (I<CNUM) AND (BP<>COMMAND'LIST(I*CSIZE),(CNT)) DO     <<B0.00>>09288000
      I := I+1;                                                         09290000
   IF I = CNUM THEN                                                     09292000
      IF NOT MPECOMMAND(BP) THEN                               <<04145>>09294000
         BEGIN                                                 <<04145>>09296000
           ERRN := 20; GO TO ERROR;                            <<04145>>09298000
         END                                                   <<04145>>09300000
      ELSE GO TO NEXT;                                         <<04145>>09302000
   IF NOT SHIFTUPPER(BP,COUNT) THEN GO TO ERROR;               <<04145>>09304000
   SCAN BP(CNT) WHILE %6440,1;                                          09306000
   @BP := TOS;                                                          09308000
   CARRYF := 0;                                                         09310000
   TOS := @BP;                                                          09312000
   TOS := @BP;                                                          09314000
   WHILE NOT CARRYF DO                                                  09316000
      BEGIN                                                             09318000
      SCAN * WHILE %6440,1;                                             09320000
      ASSEMBLE(DUP,DUP);                                                09322000
      IF BPS0 = %42 THEN                                                09324000
         BEGIN                                                          09326000
         TOS := TOS+1;                                                  09328000
         SCAN * UNTIL %6442,1;                                          09330000
         END;                                                           09332000
      IF CARRY                                                          09334000
         THEN CARRYF := TRUE                                            09336000
         ELSE TOS := TOS+1;                                             09338000
      ASSEMBLE(XCH,SUB);                                                09340000
      CNT := TOS;                                                       09342000
      MOVE * := *,(CNT),1;                                              09344000
      END;                                                              09346000
   MOVE * := *,(1);                                                     09348000
   GOTO SWCOM(I);                                                       09350000
                                                                        09352000
$PAGE                                                          <<04145>>09354000
<<*********************** E R R O R ! **********************>> <<04145>>09356000
                                                               <<04145>>09358000
ERROR:                                                                  09360000
   ERRMSG(ERRN,ERRF);                                                   09362000
   ERRN := 0;                                                           09364000
   ERRF := NO'FILE'ERROR;                                      <<04145>>09366000
   GOTO NEXT;                                                           09368000
                                                                        09370000
<<*********************** D E B U G ************************>> <<04145>>09372000
                                                               <<04145>>09374000
DBUGL:                                                                  09376000
   IF NOT CAP2.(9:1) THEN                                               09378000
      BEGIN                                                             09380000
      ERRN := 20;                                                       09382000
      WARN := 4;                                                        09384000
      GOTO ERROR;                                                       09386000
      END;                                                              09388000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>09390000
   DEBUG;                                                               09392000
   CRITFLAG := TRUE;                                           <<B0.00>>09394000
   GOTO NEXT;                                                           09396000
                                                                        09398000
<<*********************** E X I T **************************>> <<04145>>09400000
<< First check if we are a subtask.  Of so, check for errors>> <<04145>>09402000
<<**********************************************************>> <<04145>>09404000
                                                               <<04145>>09406000
EXITL:                                                                  09408000
      IF SUBTASK THEN                                          <<B0.00>>09410000
         BEGIN                                                 <<B0.00>>09412000
      CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;    <<B0.00>>09414000
         FATHERINFO := GETPROCINFO(0);                         <<B0.01>>09416000
         IF <> THEN GO TO QUITL; <<FATHER TERMINATED>>         <<B0.01>>09418000
         IF LOGICAL(FATHERINFO1) THEN GO TO QUITL;             <<B0.01>>09420000
                                      <<FATHER ACTIVE>>        <<B0.01>>09422000
           ACTIVATE(0,3);         <<FATHER>>                   <<B0.00>>09424000
         XCONTRAP(CYLABEL,CYOLD); <<REARM CONTROLY>>           <<B0.00>>09426000
      CRITFLAG := TRUE;                                        <<B0.00>>09428000
           GO TO NEXT;                                         <<B0.00>>09430000
         END;                                                  <<B0.00>>09432000
                                                               <<04145>>09434000
$PAGE                                                          <<04145>>09436000
   <<*******************************************************>> <<04145>>09438000
   << Close any texted spool files open and place back on   >> <<04145>>09440000
   << ready queue via SROOSTER.                             >> <<04145>>09442000
   <<*******************************************************>> <<04145>>09444000
                                                               <<04145>>09446000
   IF FILEN <> 0 THEN                                                   09448000
      BEGIN                                                             09450000
      TOS:=0;                                                  <<01.02>>09452000
      TOS:=XDDN;                                               <<01.02>>09454000
      ODDN:=FINDODD(*);                                        <<01.02>>09456000
      FSCLOSE(FILEN,0,0);                                               09458000
      IF < THEN                                                         09460000
         BEGIN                                                 <<04145>>09462000
           ERRN := 24;                                         <<04145>>09464000
           FCHECK(FILEN,ERRF);                                 <<04145>>09466000
           FILEN := 0;                                         <<04145>>09468000
           GOTO ERROR;                                         <<04145>>09470000
         END;                                                  <<04145>>09472000
      TOS:=ODDN;                                               <<01.02>>09474000
     SROOSTER(*); <<PLACE ODD BACK ON READY QUEUE>>            <<01.02>>09476000
      END;                                                              09478000
                                                               <<04145>>09480000
   <<*******************************************************>> <<04145>>09482000
   << Close any disk files that have been left open.        >> <<04145>>09484000
   <<*******************************************************>> <<04145>>09486000
                                                               <<04145>>09488000
   IF NEW'FILEN <> 0  THEN                                     <<B0.01>>09490000
      IF NOT NEW'FILE'CLOSE(FALSE) THEN                        <<B0.01>>09492000
         GO TO ERROR;                                          <<B0.01>>09494000
   GOTO FIN;                                                            09496000
                                                                        09498000
<<*****************E X P L A I N  I T ! ********************>> <<04145>>09500000
                                                               <<04145>>09502000
XPLAL:                                                                  09504000
   IF BP <> CR  THEN                                           <<04145>>09506000
      BEGIN ERRN := 33; GOTO ERROR; END;                                09508000
   EXPLAIN;                                                             09510000
   GOTO NEXT;                                                           09512000
                                                                        09514000
<<********************* S H O W ****************************>> <<04145>>09516000
<< Obtain file ID's, get XDD's and show them and any errors!>> <<04145>>09518000
<<**********************************************************>> <<04145>>09520000
                                                               <<04145>>09522000
SHOWL:                                                                  09524000
   IF NOT GETFILES(1) THEN GOTO ERROR;                                  09526000
   IF BP <> CR  THEN                                           <<04145>>09528000
      BEGIN ERRN := 33; GOTO ERROR; END;                                09530000
   IF MOVEFROMXDD                                              <<04145>>09532000
     THEN SHOWFILES;                                           <<04145>>09534000
   SHOWERRORS(TRUE);                                           <<04145>>09536000
   GOTO NEXT;                                                           09538000
$PAGE                                                          <<04145>>09540000
<<************************ T E X T *************************>> <<04145>>09542000
<< First close any previously texted files.                 >> <<04145>>09544000
<<**********************************************************>> <<04145>>09546000
                                                               <<04145>>09548000
TEXTL:                                                                  09550000
   IF FILEN <> 0 THEN                                                   09552000
      BEGIN                                                             09554000
      TOS:=0;                                                  <<01.02>>09556000
      TOS:=XDDN;                                               <<01.02>>09558000
      ODDN:=FINDODD(*);                                        <<01.02>>09560000
      FSCLOSE(FILEN,0,0);                                               09562000
      IF < THEN                                                         09564000
         BEGIN ERRN := 24; FCHECK(FILEN,ERRF); GOTO ERROR; END;         09566000
      TOS:=ODDN;                                               <<01.02>>09568000
      SROOSTER(*); <<PLACE ODD BACK ON READY QUEUE>>           <<01.02>>09570000
      FILEN := 0;                                                       09572000
      XDDN := 0;                                                        09574000
      DEVFN := 0;                                                       09576000
      IF BP = "*" AND BP(1) = CR  THEN GO TO NEXT;             <<04145>>09578000
      END;                                                              09580000
   DEVFC := 0;                                                          09582000
   IF NOT GETDEVF THEN GOTO ERROR;                                      09584000
   IF DEVF >= 0 THEN                                                    09586000
      BEGIN ERRN := 30; GOTO ERROR; END;                                09588000
   IF BP <> CR  THEN                                           <<04145>>09590000
      BEGIN ERRN := 33; GOTO ERROR; END;                                09592000
   IF NOT SPOOLOPEN(DEVF,FILEF) THEN GO TO ERROR;              <<B0.01>>09594000
  START'RECNUM := FLINE + 1D; <<INITIALIZE START'RECNUM>>   <<S<<01549>>09596000
   @BLOCKFP := @BLOCKCP := @BLOCKTABLE;                        <<B0.01>>09598000
   BLOCKNO := 0D;                                              <<B0.01>>09600000
   BLOCKFP := 0;                                               <<B0.01>>09602000
   MOVE BLOCKFP(1) := BLOCKFP, (BENTRIES*BENTRY'SIZE-1);       <<B0.01>>09604000
   FILEN := FILEF;                                                      09606000
   XDDN := XDDX;                                                        09608000
   DEVFN := DEVF;                                                       09610000
   FLINE := -1D;                                                        09612000
   FGETINFO(FILEN,,,,,,,,,,EOFLINE);                                    09614000
   EOFLINE := EOFLINE-1D;                                               09616000
   GOTO NEXT;                                                           09618000
$PAGE                                                          <<04145>>09620000
<<*********************** L I S T **************************>> <<04145>>09622000
<< Check for texted file, obtain List range, skan to the    >> <<04145>>09624000
<< range and list the file.                                 >> <<04145>>09626000
<<**********************************************************>> <<04145>>09628000
                                                               <<04145>>09630000
LISTL:                                                                  09632000
   IF FILEN = 0 THEN                                                    09634000
      BEGIN ERRN := 46; GOTO ERROR; END;                                09636000
   IF NOT LINERANGE(FALSE) THEN GOTO ERROR;                             09638000
   IF NOT SKANTOLINE(TRUE) THEN GOTO ERROR;                             09640000
   IF NOT LISTRANGE(FALSE) THEN GOTO ERROR;                             09642000
   GOTO NEXT;                                                           09644000
                                                                        09646000
<<******************** F I N D  I T ! **********************>> <<04145>>09648000
                                                               <<04145>>09650000
FINDL:                                                                  09654000
   IF FILEN = 0 THEN                                                    09656000
      BEGIN ERRN := 46; GOTO ERROR; END;                                09658000
   IF NOT FINDRANGE THEN GOTO ERROR;                                    09660000
   IF NOT SKANTOLINE(TRUE) THEN GOTO ERROR;                             09662000
   IF NOT LISTRANGE(TRUE) THEN GOTO ERROR;                              09664000
   GOTO NEXT;                                                           09666000
                                                                        09668000
MODEL:                                                                  09670000
   IF NOT GETMODE THEN GOTO ERROR;                                      09672000
   GOTO NEXT;                                                           09674000
                                                                        09676000
<<******************* A L T E R ****************************>> <<04145>>09678000
                                                               <<04145>>09680000
ALTEL:                                                                  09682000
   DEVFC := 0;                                                          09684000
   INITXDDP := -2048;                                          <<00897>>09686000
   IF NOT GETFILES(4) THEN GOTO ERROR;                         <<04145>>09688000
   IF BP <> ";" THEN                                           <<00897>>09690000
      BEGIN ERRN := 49; GOTO ERROR; END;                       <<00897>>09692000
   @BP := @BP+1;                                               <<00897>>09694000
   IF MOVEFROMXDD THEN                                         <<04145>>09696000
      BEGIN                                                    <<04145>>09698000
        IF NOT GETALTER THEN GOTO ERROR;                       <<04145>>09700000
        IF NOT ALTER'FILES THEN GO TO ERROR;                   <<04145>>09702000
        SHOWFILES;                                             <<04145>>09704000
      END;                                                     <<04145>>09706000
   SHOWERRORS(FALSE);                                          <<04145>>09708000
   GOTO NEXT;                                                           09710000
                                                                        09712000
$PAGE                                                          <<04145>>09714000
<<******************* P U R G E ****************************>> <<04145>>09716000
                                                               <<04145>>09718000
PURGL:                                                                  09720000
   IF NOT GETFILES(3) THEN                                     <<B0.00>>09722000
      IF NOT MPECOMMAND(BCBUF(2)) THEN                         <<B0.00>>09724000
         GO TO ERROR                                           <<B0.00>>09726000
      ELSE GO TO NEXT;                                         <<B0.00>>09728000
   IF BP <> CR  THEN                                           <<04145>>09730000
      BEGIN ERRN := 33; GOTO ERROR; END;                                09732000
   IF MOVEFROMXDD                                              <<04145>>09734000
   THEN PURGEFILES;                                            <<04145>>09736000
   SHOWERRORS(FALSE);                                          <<04145>>09738000
   GOTO NEXT;                                                           09740000
                                                                        09742000
<<******************* I N P U T ****************************>> <<04145>>09744000
<<  First check for SM capabilities.  Get the Input files   >> <<04145>>09746000
<<  list.  Open the input tape file.  Build the tape direc- >> <<04145>>09748000
<<  tory and input the files.  Lastly, close the tape file  >> <<04145>>09750000
<<  and check for errors.                                   >> <<04145>>09752000
<<**********************************************************>> <<04145>>09754000
                                                               <<04145>>09756000
INL:                                                                    09758000
   IF NOT CAP1.(0:1) THEN                                               09760000
      BEGIN ERRN := 20;WARN := 4;GOTO ERROR; END;                       09762000
   INITXDDP := -2048;                                                   09764000
   IF NOT GETFILES(0) THEN GOTO ERROR;                                  09766000
   IF BP <> ";" THEN                                                    09768000
      BEGIN ERRN := 49; GOTO ERROR; END;                                09770000
   @BP := @BP+1;                                                        09772000
   IF NOT OPENTAPE(0) THEN GOTO ERROR;                                  09774000
   IF NOT INDIRECTORY THEN GOTO ERROR;                                  09776000
   IF NOT INFILES THEN GOTO ERROR;                                      09778000
   SHOWERRORS(FALSE);                                          <<04145>>09780000
   FCLOSE(FILET,1,0);                                          <<02724>>09782000
   IF < THEN                                                            09784000
      BEGIN ERRN := 51; FCHECK(FILET,ERRF); GOTO ERROR; END;            09786000
   FILET := 0;                                                          09788000
   GOTO NEXT;                                                           09790000
                                                                        09792000
$PAGE                                                          <<04145>>09794000
<<********************* O U T P U T ************************>> <<04145>>09796000
<< Check for SM capabilities.  Get the files for output.    >> <<04145>>09798000
<<**********************************************************>> <<04145>>09800000
                                                               <<04145>>09802000
OUTL:                                                                   09804000
   IF NOT CAP1.(0:1) THEN                                               09806000
      BEGIN ERRN := 20;WARN := 4;GOTO ERROR; END;                       09808000
   INITXDDP := -2048;                                                   09810000
   IF NOT GETFILES(2) THEN GOTO ERROR;                                  09812000
   IF BP <> ";" THEN                                                    09814000
      BEGIN ERRN := 49; GOTO ERROR; END;                                09816000
                                                               <<04145>>09818000
   <<*******************************************************>> <<04145>>09820000
   << If there are any files to output found by GETFILES,   >> <<04145>>09822000
   << then open the tape file, check for the PURGE option   >> <<04145>>09824000
   << and output the files.  Last, show any error encountred>> <<04145>>09826000
   <<*******************************************************>> <<04145>>09828000
                                                               <<04145>>09830000
   IF MOVEFROMXDD THEN                                         <<04145>>09832000
      BEGIN                                                    <<04145>>09834000
        @BP := @BP+1;                                          <<04145>>09836000
        IF NOT OPENTAPE(1) THEN GOTO ERROR;                    <<04145>>09838000
        PURGEFLAG := FALSE;                                    <<04145>>09840000
        SCAN BP UNTIL %6473,1;  <<CR, ; >>                     <<04145>>09842000
        @BP := TOS  ;                                          <<04145>>09844000
        IF NOCARRY THEN                                        <<04145>>09846000
           IF BP(1) = "PURGE" THEN                             <<04145>>09848000
              PURGEFLAG := TRUE                                <<04145>>09850000
           ELSE                                                <<04145>>09852000
              BEGIN                                            <<04145>>09854000
              FCLOSE(FILET,1,0);                               <<04145>>09856000
              FILET := 0;                                      <<04145>>09858000
              ERRN := 33; GO TO ERROR; END;                    <<04145>>09860000
                                                               <<04145>>09862000
        IF NOT OUTDIRECTORY THEN GOTO ERROR;                   <<04145>>09864000
        IF NOT OUTFILES THEN GOTO ERROR;                       <<04145>>09866000
      END;                                                     <<04145>>09868000
   PURGEFLAG := FALSE;                                        <<00204>> 09870000
   SHOWERRORS(FALSE);                                          <<04145>>09872000
                                                               <<04145>>09874000
   <<Close the tape file                                    >> <<04145>>09876000
                                                               <<04145>>09878000
   IF FILET <> 0 THEN                                          <<04145>>09880000
      BEGIN                                                    <<04145>>09882000
        FCLOSE(FILET,1,0);                                     <<04145>>09884000
        IF < THEN                                              <<04145>>09886000
           BEGIN                                               <<04145>>09888000
             ERRN := 51;                                       <<04145>>09890000
             FCHECK(FILET,ERRF);                               <<04145>>09892000
             GOTO ERROR;                                       <<04145>>09894000
           END;                                                <<04145>>09896000
        FILET := 0;                                            <<04145>>09898000
      END;                                                     <<04145>>09900000
   GOTO NEXT;                                                           09902000
                                                               <<01.02>>09904000
$PAGE                                                          <<04145>>09906000
<<************************ H E L P ! ***********************>> <<04145>>09908000
<< Check if MPE help facility has been requested and call   >> <<04145>>09910000
<< via MPECOMMAND.                                          >> <<04145>>09912000
<<**********************************************************>> <<04145>>09914000
                                                               <<04145>>09916000
HELPL:                                                         <<B0.00>>09918000
   IF BP = CR  THEN                                            <<04145>>09920000
   GO TO XPLAL;                                                <<B0.00>>09922000
   IF BP = "MPE" THEN                                          <<B0.00>>09924000
      BEGIN                                                    <<B0.00>>09926000
      SCAN BP(3) WHILE %6440;                                  <<B0.00>>09928000
      IF CARRY THEN                                            <<B0.00>>09930000
         BP := CR ;                                            <<04145>>09932000
      END;                                                     <<B0.00>>09934000
   MPECOMMAND(BCBUF(2));                                       <<B0.00>>09936000
   IF BP=CR  AND BP(1) ="PE" THEN                              <<04145>>09938000
      GO TO SPOOK'TITLE                                                 09940000
   ELSE                                                                 09942000
     GO TO NEXT;                                                        09944000
                                                                        09946000
<<************************** R U N *************************>> <<04145>>09948000
<< Run a user program via ATTACH.  If failed, than either   >> <<04145>>09950000
<< capabilty is illegal or program is invalid.              >> <<04145>>09952000
<<**********************************************************>> <<04145>>09954000
                                                               <<04145>>09956000
RUNL:                                                          <<B0.00>>09958000
         PROGNAME(26):=" ";                                    <<B0.00>>09960000
         MOVE PROGNAME:=BP,(26);                               <<B0.00>>09962000
         SCAN PROGNAME UNTIL %6440,1;                          <<B0.00>>09964000
         MOVE * := " ";                                        <<B0.00>>09966000
         IF PROGNAME = " " THEN                                <<B0.00>>09968000
            BEGIN                                              <<B0.00>>09970000
            ERRN := 72; GO TO ERROR; <<MISSING OPERAND>>       <<B0.00>>09972000
            END;                                               <<B0.00>>09974000
         IF PROGNAME = "*" THEN                                <<B0.00>>09976000
            MOVE PROGNAME := LASTCREATE,(27);                  <<B0.00>>09978000
         IF NOT ATTACH(PROGNAME,PIN) THEN                      <<B0.00>>09980000
           BEGIN                                               <<04145>>09982000
            IF NOT CAP2.(15:1) THEN                            <<04145>>09984000
               BEGIN                                           <<04145>>09986000
                 ERRN := 20;                                   <<04145>>09988000
                 WARN := 4;                                    <<04145>>09990000
                 GO TO ERROR;                                  <<04145>>09992000
               END                                             <<04145>>09994000
            ELSE                                               <<04145>>09996000
               BEGIN                                           <<04145>>09998000
                 ERRN := 70;                                   <<04145>>10000000
                 GO TO ERROR;                                  <<04145>>10002000
               END;                                            <<04145>>10004000
           END                                                 <<04145>>10006000
         ELSE BEGIN                                            <<04145>>10008000
              MOVE CBUF := PTITLE,2;                           <<04145>>10010000
              I := TOS - @CBUF;                                <<04145>>10012000
        MOVE BCBUF(VUUFF'COL) := OFFICIAL'VUUFF;               <<04151>>10014000
              PRINT(CBUF,I,0);                                 <<04145>>10016000
            END;                                               <<04145>>10018000
      GO TO NEXT;                                              <<B0.00>>10020000
                                                               <<B0.00>>10022000
<<************************* K I L L ! **********************>> <<04145>>10024000
<< Check if any programs being run and kill the last pin    >> <<04145>>10026000
<< number via KILL.                                         >> <<04145>>10028000
<<**********************************************************>> <<04145>>10030000
                                                               <<04145>>10032000
KILLL:                                                         <<B0.00>>10034000
   IF LASTPIN = 0 THEN                                         <<B0.00>>10036000
      BEGIN                                                    <<B0.00>>10038000
         ERRN :=71; GO TO ERROR;                               <<B0.00>>10040000
      END                                                      <<B0.00>>10042000
   ELSE                                                        <<B0.00>>10044000
      BEGIN                                                    <<B0.00>>10046000
      KILL(LASTPIN);                                           <<B0.00>>10048000
      LASTPIN := 0; LASTCREATE := 0;                           <<B0.00>>10050000
      END;                                                     <<B0.00>>10052000
   GO TO NEXT;                                                 <<B0.00>>10054000
                                                               <<B0.00>>10056000
<<********************** I  Q U I T ! **********************>> <<04145>>10058000
                                                               <<04145>>10060000
QUITL:                                                         <<B0.00>>10062000
   <<  TERMINATE SUBTASK>>                                     <<B0.00>>10064000
                                                               <<B0.00>>10066000
   SUBTASK := FALSE;                                           <<B0.00>>10068000
   GO TO EXITL;                                                <<B0.00>>10070000
                                                               <<B0.00>>10072000
$PAGE                                                          <<04145>>10074000
<<********************** C O P Y ***************************>> <<04145>>10076000
<< If a file was specified, then obtain the list of files   >> <<04145>>10078000
<< via GETFILES.  Move the ODD entries in.  If no files were>> <<04145>>10080000
<< specified, copy the texted file if one is texted.  If no >> <<04145>>10082000
<< copy file was specified, create another spoolfile exactly>> <<04145>>10084000
<< like the original and copy the contents of the spoolfiles>> <<04145>>10086000
<< specified into it.                                       >> <<04145>>10088000
<<**********************************************************>> <<04145>>10090000
                                                               <<04145>>10092000
COPYL:                                                         <<B0.01>>10094000
   IF BP = "END" THEN                                          <<B0.01>>10096000
     BEGIN                                                     <<B0.01>>10098000
     APPEND := FALSE;                                          <<B0.01>>10100000
      IF NEW'FILEN = 0 THEN GO TO NEXT                         <<B0.01>>10102000
      ELSE                                                     <<B0.01>>10104000
         BEGIN                                                 <<B0.01>>10106000
         IF NOT NEW'FILE'CLOSE(FALSE) THEN GO TO ERROR;        <<B0.01>>10108000
         GO TO NEXT;                                           <<B0.01>>10110000
         END;                                                  <<00897>>10112000
      END;                                                     <<00897>>10114000
   COPY'FILES'FLAG := FALSE; @FIRSTPARM := @BP;                <<00897>>10116000
   INITXDDP := -2048;                                          <<00897>>10118000
   SCAN BP UNTIL %6473;                                        <<04329>>10120000
   IF NOCARRY THEN   << CR ";">>                               <<04329>>10122000
      BEGIN                                                    <<04329>>10124000
      IF NOT GETFILES(2) THEN GO TO ERROR;                     <<00897>>10126000
      IF BP <> ";" THEN                                        <<00897>>10128000
      BEGIN ERRN := 49; GO TO ERROR ; END;                     <<00897>>10130000
      @BP := @BP + 1;                                          <<00897>>10132000
      MOVEFROMXDD;                                             <<00897>>10134000
      COPY'FILES'FLAG := TRUE; @SECONDPARM := @BP;             <<00897>>10136000
      END                                                      <<04329>>10138000
   ELSE                                                        <<00897>>10140000
      IF FILEN = 0 THEN                                        <<04329>>10142000
         BEGIN                                                 <<04329>>10144000
         ERRN := 46;               << No text file          >> <<04329>>10146000
         GO TO ERROR;              << Aren't GO TO's ugly?  >> <<04329>>10148000
         END                                                   <<04329>>10150000
      ELSE                                                     <<04329>>10152000
        FILE'FOUND := TRUE;        << File exists.          >> <<04329>>10154000
                                                               <<04329>>10156000
   IF NOT COPY'FILES'FLAG THEN                                 <<00897>>10158000
   BEGIN                                                       <<00897>>10160000
      XDDC := 1;                                               <<00897>>10162000
      @BP := @FIRSTPARM;                                       <<00897>>10164000
      @SECONDPARM := @FIRSTPARM;                               <<00897>>10166000
   END;                                                        <<00897>>10168000
                                                               <<04145>>10170000
   <<*******************************************************>> <<04145>>10172000
   << Copy the files via COPY'FILES and show any error that >> <<04145>>10174000
   << occured via SHOWERRORS.                               >> <<04145>>10176000
   <<*******************************************************>> <<04145>>10178000
                                                               <<04145>>10180000
   IF FILE'FOUND THEN                                          <<04145>>10182000
      IF NOT COPY'FILES THEN GO TO ERROR;                      <<04145>>10184000
   APPEND:= FALSE;                                             <<B0.01>>10186000
   IF COPY'FILES'FLAG                                          <<04329>>10188000
      THEN SHOWERRORS(FALSE);                                  <<04329>>10190000
   COPY'FILES'FLAG := FALSE;                                   <<04329>>10192000
   GO TO NEXT;                                                 <<B0.01>>10194000
                                                               <<B0.01>>10196000
                                                               <<B0.01>>10198000
APPENDL:                                                       <<B0.01>>10200000
   APPEND := TRUE;                                             <<B0.01>>10202000
   GO TO COPYL;                                                <<B0.01>>10204000
                                                                        10206000
                                                                        10208000
FIN:                                                                    10210000
   XCONTRAP(CYOLD,CYLABEL);                                             10212000
   CRITFLAG := FALSE; IF CONTROLYFLAG THEN CONTROLYPROC;       <<B0.00>>10214000
                                                                        10216000
                                                                        10218000
END.                                                                    10220000
