$CONTROL USLINIT,MAP,CODE,SOURCE                                        00010000
<< STORE/RESTORE -- MODULE 52 >>                                        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 MAIN=STORE'RESTORE                                             00028000
$THIRTY                                                                 00030000
$CONTROL PRIVILEGED                                                     00032000
<< New labeled tape code >>                                    <<02546>>00034000
$PAGE "GLOBAL DECLARATIONS"                                             00036000
 BEGIN     <<  DEC 31,1974     SOURCE  S52   >>                         00038000
$PAGE "PATCH MNEMONICS & EXPLANATIONS"                         <<04658>>00040000
                                                               <<04658>>00042000
<<Add CXSTORENEW procedure to module...called by CI.        >> <<04658>>00044000
                                                              <<00.GEN>>00046000
                                                              <<00.GEN>>00048000
<<  P R O D U C E P A R M S   D E F I N I T I O N S  >>       <<00.GEN>>00050000
                                                              <<00.GEN>>00052000
DEFINE D'INX=      DPPRESULT #,        <<"PPRESULT" FMT>>     <<00.GEN>>00054000
       D'INX1=     PPRESULT #,                                <<00.GEN>>00056000
       D'INX2=     PPRESULT(1) #,                             <<00.GEN>>00058000
       D'TYPE=     PPRESULT(2) #,                             <<00.GEN>>00060000
       D'FNAME=    PPRESULT(3) #,                             <<00.GEN>>00062000
       D'VNAME=    PPRESULT(3) #,                             <<00.GEN>>00064000
       D'GNAME=    PPRESULT(7) #,                             <<00.GEN>>00066000
       D'UNAME=    PPRESULT(7) #,                             <<00.GEN>>00068000
       D'ANAME=    PPRESULT(11) #,                            <<00.GEN>>00070000
       D'LOCKWORD= PPRESULT(15) #,                            <<00.GEN>>00072000
       G'FNAME=    PPRESULT(19) #,                            <<00.GEN>>00074000
       G'VNAME=    PPRESULT(19) #,                            <<00.GEN>>00076000
       G'GNAME=    PPRESULT(23) #,                            <<00.GEN>>00078000
       G'UNAME=    PPRESULT(23) #,                            <<00.GEN>>00080000
       G'ANAME=    PPRESULT(27) #,                            <<00.GEN>>00082000
       D'BFNAME=    BPPRESULT(6) #,                           <<00.GEN>>00084000
       D'BVNAME=    BPPRESULT(6) #,                           <<00.GEN>>00086000
       D'BGNAME=    BPPRESULT(14) #,                          <<00.GEN>>00088000
       D'BUNAME=    BPPRESULT(14) #,                          <<00.GEN>>00090000
       D'BANAME=    BPPRESULT(22) #,                          <<00.GEN>>00092000
       D'BLOCKWORD= BPPRESULT(30) #,                          <<00.GEN>>00094000
       G'BFNAME=    BPPRESULT(38) #,                          <<00.GEN>>00096000
       G'BVNAME=    BPPRESULT(38) #,                          <<00.GEN>>00098000
       G'BGNAME=    BPPRESULT(46) #,                          <<00.GEN>>00100000
       G'BUNAME=    BPPRESULT(46) #,                          <<00.GEN>>00102000
       G'BANAME=    BPPRESULT(54) #;                          <<00.GEN>>00104000
                                                              <<00.GEN>>00106000
  <<LENGTH OF "DIRECSCAN" RECIP PARAMETER  >>                 <<00.GEN>>00108000
  <<AND OFFSET THEREIN TO "PPRESULT" AT END>>                 <<00.GEN>>00110000
  <<OF PARAMETER TO FACILITATE EXTENSIONS  >>                 <<00.GEN>>00112000
                                                              <<00.GEN>>00114000
EQUATE PPR'LEN=    31,                 <<"PPRESULT" SIZE>>   <<04FEB77>>00116000
       ST'PARMLEN= 59+PPR'LEN,         <<FOR "ISTORE">>       <<00.GEN>>00118000
       ST'PPRINX=  ST'PARMLEN-PPR'LEN;                        <<00.GEN>>00120000
                                                              <<00.GEN>>00122000
DEFINE STARTLEVELF= 13:3 #,                                   <<00.GEN>>00124000
       ENDLEVELF=   10:3 #,                                   <<00.GEN>>00126000
       ENDLEVELFX=   9:4 #,                                   <<00.GEN>>00128000
       ALLFLAG=      9:1 #,                                   <<00.GEN>>00130000
       TOLEVELF=     6:3 #,                                   <<00.GEN>>00132000
       HITFLAG=      5:1 #;                                   <<00.GEN>>00134000
                                                              <<00.GEN>>00136000
                                                                        00138000
   DEFINE HDRLBL=TRAILBL#,                                              00140000
          LABELTEXT="STORE/RESTORE LABEL-HP/3000."#,                    00142000
          IIBID    = HDRLBL (14) <<& (15)>> #,                          00144000
          SPANTOG  = HDRLBL (16) #,                                     00146000
          CHKSUM   = HDRLBL (17) #,                                     00148000
          FFILEINX = HDRLBL (18) #,                                     00150000
          XFIELD=TRAILBL(21)#,                                          00152000
          ZFIELD=TRAILBL(22)#,                                          00154000
          REELNUM=TRAILBL(23)#,                                         00156000
          CHDATE=TRAILBL(24)#,                                          00158000
          CHHHMM=TRAILBL(25)#,                                          00160000
      CHSSTT=TRAILBL(26)#,                                     <<00425>>00162000
      TAPEBLOCKSIZE=TRAILBL(27)#;<<SIZE OF STORE BLOCKS>>      <<00425>>00164000
   EQUATE TREAD =0,                                            <<02518>>00166000
          TWRITE=1,                                            <<02518>>00168000
          WEOF  =6,                                            <<02518>>00170000
          FSF=7,                                                        00172000
          BSF=8,                                                        00174000
          REWIND=5,                                                     00176000
          REWUNLOAD=9;                                                  00178000
   EQUATE LRECLTD=12;       << LRECL OF TAPE DIRECTORY >>               00180000
   EQUATE                                                      <<02558>>00184000
      NUMBUFF    =   2,    << Number of disc buffers >>        <<02558>>00186000
      DEN'OPTION =  46,    << FFILEINFO option for DENSITY >>  <<02558>>00192000
      DEVVIOL    =  42,    << Device violation, FSERR >>       <<02558>>00194000
      MAGTAPE    =  24,    << Device type for mag tapes >>     <<02558>>00196000
      SUBTYP7970 =   0,       << Subtype for HP7970 >>         <<02558>>00198000
      SUBTYP7976 =   1,       << Subtype for HP7976 >>         <<02558>>00200000
      SDISC      =  31,    << Device type for serial disc >>   <<02558>>00202000
      TYPE7970   = %30,    << Subtype/type from DEVTYPE >>     <<02558>>00204000
      TYPE7976   = %430;   << Subtype/type from DEVTYPE >>     <<02558>>00206000
   DEFINE                                                      <<02558>>00208000
      DTYPE     = (8:8)#,  << DEVTYPE field for device type >> <<02558>>00210000
      STYPE     = (0:8)#,  << DEVTYPE field for subtype >>     <<02558>>00212000
      T'SUBTYPE = (5:3)#,  << DEVTYPE field for tape subtype >><<02558>>00214000
      TAPE'TYPE = (5:11)#, << Field for tape subtype/type >>   <<02558>>00216000
                                                               <<02558>>00218000
      << Defines used by STORE/RESTORE to determine which >>   <<02558>>00220000
      << algorithm, ATTACHIO or FILESYS, to use for >>         <<02558>>00222000
      << data transfers to/from the device. >>                 <<02558>>00224000
                                                               <<02558>>00226000
      USING'ATTIO   = (DEVTYPE.TAPE'TYPE = TYPE7976) AND       <<02558>>00228000
               NOT VIRTDEV AND NOT LABELED AND NOT SPEC'ENTRY#,<<02871>>00230000
      USING'FILESYS = ( (DEVTYPE.TAPE'TYPE <> TYPE7976)  OR    <<02558>>00232000
                        VIRTDEV OR LABELED OR SPEC'ENTRY ) #;  <<02871>>00234000
                                                               <<02558>>00236000
   DEFINE                                                      <<02558>>00238000
      RECSIZE'FLAG  = (1:1)#;  << FEQ option bit for recsize >><<02558>>00240000
                                                               <<02518>>00244000
  DEFINE SETXPXFIXED = PUSH(DL);                               <<U.RAO>>00246000
         X := TOS-PS0(-2)#;   <<SET X TO POINT TO PXFIXED AREA><<U.RAO>>00248000
  EQUATE PXFWCONT = 33;  <<OFFSET IN PXFIXED OF CONTINUE FLAG>><<U.RAO>>00250000
EQUATE NAVAILDEV = 55;     << device not available >>          <<02546>>00252000
EQUATE LBTEOVSET = 123;    << end of volumeset >>              <<02546>>00254000
INTRINSIC FREADLABEL,FWRITELABEL;                              <<02546>>00256000
DEFINE LABELED=FOPTIONS.(6:1)#;    << labeled tape >>          <<02546>>00258000
DEFINE VIRTDEV = (LDEV.(0:8)<>0)#;  << Virtual Device >>       <<02625>>00260000
   DEFINE   << FILE LABEL DEFINITION >>                                 00262000
                                                                        00264000
      CHECKSUM    =                                                     00266000
          X := 127;                                                     00268000
          TOS := -1;                                                    00270000
          DO BEGIN                                                      00272000
                 IF X <> FLCHECKSUMX THEN                               00274000
                  IF X <> FLMISCX THEN                                  00276000
                   IF X <> FLCLIDX THEN                                 00278000
                    TOS := TOS XOR LOGICAL (FLAB (X));                  00280000
                 X:=X-1;                                                00282000
             END UNTIL <                                                00284000
                  #,                                                    00286000
      FLMISCX     =28#,             <<MISC WORD INDEX>>                 00288000
      FLCHECKSUMX =34#,             <<CHECKSUM INDEX>>                  00290000
      FLCLIDX     =35#,             <<COLD LOAD INDEX>>                 00292000
      FLLOCNAME   =FLAB( 0)#,       << LOCAL FILE NAME >>               00294000
      FLGRPNAME   =FLAB( 4)#,       << GROUP NAME >>                    00296000
      FLACCTNAME  =FLAB( 8)#,       << ACCOUNT NAME >>                  00298000
      FLUSERID    =FLAB(12)#,       << CREATING USERID >>               00300000
      FLLOCKWORD  =FLAB(16)#,       << LOCKWORD >>                      00302000
      FLSECMX     =FLABDBL(10)#,    <<SECURITY MATRIX>>                 00304000
      FLSECURE    =FLAB(22).(15:1)#, <<SECURITY IN FORCE>>              00306000
      FLCREATE    =FLAB(23)#,       << CREATION DATE >>                 00308000
      FLLASTACC   =FLAB(24)#,       << LAST ACCESS DATE >>              00310000
      FLLASTMOD   =FLAB(25)#,       << LAST MODIFICATION DATE >>        00312000
      FLFILECODE  =FLAB(26)#,       << FILE CODE >>                     00314000
      FLFCBVECT   =FLAB(27)#,       << FCB VECTOR >>                    00316000
      FLSTORE     =FLAB(28).(0:1)#, <<FILE BEGIN STORED>>               00318000
      FLRESTORE   =FLAB(28).(0:2)#, <<FILE BEING RESTORED>>             00320000
      FLLOADED    =FLAB(28).(2:1)#, <<FILE IS LOADED>>                  00322000
      FLDEVTYPE   =FLAB(28).(8:6)#, <<DEVICE TYPE>>                     00324000
      FLDEVSUBTYPE=FLAB(28).(4:4)#, <<DEVICE SUBTYPE>>                  00326000
      FLWRITE     =FLAB(28).(14:1)#,<<FILE OPEN FOR WRITING>>           00328000
      FLREAD      =FLAB(28).(15:1)#,<<FILE OPEN FOR READING>>           00330000
      FLRW        =FLAB(28).(14:2)#,<<FILE OPEN>>                       00332000
      FLFLIM      =FLABDBL(15)#,    << FILE LIMIT >>                    00334000
      FLCHECKSUM  =FLAB (34)#,      <<CHECKSUM>>                        00336000
      FLCLID      =FLAB(35)#,       << COLD LOAD ID >>                  00338000
      FLFOPTIONS  =FLAB(36)#,       << FOPTIONS >>                      00340000
      FLRECSIZE   =FLAB(37)#,       << RECORD SIZE >>                   00342000
      FLBLKSIZE   =FLAB(38)#,       << BLOCK SIZE >>                    00344000
      FLSECTOFF   =FLAB(39).(0:8)#, << SECTOR OFFSET >>                 00346000
      FLDFLAGS    =FLAB(39).(8:4)#, << DISK FLAGS >>                    00348000
      FLNUMEXTS   =FLAB(39).(11:5)#,<< NUMBER OF EXTENTS >>             00350000
      FLLASTEXTSIZE=FLAB(40)#,      <<LAST EXTENT SIZE >>               00352000
      FLEXTSIZE   =FLAB(41)#,       << EXTENT SIZE >>                   00354000
      FLEOF       =FLABDBL(21)#,    << END-OF-DATA POINTER >>           00356000
      FLEXTMAP    =FLAB(44)#,       << ORIGIN OF EXTENT MAP >>          00358000
FLALLOCTIME=FLABDBL(54)#, <<ALLOCATE FILE TIME>>               <<00633>>00360000
FLALLOCDATE=FLAB(110)#,    <<ALLOCATE FILE DATE>>              <<00633>>00362000
                                                               <<00633>>00364000
      FLCLASS     =FLAB(124)#,       <<CLASS NAME IN ASCII>>            00366000
      FLEXTMAPD   =FLABDBL(22)#;                                        00368000
                                                                        00370000
<<GROUP ENTRY>>                                                <<28.PV>>00372000
EQUATE                                                         <<28.PV>>00374000
   NAMESIZE        = 4,                                        <<28.PV>>00376000
   GNAME           = 0,                  <<NAME>>              <<28.PV>>00378000
   GFIPNTR         = GNAME+NAMESIZE,     <<FILE INDEX PNTR>>   <<28.PV>>00380000
   GPASS           = GFIPNTR+1,          <<PASSWORD>>          <<28.PV>>00382000
   GDFSCOUNT       = GPASS+NAMESIZE,     <<DISC FILE SPACE>>   <<28.PV>>00384000
   GDFSLIMIT       = GDFSCOUNT+2,                              <<28.PV>>00386000
   GCPUCOUNT       = GDFSLIMIT+2,        <<CPU TIME>>          <<28.PV>>00388000
   GCPULIMIT       = GCPUCOUNT+2,                              <<28.PV>>00390000
   GCONTIMECOUNT   = GCPULIMIT+2,                              <<28.PV>>00392000
   GCONTIMELIMIT   = GCONTIMECOUNT+2,                          <<28.PV>>00394000
   GSEC            = GCONTIMELIMIT+2,                          <<28.PV>>00396000
   GPURGEFLAGW     = GSEC,                                     <<28.PV>>00398000
   GCAP            = GSEC +2,                                  <<28.PV>>00400000
   GLINKAGE        = GCAP+1,                                   <<28.PV>>00402000
   GVSDIPNTR       = GLINKAGE+1,         <<VS DEF INDEX PNTR>> <<28.PV>>00404000
   GHVSNAME        = GVSDIPNTR+1,        <<HOME VS NAME>>      <<28.PV>>00406000
   GHVSANAME       = GHVSNAME,           << "   "  ACCT NAME>> <<28.PV>>00408000
   GHVSGNAME       = GHVSANAME+NAMESIZE, << "   "  GRP  NAME>> <<28.PV>>00410000
   GHVSVSNAME      = GHVSGNAME+NAMESIZE, << "   "  VS   NAME>> <<28.PV>>00412000
   GSAVEFIPNTR     = GHVSVSNAME+NAMESIZE,<<SAVES GFIPNTR>>     <<28.PV>>00414000
   GMOUNTREFCNTR   = GSAVEFIPNTR+1,      <<MOUNT USE COUNTER>> <<28.PV>>00416000
   GSPARE          = GMOUNTREFCNTR+1,                          <<28.PV>>00418000
   GSIZE           = GSPARE+1;                                 <<28.PV>>00420000
<<GLINKAGE DEFINITIONS>>                                       <<28.PV>>00422000
DEFINE                                                         <<28.PV>>00424000
   PVF             = 0:1 #,                                    <<28.PV>>00426000
   MVTABXF         = 8:8 #;                                    <<28.PV>>00428000
EQUATE                                                         <<28.PV>>00430000
   PV              = 1,                                        <<28.PV>>00432000
   VMAX            = 8;                  <<VOL MEMBERSHIP MAX>><<28.PV>>00434000
                                                               <<28.PV>>00436000
   INTEGER X=X,S0=S-0,S1=S-1;                                  <<RV.PV>>00438000
   DOUBLE DS5=S-5;                                                      00440000
   DOUBLE POINTER DPS3=S-3,DPS5=S-5;                                    00442000
   BYTE POINTER BPS0=S-0,BPS1=S-1;                                      00444000
   INTEGER POINTER PS0=S-0;                                             00446000
   INTEGER ARRAY DB2(*)=DB+2,DB6(*)=DB+6;                               00448000
   INTEGER ARRAY DB0(*) = DB+0;                                <<U.RAO>>00450000
   DOUBLE ARRAY DBDARRAY(*)=DB+0;                                       00452000
   INTEGER POINTER LPDT'=%10;                                           00454000
   EQUATE COLDLOADIDN=%1075;                                            00456000
EQUATE FISIR = 37,                                             <<00482>>00458000
       CCG=0, CCL=1, CCE=2;                                    <<00482>>00460000
DEFINE CC = STAT.(6:2)#;                                       <<00482>>00464000
   INTEGER STAT = Q-1;                                         <<00482>>00466000
EQUATE   <<CI ERROR MESSAGE EQUATES>>                          <<U.RAO>>00468000
   SUBSNOTFOUND    = 641,  <<SUBSYSTEM NOT FOUND>>             <<04658>>00470000
   SUBSNOTCREATE   = 660,  <<CREATEPROCESS FAILED ON SUBSYS>>  <<04658>>00472000
   STORTAPEFSERR   = 1000,  <<ERROR WRITING TO TAPE>>          <<U.RAO>>00474000
   STORTAPEMBEDSPC = 1001,  <<EMBEDDED SPECIAL IN TAPE ID>>    <<U.RAO>>00476000
   STORTAPXPCTALPH = 1002,  <<NEED ALPHA TO START NAME>>       <<U.RAO>>00478000
   STORTAPNAME2LNG = 1003,  <<NAME > 8 CHARACTERS>>            <<U.RAO>>00480000
   STORXPCTBREFTAP = 1004,  <<EXPECTED "*">>                   <<U.RAO>>00482000
   STORREQTAPEFILE = 1005,  <<NAME MISSING>>                   <<U.RAO>>00484000
   STORXPCTSEMIC   = 1006,  <<ILLEGAL DELIMITER>>              <<U.RAO>>00486000
   STORREDUNDFILES = 1007,  <<REDUNDANT "FILES=">>             <<U.RAO>>00488000
   STORXPCTEQFILES = 1008,  <<NEED = BEFORE FILE COUNT>>       <<U.RAO>>00490000
   STORXPCTFILECNT = 1009,  <<EXPECTED VALUE AFTER "FILES=">>  <<U.RAO>>00492000
   STORUNKOPTION   = 1010,  <<UNKNOWN KEYWORD>>                <<U.RAO>>00494000
   STOR2MP         = 1011,  <<TOO MANY PARMS FOR CXSTORE>>     <<U.RAO>>00496000
   STOR'XPCT'TAPE  = 1012,  <<REQUIRES TAPE FILE NAME>>        <<U.RAO>>00498000
   STORUNXPCTEQFST = 1013,  <<UNEXPECTED = IN FILESET NAME>>   <<U.RAO>>00500000
   STORBADSYSLIST  = 1014,  <<UNABLE TO OPEN LIST FILE>>       <<U.RAO>>00502000
   STORINSUFSTACK  = 1015,  <<INSUFFICIENT STACK FOR STORE>>   <<U.RAO>>00504000
   STORTFILFOPTION = 1016,  <<BAD FOPTIONS ON TAPE>>           <<U.RAO>>00506000
   STORTFILAOPTION = 1017,  <<BAD AOPTIONS ON TAPE>>           <<U.RAO>>00508000
   STORXPCTTAPEDEV = 1018,  <<NOT A TAPE FILE>>                <<U.RAO>>00510000
   STORSCRFLFSERR  = 1019,  <<FSYS ERR ON SCRATCH FILE>>       <<U.RAO>>00512000
   STOR'ATTIO'FAIL = 1020,  <<ATTACHIO ON FILE LABEL FAILED>>  <<U.RAO>>00514000
   STORBREAK       = 1021,  <<BREAK WHILE DOING STORE>>        <<U.RAO>>00516000
   STORFSETUNKDEL  = 1022,  <<UNKNOWN DELIMITER IN FILESET>>   <<U.RAO>>00518000
   RSTORSCRFLFSERR = 1025,  <<SCRATCH FILE ERROR>>             <<U.RAO>>00520000
   RSTOR'TFL'FSERR = 1026,  <<TAPE FILE ERROR>>                <<U.RAO>>00522000
   RSTORPRTFLFSERR = 1027,  <<PRINT FILE ERROR>>               <<U.RAO>>00524000
   RSTORDISCIO     = 1028,  <<DISC I/O ERROR>>                 <<U.RAO>>00526000
   RSTORDIRERR     = 1029,  <<DIRECTORY PROBLEM>>              <<U.RAO>>00528000
   RSTORNOVIRTDEV  = 1030,  <<VIRTUAL DEVICE SPECIFIED>>       <<U.RAO>>00530000
   RSTORINVDEVCLS  = 1031,  <<INVALID DEV CLASS NAME>>         <<U.RAO>>00532000
   RSTORUNKDEVCLS  = 1032,  <<UNKNOWN DEVICE CLASS>>           <<U.RAO>>00534000
   RSTORUNKLDEV    = 1033,  <<UNKNOWN LOGICAL DEVICE>>         <<U.RAO>>00536000
   RSTORDEVNOTDISC = 1034,  <<MUST BE DISC DEVICE>>            <<U.RAO>>00538000
   RSTORNOTSTORTAP = 1035,  <<NOT A STORE TAPE>>               <<U.RAO>>00540000
   RSTORNOTAPEOP   = 1036,  <<OP CAN'T FIND TAPE>>             <<U.RAO>>00542000
   RSTORDEVNOTAVAL = 1037,  <<TO DEV NOT AVAILABLE>>           <<U.RAO>>00544000
   RSTORIMPTAPEFMT = 1038,  <<IMPROPER TAPE FORMAT>>           <<U.RAO>>00546000
   RSTORREQTAPEFILE= 1039,  <<MISSING TAPE NAME>>              <<U.RAO>>00548000
   RSTORXPCTSEMIC  = 1040,  <<NEED ; BETWEEN OPTIONS>>         <<U.RAO>>00550000
   RSTORREDUNDDEV  = 1041,  <<REDUNDANTLY SPECIFIED (WARN)>>   <<U.RAO>>00552000
   RSTORXPCTEQDEV  = 1042,  <<EXPECT = AFTER DEV>>             <<U.RAO>>00554000
   RSTORNODEV      = 1043,  <<EXPECTED DEV NAME>>              <<U.RAO>>00556000
   RSTORDEV2LNG    = 1044,  << > 8 CHAR IN DEV ID>>            <<U.RAO>>00558000
   RSTORDEVSPECIAL = 1045,  <<EMBEDDED SPECIAL IN DEV ID>>     <<U.RAO>>00560000
   RSTORINSUFSTACK = 1046,  <<ZSIZE FAILED>>                   <<U.RAO>>00562000
   RSTORTAPFOPTION = 1047,  <<BAD FOPTIONS ON TAPE>>           <<U.RAO>>00564000
   RSTORTAPAOPTION = 1048,  <<BAD AOPTIONS ON TAPE>>           <<U.RAO>>00566000
   RSTORTAPRECLEN  = 1049,  <<NOT 1024 WORDS>>                 <<U.RAO>>00568000
   RSTORNOTTAPEDEV = 1050,  <<NOT A TAPE DEVICE>>              <<U.RAO>>00570000
   RSTOR2MP        = 1051,                                     <<U.RAO>>00572000
   RSTORXPCTSEMITF = 1052,  <<UNEXPECTED DELIMITER>>           <<U.RAO>>00574000
   RSTORBADSYSLIST = 1053,  <<UNABLE TO USE SYSLIST>>          <<U.RAO>>00576000
   RSTOR2MAFSETS   = 1054,  <<TOO MANY ACCT FILESETS>>         <<U.RAO>>00578000
   RSTOR2MAGFFSETS = 1055,  <<TOO MANY FULLY QUALIFIED>>       <<U.RAO>>00580000
   RSTOR2MAGFSETS  = 1056,  <<TOO MANY GROUP FILESETS>>        <<U.RAO>>00582000
   RSTORFSETUNKDEL = 1057,  <<UNKNOWN DELIMITER IN FILESETS>>  <<00425>>00584000
   STOREREDUNDDATE = 1058,  <<REDUNDANT SPECIFICATION OF ;DATE><<00425>>00586000
   STORXPCTDATELTGT= 1059,  <<;DATE IS EXPECT "<" OR ">">>     <<00425>>00588000
   STORRECSIZEBAD  = 1060,  <<USER-SPECIFIED RECORD SIZE BAD>> <<00425>>00590000
   RSTORRECCONFLICT= 1061,  <<TAPE RECORD SIZE>USER-SPECIFIED R<<00425>>00592000
   RSTORUKNOPTION  = 1062,  << UNKNOWN KEYWORD >>              <<00530>>00594000
   XRETPMASKFAIL   = 1063,  << Bad return from XRETPMASK >>    <<02558>>00596000
   REMOTELBLINVAL  = 1064,  << Remote labelled tapes invalid >><<02649>>00598000
   STORE'FAILED    = 1090, <<STORE FAILED>>                    <<04658>>00600000
   STORE'JCW'FAILED= 1090, <<for right now>>                   <<04658>>00602000
   FILEXPINVMONTH  =  280,  <<BAD NO. FOR MONTH>>                       00604000
   FILEXPNOSLASHMD =  281,  <<NO SLASH BETWEEN MONTH & DAY>>            00606000
   FILEXPINVDAY    =  282,  <<BAD NO. FOR DAY>>                         00608000
   FILEXPNOSLASHDY =  284,  <<NO SLASH BETWEEN DAY & YEAR>>             00610000
   FILEXPXTRNDATA  =  286,  <<EXTRANEOUS DATA IN DATE>>        <<02562>>00612000
   DATASEGERROR    = 1127,  <<DATA SEGMENT NOT AVAILABLE>>     <<02562>>00614000
   INSUFFMEMORY    = 1128;  <<INSUFFICIENT VIRTUAL MEMORY>>    <<02562>>00616000
DEFINE                                                         <<04658>>00618000
   EXECUTORHEAD =                                              <<04658>>00620000
      (PARMSP,ERRNUM,PARMNUM);                                 <<04658>>00622000
      BYTE ARRAY PARMSP;                                       <<04658>>00624000
      INTEGER ERRNUM,PARMNUM #,                                <<04658>>00626000
   BCOMMANDBUFLEN = 270 #;                                     <<04658>>00628000
$PAGE "EXTERNAL PROCEDURE DECLARATIONS"                                 00630000
   INTRINSIC MYCOMMAND,FOPEN,FCLOSE,FREAD,FWRITE,FCONTROL,WHO,          00632000
      READ,DEBUG,FFILEINFO,                                    <<02558>>00634000
      ZSIZE,PRINT,FCHECK,FGETINFO,FSPACE,ASCII,                <<02546>>00636000
      DASCII,BINARY,DBINARY,FPOINT,FUPDATE;                    <<RV.RS>>00638000
                                                                        00640000
   PROCEDURE SUDDENDEATH(ERRNUM);                                       00642000
      VALUE ERRNUM;                                                     00644000
      INTEGER ERRNUM;                                                   00646000
      OPTION EXTERNAL;                                                  00648000
                                                                        00650000
  LOGICAL PROCEDURE CALENDAR;   OPTION EXTERNAL;                        00652000
                                                                        00656000
  DOUBLE PROCEDURE CLOCK;       OPTION EXTERNAL;                        00658000
LOGICAL PROCEDURE JOBSESSIONMAIN;  OPTION EXTERNAL;            <<U.RAO>>00660000
                                                               <<U.RAO>>00662000
                                                                        00664000
   INTEGER PROCEDURE LUN (VTABINX,MVTABX);                     <<RV.PV>>00666000
      VALUE VTABINX,MVTABX;                                    <<RV.PV>>00668000
      INTEGER VTABINX,MVTABX;                                  <<RV.PV>>00670000
      OPTION EXTERNAL;                                                  00672000
                                                                        00674000
   INTEGER PROCEDURE VTABINX (LUN,LOCAL);                      <<RV.PV>>00676000
      VALUE LUN,LOCAL;                                         <<RV.PV>>00678000
      INTEGER LUN;                                                      00680000
      LOGICAL LOCAL;                                           <<RV.PV>>00682000
      OPTION EXTERNAL;                                                  00684000
                                                                        00686000
   DOUBLE PROCEDURE ATTACHIO(LDEV,QMISC,DX,T,FUNC,CNT,P1,P2,FLAGS);     00688000
      VALUE LDEV,QMISC,DX,T,FUNC,CNT,P1,P2,FLAGS;                       00690000
      INTEGER LDEV,QMISC,DX,T,FUNC,CNT,P1,P2,FLAGS;                     00692000
      OPTION EXTERNAL;                                                  00694000
                                                                        00696000
   INTEGER PROCEDURE EXCHANGEDB(I);       << FOR ADDENTRY >>            00698000
         VALUE I;                                                       00700000
         INTEGER I;                                                     00702000
         OPTION EXTERNAL;                                               00704000
                                                                        00706000
   LOGICAL PROCEDURE ACCCHECK(LEVEL,ANAME,ASEC,GNAME,GSEC,              00708000
                              CREATOR,FSEC,USERINFO);                   00710000
      VALUE LEVEL,ASEC,GSEC,FSEC;                                       00712000
      INTEGER LEVEL;                                                    00714000
      BYTE ARRAY ANAME,GNAME,CREATOR,USERINFO;                          00716000
      LOGICAL ASEC;                                                     00718000
      DOUBLE GSEC,FSEC;                                                 00720000
      OPTION VARIABLE,EXTERNAL;                                         00722000
                                                                        00724000
   DOUBLE PROCEDURE DIRECADJUST (NUMSECTS,DUMMY,ANAME,         <<39.PV>>00726000
                                 GNAME,MVTABX);                <<39.PV>>00728000
      VALUE NUMSECTS,DUMMY,MVTABX;                             <<39.PV>>00730000
      DOUBLE NUMSECTS;                                                  00732000
      INTEGER DUMMY,MVTABX;                                    <<39.PV>>00734000
      ARRAY ANAME,GNAME;                                                00736000
      OPTION EXTERNAL,VARIABLE;                                <<39.PV>>00738000
                                                                        00740000
   DOUBLE PROCEDURE DIRECINSERTFILE (NUMSECTS,DUMMY,ANAME,     <<38.PV>>00742000
                        GNAME,FNAME,FADDR,MVTABX);             <<38.PV>>00744000
      VALUE NUMSECTS,DUMMY,FADDR,MVTABX;                       <<38.PV>>00746000
      DOUBLE NUMSECTS,FADDR;                                            00748000
      INTEGER DUMMY,MVTABX;                                    <<38.PV>>00750000
      ARRAY ANAME,GNAME,FNAME;                                          00752000
      OPTION EXTERNAL,VARIABLE;                                <<18.PV>>00754000
                                                               <<RV.PV>>00756000
   DOUBLE PROCEDURE DIRECPURGEFILE (NUMSECTS,DUMMY,ANAME,GNAME,<<38.PV>>00758000
                                    FNAME, MVTABX);            <<21.PV>>00760000
      VALUE NUMSECTS, DUMMY, MVTABX;                           <<38.PV>>00762000
      DOUBLE NUMSECTS;                                                  00764000
      INTEGER DUMMY, MVTABX;                                   <<38.PV>>00766000
      ARRAY ANAME,GNAME,FNAME;                                          00768000
      OPTION EXTERNAL, VARIABLE;                               <<21.PV>>00770000
                                                                        00772000
   DOUBLE PROCEDURE DIRECFINDFILE (TYPE,LINKAGE'INDEXP,        <<38.PV>>00774000
                           ANAME,GNAME,FNAME,PRETURN,MVTABX);  <<38.PV>>00776000
      VALUE TYPE,LINKAGE'INDEXP,MVTABX;                        <<38.PV>>00778000
      INTEGER TYPE,MVTABX;                                     <<38.PV>>00780000
      DOUBLE  LINKAGE'INDEXP;                                  <<38.PV>>00782000
      ARRAY ANAME,GNAME,FNAME,PRETURN;                                  00784000
      OPTION EXTERNAL,VARIABLE;                                <<38.PV>>00786000
                                                                        00788000
   DOUBLE PROCEDURE DIRECFIND (TYPE,LINKAGE'INDEXP,ANAME,      <<38.PV>>00790000
                               GNAME,FNAME,A);                 <<38.PV>>00792000
         VALUE TYPE,LINKAGE'INDEXP;                            <<38.PV>>00794000
         INTEGER TYPE;                                         <<38.PV>>00796000
         DOUBLE  LINKAGE'INDEXP;                               <<38.PV>>00798000
         INTEGER ARRAY ANAME,GNAME,FNAME,A;                             00800000
         OPTION EXTERNAL;                                               00802000
                                                                        00804000
   DOUBLE PROCEDURE DIRECINSERT (TYPE,LINKAGE'INDEXP,ANAME,    <<38.PV>>00806000
                                 GNAME,FNAME,A,MVTABX);        <<38.PV>>00808000
      VALUE TYPE,LINKAGE'INDEXP,MVTABX;                        <<38.PV>>00810000
      INTEGER TYPE,MVTABX;                                     <<38.PV>>00812000
      DOUBLE  LINKAGE'INDEXP;                                  <<38.PV>>00814000
      INTEGER ARRAY ANAME,GNAME,FNAME,A;                                00816000
      OPTION EXTERNAL,VARIABLE;                                <<12.PV>>00818000
                                                                        00820000
   DOUBLE PROCEDURE DIRECSETFLAG (TYPE,LINKAGE'INDEXP,ANAME,   <<38.PV>>00822000
                                  GNAME,FNAME,MVTABX);         <<32.PV>>00824000
       VALUE   TYPE,LINKAGE'INDEXP,MVTABX;                     <<38.PV>>00826000
       LOGICAL TYPE,MVTABX;                                    <<38.PV>>00828000
       DOUBLE  LINKAGE'INDEXP;                                 <<38.PV>>00830000
       ARRAY   ANAME,GNAME,FNAME;                              <<32.PV>>00832000
       OPTION  EXTERNAL,VARIABLE;                              <<32.PV>>00834000
                                                               <<32.PV>>00836000
   DOUBLE PROCEDURE DIRECRESETFLAG (TYPE,LINKAGE'INDEXP,ANAME, <<38.PV>>00838000
                                    GNAME,FNAME,MVTABX);       <<32.PV>>00840000
       VALUE   TYPE,LINKAGE'INDEXP,MVTABX;                     <<38.PV>>00842000
       LOGICAL TYPE,MVTABX;                                    <<38.PV>>00844000
       DOUBLE  LINKAGE'INDEXP;                                 <<38.PV>>00846000
       ARRAY   ANAME,GNAME,FNAME;                              <<32.PV>>00848000
       OPTION  EXTERNAL,VARIABLE;                              <<32.PV>>00850000
                                                               <<03508>>00852000
   INTEGER PROCEDURE Return'Disc'Space (ldev,                  <<03508>>00854000
         disc'address, number'of'sectors);                     <<03508>>00856000
      VALUE ldev, disc'address, number'of'sectors;             <<03508>>00858000
      INTEGER ldev;                                            <<03508>>00860000
      DOUBLE number'of'sectors, disc'address;                  <<03508>>00862000
      OPTION EXTERNAL;                                         <<03508>>00864000
                                                                        00866000
   INTEGER PROCEDURE GETDEVINFO(DEV,INFO);                              00870000
      BYTE ARRAY DEV;                                                   00872000
      INTEGER ARRAY INFO;                                               00874000
      OPTION EXTERNAL;                                                  00876000
                                                                        00878000
   INTEGER PROCEDURE DISKALLOC(INDX,NUMEXT,SPACEDATA,PVINFO);  <<RH.PV>>00880000
      VALUE INDX,NUMEXT,PVINFO;                                <<RH.PV>>00882000
      INTEGER INDX,NUMEXT;                                     <<RH.PV>>00884000
      LOGICAL PVINFO;                                          <<RH.PV>>00886000
      DOUBLE ARRAY SPACEDATA;                                  <<RH.PV>>00888000
      OPTION EXTERNAL;                                                  00890000
                                                                        00892000
   INTEGER PROCEDURE DISKDEALLOC(EXTSIZE,LASTEXTSIZE,NUMEXTS,MAP);      00894000
      VALUE NUMEXTS,EXTSIZE,LASTEXTSIZE;                                00896000
      INTEGER NUMEXTS,EXTSIZE,LASTEXTSIZE;                              00898000
      DOUBLE ARRAY MAP;                                                 00900000
      OPTION EXTERNAL;                                                  00902000
                                                                        00904000
PROCEDURE MOUNT (VSNAME,VSGROUP,VSACCNT,REQTYPE,GEN,           <<00211>>00906000
                 PVINFO,SOME'OTHER'PIN);                       <<00211>>00908000
    VALUE   GEN,SOME'OTHER'PIN;                                <<00211>>00910000
    INTEGER REQTYPE,GEN,PVINFO,SOME'OTHER'PIN;                 <<00211>>00912000
    BYTE ARRAY VSNAME,VSGROUP,VSACCNT;                         <<RV.PV>>00914000
    OPTION VARIABLE,EXTERNAL;                                  <<RV.PV>>00916000
                                                               <<RV.PV>>00918000
PROCEDURE DISMOUNT (VSNAME,VSGROUP,VSACCT,REQTYPE,             <<00211>>00920000
                    PVINFO,SOME'OTHER'PIN);                    <<00211>>00922000
    VALUE   PVINFO,SOME'OTHER'PIN;                             <<00211>>00924000
    INTEGER REQTYPE,PVINFO,SOME'OTHER'PIN;                     <<00211>>00926000
    BYTE ARRAY VSNAME,VSGROUP,VSACCT;                          <<RV.PV>>00928000
    OPTION EXTERNAL,VARIABLE;                                  <<RV.PV>>00930000
                                                               <<RV.PV>>00932000
LOGICAL PROCEDURE PRODUCEPARMS(LEAFLEVEL,QNAME,PPRESULT,      <<00.GEN>>00934000
                               DELIM,ERRNUM);                 <<00.GEN>>00936000
                              VALUE LEAFLEVEL,QNAME;          <<00.GEN>>00938000
                              INTEGER LEAFLEVEL;              <<00.GEN>>00940000
                              BYTE POINTER QNAME;             <<00.GEN>>00942000
                              ARRAY PPRESULT;                 <<00.GEN>>00944000
                              BYTE POINTER DELIM;             <<00.GEN>>00946000
                              INTEGER ERRNUM;                 <<00.GEN>>00948000
                              OPTION EXTERNAL;                <<00.GEN>>00950000
                                                              <<00.GEN>>00952000
INTEGER PROCEDURE DIRMATCH(GENNAME,REALNAME);                 <<00.GEN>>00954000
                          VALUE GENNAME,REALNAME;             <<00.GEN>>00956000
                          BYTE POINTER GENNAME,REALNAME;      <<00.GEN>>00958000
                          OPTION EXTERNAL;                    <<00.GEN>>00960000
                                                              <<00.GEN>>00962000
   DOUBLE PROCEDURE DIRECSCAN (TYPE,LINKAGE'INDEXP,ACCTNAME,   <<38.PV>>00964000
                     GROUPNAME,FILENAME,RECIP,PARAMS,MVTABX);  <<38.PV>>00966000
         VALUE TYPE,LINKAGE'INDEXP,MVTABX;                     <<38.PV>>00968000
         INTEGER TYPE,MVTABX;                                  <<38.PV>>00970000
         DOUBLE  LINKAGE'INDEXP;                               <<38.PV>>00972000
         INTEGER ARRAY ACCTNAME,GROUPNAME,FILENAME,PARAMS;              00974000
         INTEGER PROCEDURE RECIP;                                       00976000
         OPTION EXTERNAL,VARIABLE;                             <<35.PV>>00978000
                                                                        00980000
   INTEGER PROCEDURE GETSIR(A);                                         00982000
      VALUE A;   INTEGER A;                                             00984000
      OPTION EXTERNAL;                                                  00986000
                                                                        00988000
   PROCEDURE RELSIR(A,B);                                               00990000
       VALUE A,B;    INTEGER A,B;                                       00992000
      OPTION EXTERNAL;                                                  00994000
                                                                        00996000
INTEGER PROCEDURE XRETPMASK(N1,N2,N3,PMASKHI,PMASKLO);         <<02558>>00998000
   LOGICAL PMASKHI,PMASKLO;                                    <<02558>>01000000
   BYTE ARRAY N1,N2,N3;                                        <<02558>>01002000
   OPTION EXTERNAL;                                            <<02558>>01004000
                                                               <<02558>>01006000
PROCEDURE CIERR(ERRNUM, ERRADR, PARMMASK, PARM);               <<U.RAO>>01008000
   VALUE ERRNUM, PARMMASK, PARM;                               <<U.RAO>>01010000
   INTEGER ERRNUM, PARMMASK, PARM;                             <<U.RAO>>01012000
   BYTE ARRAY ERRADR;                                          <<U.RAO>>01014000
   OPTION PRIVILEGED, UNCALLABLE, VARIABLE, EXTERNAL;          <<U.RAO>>01016000
                                                               <<04658>>01018000
PROCEDURE CXFILE EXECUTORHEAD;                                 <<04658>>01020000
         OPTION EXTERNAL;                                      <<04658>>01022000
                                                               <<04658>>01024000
LOGICAL PROCEDURE CREATEPROC'ERR (ERROR, ERRNUM);              <<04658>>01026000
         VALUE ERROR; INTEGER ERROR,ERRNUM;                    <<04658>>01028000
         OPTION EXTERNAL;                                      <<04658>>01030000
                                                               <<04658>>01032000
                                                               <<U.RAO>>01034000
INTEGER PROCEDURE GENMSG(SETNO,MSGNO,MASK,A,B,C,D,E,           <<0U.EB>>01036000
      DEST,REPLY,BUFF,DST,IOTYPE);                             <<0U.EB>>01038000
   VALUE SETNO,MSGNO,MASK,A,B,C,D,E,DEST,REPLY,BUFF,           <<0U.EB>>01040000
      DST,IOTYPE;                                              <<0U.EB>>01042000
   LOGICAL SETNO,MSGNO,MASK,A,B,C,D,E,DEST,REPLY,BUFF,         <<0U.EB>>01044000
      DST,IOTYPE;                                              <<0U.EB>>01046000
   OPTION VARIABLE,EXTERNAL;                                   <<0U.EB>>01048000
                                                               <<0U.EB>>01050000
   LOGICAL PROCEDURE FREPLY(MESSAGE,LENGTH);                            01052000
      VALUE LENGTH;                                                     01054000
      BYTE ARRAY MESSAGE;                                               01056000
      INTEGER LENGTH;                                                   01058000
      OPTION EXTERNAL;                                                  01060000
                                                                        01062000
PROCEDURE DATE'LINE(STRING);                                   <<04.RO>>01064000
BYTE ARRAY STRING;                                             <<04.RO>>01066000
OPTION EXTERNAL;                                               <<04.RO>>01068000
                                                               <<04.RO>>01070000
PROCEDURE FERROR'(FNUM, PARMNUM);                              <<U.RAO>>01072000
   VALUE FNUM;                                                 <<U.RAO>>01074000
   INTEGER FNUM, PARMNUM;                                      <<U.RAO>>01076000
   OPTION PRIVILEGED, UNCALLABLE, EXTERNAL;                    <<U.RAO>>01078000
                                                                        01080000
   LOGICAL PROCEDURE REQUESTSERVICE;                                    01082000
      OPTION EXTERNAL;                                                  01084000
                                                                        01086000
PROCEDURE VTABTOLDEV (T,S,COUNT,MVTABX);                       <<RV.PV>>01088000
   VALUE COUNT,MVTABX;                                         <<RV.PV>>01090000
   DOUBLE ARRAY T,S;                                                    01092000
   INTEGER COUNT,MVTABX;                                       <<RV.PV>>01094000
   OPTION EXTERNAL;                                                     01096000
                                                                        01098000
PROCEDURE LDEVTOVTAB (T,S,COUNT,LOCAL);                        <<RV.PV>>01100000
   VALUE COUNT,LOCAL;                                          <<RV.PV>>01102000
   DOUBLE ARRAY T,S;                                                    01104000
   INTEGER COUNT;                                              <<RV.PV>>01106000
   LOGICAL LOCAL;                                              <<RV.PV>>01108000
   OPTION EXTERNAL;                                                     01110000
                                                                        01112000
LOGICAL PROCEDURE LDIRECTF(FNUM);                              <<02546>>01114000
   VALUE FNUM; INTEGER FNUM;                                   <<02546>>01116000
   OPTION EXTERNAL;                                            <<02546>>01118000
                                                               <<02546>>01120000
LOGICAL PROCEDURE LRELSW(FNUM);                                <<02546>>01124000
   VALUE FNUM; INTEGER FNUM;                                   <<02546>>01126000
  OPTION EXTERNAL;                                             <<00615>>01128000
                                                               <<00615>>01130000
INTEGER PROCEDURE REELSWITCH(LDEV,RDWR);                       <<02546>>01132000
   VALUE LDEV,RDWR;                                            <<02546>>01134000
   LOGICAL LDEV;                                               <<02546>>01136000
   INTEGER RDWR;                                               <<02546>>01138000
   OPTION EXTERNAL;                                            <<02546>>01140000
                                                                        01142000
INTEGER PROCEDURE NEXTTAPEFILE(FNUM);                          <<02546>>01144000
INTEGER FNUM;                                                           01146000
OPTION EXTERNAL;                                                        01148000
                                                                        01150000
<< Advance to the next file on a labeled tape. >>                       01152000
                                                                        01154000
                                                               <<02518>>01156000
INTEGER PROCEDURE GETDATASEG(MSIZE,VMSIZE);                    <<02518>>01158000
   VALUE MSIZE, VMSIZE;                                        <<02518>>01160000
   INTEGER MSIZE, VMSIZE;                                      <<02518>>01162000
   OPTION EXTERNAL;                                            <<02518>>01164000
                                                               <<02518>>01166000
PROCEDURE RELDATASEG(EN);                                      <<02518>>01168000
   VALUE EN;                                                   <<02518>>01170000
   INTEGER EN;                                                 <<02518>>01172000
   OPTION EXTERNAL;                                            <<02518>>01174000
                                                               <<02518>>01176000
DOUBLE PROCEDURE WAITFORIO (IOQX);                             <<02518>>01178000
   VALUE IOQX;                                                 <<02518>>01180000
   INTEGER IOQX;                                               <<02518>>01182000
   OPTION EXTERNAL;                                            <<02518>>01184000
                                                               <<02518>>01186000
PROCEDURE LOCKSEG(EN,TEST,PINX);                               <<02518>>01188000
   VALUE EN,TEST,PINX;                                         <<02518>>01190000
   INTEGER EN,PINX;                                            <<02518>>01192000
   LOGICAL TEST;                                               <<02518>>01194000
   OPTION EXTERNAL;                                            <<02518>>01196000
                                                               <<02518>>01198000
PROCEDURE UNLOCKSEG(EN,TEST,PINX);                             <<02518>>01200000
   VALUE EN,TEST,PINX;                                         <<02518>>01202000
   INTEGER EN,PINX;                                            <<02518>>01204000
   LOGICAL TEST;                                               <<02518>>01206000
   OPTION EXTERNAL;                                            <<02518>>01208000
                                                               <<02518>>01210000
                                                                        01212000
                                                                        01214000
PROCEDURE FREEZE(EN,TEST,PINX);                                <<02645>>01216000
   VALUE EN,TEST,PINX;                                         <<02645>>01218000
   INTEGER EN,PINX;                                            <<02645>>01220000
   LOGICAL TEST;                                               <<02645>>01222000
   OPTION EXTERNAL;                                            <<02645>>01224000
                                                               <<02645>>01226000
PROCEDURE UNFREEZE(EN,TEST,PINX);                              <<02645>>01228000
   VALUE EN,TEST,PINX;                                         <<02645>>01230000
   INTEGER EN,PINX;                                            <<02645>>01232000
   LOGICAL TEST;                                               <<02645>>01234000
   OPTION EXTERNAL;                                            <<02645>>01236000
                                                               <<02708>>01238000
INTEGER PROCEDURE IOSTAT(STAT);                                <<02708>>01240000
   VALUE STAT;                                                 <<02708>>01242000
   INTEGER STAT;                                               <<02708>>01244000
   OPTION EXTERNAL;                                            <<02708>>01246000
                                                               <<02708>>01248000
PROCEDURE POST'ACB'ERROR(FILENUM,THEIRSTATUS,ERROR);           <<02708>>01250000
   VALUE FILENUM,THEIRSTATUS,ERROR;                            <<02708>>01252000
   INTEGER FILENUM,ERROR;                                      <<02708>>01254000
   LOGICAL THEIRSTATUS;                                        <<02708>>01256000
   OPTION EXTERNAL;                                            <<02708>>01258000
$PAGE                                                                   01260000
 PROCEDURE CXSTORE(P,ENUMBER,PNUMBER);                                  01262000
    BYTE ARRAY P;                                                       01264000
      INTEGER ENUMBER,PNUMBER;                                          01266000
   OPTION PRIVILEGED,UNCALLABLE,FORWARD;                                01268000
                                                                        01270000
   DOUBLE PROCEDURE ISTORE(PTR,ENUM,GNUM,PDATE,RETVAL,FCLLIM,           01272000
                           FCULIM,FLAG);                                01274000
      VALUE ENUM,GNUM,PDATE,FCLLIM,FCULIM,FLAG;                         01276000
      INTEGER ENUM,GNUM,FCLLIM,FCULIM;                                  01278000
      INTEGER ARRAY RETVAL;                                             01280000
      BYTE ARRAY PTR;                                                   01282000
      LOGICAL PDATE,FLAG;                                               01284000
      OPTION PRIVILEGED,UNCALLABLE,FORWARD;                             01286000
                                                                        01288000
 INTEGER PROCEDURE RCSTORE(ELEMENT,LEVEL,PARMS,SIR);                    01290000
     VALUE LEVEL,PARMS,SIR;                                             01292000
     INTEGER LEVEL,PARMS;                                               01294000
     INTEGER ARRAY ELEMENT;                                             01296000
     DOUBLE SIR;                                                        01298000
   OPTION PRIVILEGED,UNCALLABLE,FORWARD;                                01300000
                                                                        01302000
   DOUBLE PROCEDURE FSTORE(TNUM,GNUM);                                  01304000
      VALUE TNUM,GNUM;                                                  01306000
      INTEGER TNUM,GNUM;                                                01308000
                                                                        01310000
      OPTION PRIVILEGED,UNCALLABLE,FORWARD;                             01312000
                                                                        01314000
DOUBLE PROCEDURE DIREC'TO'TAPE (GNUM,CURR'GOODREC,TDBUF,       <<02546>>01316000
                         TRAILBL,TNUM,K,L);                    <<02546>>01318000
    VALUE GNUM,CURR'GOODREC,TNUM;                              <<02546>>01320000
    INTEGER GNUM,CURR'GOODREC,TNUM,K,L;                        <<02546>>01322000
    ARRAY TDBUF,TRAILBL;                                       <<02546>>01324000
    OPTION UNCALLABLE,FORWARD;                                 <<02546>>01326000
                                                               <<02546>>01328000
   PROCEDURE UNLOCKSTORE (GNUM,REW,PVINFO,PREVGBUF);           <<RC.PV>>01330000
      VALUE GNUM,REW,PVINFO;                                   <<RV.PV>>01332000
      INTEGER GNUM;                                                     01334000
      LOGICAL REW,PVINFO;                                      <<RV.PV>>01336000
      ARRAY PREVGBUF;                                          <<RC.PV>>01338000
      OPTION PRIVILEGED,UNCALLABLE,VARIABLE,FORWARD;           <<RV.PV>>01340000
                                                                        01342000
   DOUBLE PROCEDURE PRINTDFILE(PNUM,DNUM,COUNT,GORE,CHR,SHOW);          01344000
      VALUE PNUM,DNUM,COUNT,GORE,SHOW;                                  01346000
      INTEGER PNUM,DNUM,COUNT;                                          01348000
      BYTE ARRAY CHR;                                                   01350000
      LOGICAL GORE,SHOW;                                                01352000
      OPTION PRIVILEGED,UNCALLABLE,FORWARD;                             01354000
                                                                        01356000
   PROCEDURE CXRESTORE(P,ENUMBER,PNUMBER);                              01358000
      BYTE ARRAY P;                                                     01360000
      INTEGER ENUMBER,PNUMBER;                                          01362000
      OPTION PRIVILEGED,UNCALLABLE,FORWARD;                             01364000
                                                                        01366000
   DOUBLE PROCEDURE IRESTORE(FILESETS,TNUM,CNUM,ENUM,RETVAL);           01368000
      VALUE TNUM,CNUM,ENUM;                                             01370000
      BYTE ARRAY FILESETS;                                              01372000
      INTEGER TNUM,CNUM,ENUM;                                           01374000
      INTEGER ARRAY RETVAL;                                             01376000
      OPTION PRIVILEGED,UNCALLABLE,FORWARD;                             01378000
                                                                        01380000
   DOUBLE PROCEDURE FRESTORE(TNUM,CNUM,ENUM,GNUM,DEVPARM,               01382000
                             RETVAL,FCLLIM,FCULIM,FLAGS);               01384000
      VALUE TNUM,CNUM,ENUM,GNUM,FCLLIM,FCULIM,FLAGS;                    01386000
      INTEGER TNUM,CNUM,ENUM,GNUM,FCLLIM,FCULIM;                        01388000
      BYTE ARRAY DEVPARM;                                               01390000
      INTEGER ARRAY RETVAL;                                             01392000
      LOGICAL FLAGS;                                                    01394000
      OPTION PRIVILEGED,UNCALLABLE,FORWARD;                             01396000
                                                                        01398000
   INTEGER PROCEDURE STARTVOLUME(TNUM,HDRLBL);                 <<02546>>01400000
       VALUE TNUM;                                             <<RV.RS>>01402000
       INTEGER TNUM;                                           <<02546>>01404000
       INTEGER ARRAY HDRLBL;                                   <<RV.RS>>01406000
       OPTION PRIVILEGED,UNCALLABLE,FORWARD;                   <<RV.RS>>01408000
                                                               <<RV.RS>>01410000
   PROCEDURE TAPESWITCH(TNUM,TDBUF);                           <<02546>>01412000
      VALUE TNUM;                                                       01414000
      INTEGER TNUM;                                            <<02546>>01416000
      INTEGER ARRAY TDBUF;                                              01418000
      OPTION PRIVILEGED,UNCALLABLE,FORWARD;                             01420000
                                                                        01422000
   INTEGER PROCEDURE ADJUSTFPTR(ELEMENT,LEVEL,PARMS,SIR);               01424000
      VALUE LEVEL,PARMS,SIR;                                            01426000
      INTEGER LEVEL,PARMS;                                              01428000
      DOUBLE SIR;                                                       01430000
      INTEGER ARRAY ELEMENT;                                            01432000
      OPTION PRIVILEGED,UNCALLABLE,FORWARD;                             01434000
                                                                        01436000
   LOGICAL PROCEDURE SETCRITICAL;                                       01438000
      OPTION EXTERNAL;                                                  01440000
                                                                        01442000
   PROCEDURE RESETCRITICAL(A);                                          01444000
      VALUE A;                                                          01446000
      LOGICAL A;                                                        01448000
      OPTION EXTERNAL;                                                  01450000
                                                                        01452000
$PAGE "CXSTORE/CXRESTORE UTILITY PROCEDURES"                   <<02558>>01454000
$CONTROL SEGMENT=CXSTOREST                                     <<02558>>01456000
                                                               <<02558>>01458000
LOGICAL PROCEDURE GET'TAPE'INFO(FILENUM,MAX'BLOCK,DENSITY);    <<02558>>01460000
   VALUE FILENUM;                                              <<02558>>01462000
   INTEGER FILENUM,MAX'BLOCK,DENSITY;                          <<02558>>01464000
   OPTION PRIVILEGED,UNCALLABLE;                               <<02558>>01466000
                                                               <<02558>>01468000
COMMENT                                                        <<02558>>01470000
                                                               <<02558>>01472000
   This procedure returns information about tape files which is<<02558>>01474000
relevant only to those programs/procedures which interface the <<02558>>01476000
user to the STORE/RESTORE procedures ISTORE, FSTORE, IRESTORE, <<02558>>01478000
& FRESTORE.  The typical caller has opened the STORE/RESTORE   <<02558>>01480000
output tape (serial disc) file and is in the process of verify-<<02558>>01482000
ing the file characteristics specified by the user.  The caller<<02558>>01484000
must ensure that FILENUM resides on a magtape drive.  DB MUST  <<02558>>01486000
BE AT STACK.                                                   <<02558>>01488000
                                                               <<02558>>01490000
INPUTS:                                                        <<02558>>01492000
   FILENUM -- the tape file in question.                       <<02558>>01494000
                                                               <<02558>>01496000
OUTPUTS:                                                       <<02558>>01498000
   MAX'BLOCK -- the maximum block size the user can legally    <<02558>>01500000
                specify for this file (function of density).   <<02558>>01502000
   DENSITY   -- the density of the tape file in BPI.           <<02558>>01504000
   Procedure -- TRUE, when no errors.                          <<02558>>01506000
   return       FALSE, when a file system error occured.       <<02558>>01508000
                                                               <<02558>>01510000
Called by:  CXSTORE, CXRESTORE (Procedures)                    <<02558>>01512000
            SYSDUMP, DBSTORE, DBRESTORE (Programs in PUB.SYS)  <<02558>>01514000
                                                               <<02558>>01516000
;     << end of comment >>                                     <<02558>>01518000
                                                               <<02558>>01520000
BEGIN                                                          <<02558>>01522000
LOGICAL                                                        <<02558>>01526000
   RESULT = GET'TAPE'INFO;   << Procedure return >>            <<02558>>01528000
                                                               <<02558>>01530000
                                                               <<02558>>01532000
   RESULT := FALSE;   << Set up return to signal error >>      <<02558>>01534000
                                                               <<02558>>01536000
   << Determine density of tape >>                             <<02558>>01538000
   FFILEINFO(FILENUM,DEN'OPTION,DENSITY);                      <<02558>>01540000
   IF <> THEN RETURN;    << File system error.  Return. >>     <<02674>>01542000
                                                               <<02674>>01546000
   IF DENSITY = 0 THEN                                         <<02674>>01548000
      DENSITY := 1600;   << Not a variable density drive. >>   <<02674>>01550000
                                                               <<02558>>01552000
   RESULT := TRUE;   << Everything OK. >>                      <<02558>>01554000
                                                               <<02558>>01556000
   << Maximum block size is a function of density. >>          <<02558>>01558000
   MAX'BLOCK := IF DENSITY = 1600 THEN 4096                    <<02558>>01560000
                                  ELSE 8192;                   <<02558>>01562000
                                                               <<02558>>01564000
END;   << of GET'TAPE'INFO >>                                  <<02558>>01566000
$CONTROL SEGMENT=CXSTOREST                                     <<02558>>01568000
                                                               <<02558>>01570000
PROCEDURE SETUP'FLAGS(FILENUM,DENSITY,DESIG,FLAGS,ERRNUM);     <<02558>>01572000
   VALUE FILENUM,DENSITY;                                      <<02558>>01574000
   INTEGER FILENUM,DENSITY,ERRNUM;                             <<02558>>01576000
   BYTE ARRAY DESIG;                                           <<02558>>01578000
   LOGICAL FLAGS;                                              <<02558>>01580000
   OPTION PRIVILEGED,UNCALLABLE;                               <<02558>>01582000
                                                               <<02558>>01584000
COMMENT                                                        <<02558>>01586000
                                                               <<02558>>01588000
   This procedure handles a KLUDGE which is relevant only to   <<02558>>01590000
those programs/procedures which interface the user to the      <<02558>>01592000
STORE/RESTORE procedures FSTORE & IRESTORE.  (It should be     <<02558>>01594000
easy to extend this procedure to do any extra work which is    <<02558>>01596000
common to all these programs/procedures.)                      <<02558>>01598000
   The calling procedure opens the STORE/RESTORE tape (serial  <<02558>>01600000
disc) file with a block size of 4096 words.  However, for 6250 <<02558>>01602000
BPI tapes which use the ATTACHIO algorithm, the default block  <<02617>>01604000
size is defined to be 8192 words.  (Default here means that the<<02617>>01606000
user has not used a file equation to specify the file's block  <<02617>>01608000
size.)  In this case, the caller must signal FSTORE/IRESTORE   <<02617>>01610000
that the block size returned by FGETINFO (4096 words) should be<<02617>>01612000
ignored and that the actual block size should be 8192 words.   <<02617>>01614000
This procedure sets a flag when it detects this situation.     <<02617>>01616000
                                                               <<02558>>01618000
INPUTS:                                                        <<02558>>01620000
   FILENUM -- the file in quetion.                             <<02558>>01622000
   DENSITY -- the density of the file in BPI, relevant for     <<02558>>01624000
              tape files only.                                 <<02558>>01626000
   DESIG   -- the formal designator used to open the file.     <<02558>>01628000
                                                               <<02558>>01630000
OUTPUTS:                                                       <<02558>>01632000
   FLAGS   -- TRUE when the user has taken the default block   <<02617>>01634000
              size and ATTACHIO will be used with the tape     <<02617>>01636000
              file.  (If this procedure is ever expanded, each <<02617>>01638000
              bit in the FLAGS word could have a different     <<02558>>01640000
              meaning.)                                        <<02558>>01642000
   ERRNUM  --   0:  no errors occured.                         <<02558>>01644000
               -1:  a file system error occured.               <<02558>>01646000
              1,2:  error in XRETPMASK:  1 = FEQ entry cannot  <<02558>>01648000
                    be found, 2 = FEQ pointer entry points to  <<02558>>01650000
                    non-existent entry.                        <<02558>>01652000
                                                               <<02558>>01654000
Called by:  CXSTORE, CXRESTORE (Procedures)                    <<02558>>01656000
            SYSDUMP, DBSTORE, DBRESTORE (Programs in PUB.SYS)  <<02558>>01658000
                                                               <<02558>>01660000
DB MUST BE AT STACK !!                                         <<02558>>01662000
                                                               <<02558>>01664000
;    << end of comment >>                                      <<02558>>01666000
                                                               <<02558>>01668000
BEGIN                                                          <<02558>>01670000
INTEGER                                                        <<02558>>01672000
   DESIG'POS := 0, << Start of designator minus leading "*" >> <<02558>>01674000
   RECSIZE,        << Returns from FGETINFO >>                 <<02558>>01676000
   DEVTYPE;                                                    <<02558>>01678000
LOGICAL                                                        <<02558>>01680000
   LDEV,                                                       <<02617>>01682000
   FOPTIONS,                                                   <<02558>>01684000
   SPEC'ENTRY := FALSE,                                        <<02871>>01686000
   MASKHI,         << 1st and 2nd words of FEQ option bits >>  <<02558>>01688000
   MASKLOW;                                                    <<02558>>01690000
BYTE                                                           <<02558>>01692000
   DUMMY := " ";   << Dummy for XRETPMASK >>                   <<02558>>01694000
                                                               <<02558>>01696000
                                                               <<02558>>01698000
   << Initialization -- no errors/no special case >>           <<02558>>01700000
   ERRNUM := 0;                                                <<02558>>01702000
   FLAGS := FALSE;                                             <<02558>>01704000
                                                               <<02558>>01706000
   FGETINFO(FILENUM,,FOPTIONS,,RECSIZE,DEVTYPE,LDEV);          <<02617>>01708000
   IF <> THEN                                                  <<02558>>01710000
      BEGIN    << File system error >>                         <<02558>>01712000
      ERRNUM := -1;                                            <<02558>>01714000
      RETURN;                                                  <<02558>>01716000
      END;                                                     <<02558>>01718000
                                                               <<02558>>01720000
   IF USING'ATTIO AND (DENSITY = 6250) AND                     <<02617>>01722000
     (RECSIZE = 4096)  THEN                                    <<02617>>01724000
      BEGIN                                                    <<02558>>01726000
      << Possible special case.  Check FILE equation. >>       <<02558>>01728000
                                                               <<02558>>01730000
      IF DESIG = "*" THEN DESIG'POS := 1;                      <<02558>>01732000
      ERRNUM := XRETPMASK(DESIG(DESIG'POS),DUMMY,DUMMY,        <<02558>>01734000
                          MASKHI,MASKLOW);                     <<02558>>01736000
                                                               <<02558>>01738000
      << If no file equation, then either special case or >>   <<02558>>01740000
      << error.  Let caller decide. >>                         <<02558>>01742000
                                                               <<02558>>01744000
      IF ERRNUM <> 0 THEN                                      <<02558>>01746000
         FLAGS := TRUE                                         <<02558>>01748000
      ELSE                                                     <<02558>>01750000
         FLAGS := NOT MASKHI.RECSIZE'FLAG;                     <<02558>>01752000
      END;                                                     <<02558>>01754000
                                                               <<02558>>01756000
END;   << of SETUP'FLAGS >>                                    <<02558>>01758000
$CONTROL SEGMENT=CXSTOREST                                              01760000
LOGICAL PROCEDURE CHECKEXPDATE(ERRNUM, FIELDLEN, DATASOURCE,   <<00425>>01762000
    MONTH,DAY,YEAR);                                           <<00425>>01764000
VALUE FIELDLEN;                                                <<00425>>01766000
INTEGER ERRNUM, FIELDLEN,MONTH,DAY,YEAR;                       <<00425>>01768000
BYTE ARRAY DATASOURCE;                                         <<00425>>01770000
<<This procedure checks the expiration date field for labeled>><<00425>>01772000
<<tapes.  The format for this field is MM/DD/YY.  They may all><<00425>>01774000
<<be zero.  The procedure calls CIERR directly.  ERRNUM is the><<00425>>01776000
<<usual CI error parameter.  FIELDLEN is the length of the >>  <<00425>>01778000
<<expiration date field as determined in the FILE command by>> <<00425>>01780000
<<MYCOMMAND.  It is used to check for extraneous data.  >>     <<00425>>01782000
BEGIN                                                          <<00425>>01784000
INTEGER DAYLEN;                                                <<00425>>01786000
INTEGER NUMLEN;  <<LENGTH OF THE INDIVIDUAL DATA FIELD>>       <<00425>>01788000
INTEGER MAXDAYS;  <<USED TO COPE WITH LEAP YEAR COMPLICATIONS>><<00425>>01790000
BYTE POINTER SOURCEPTR;   <<CURRENT LOCATION IN SOURCE>>       <<00425>>01792000
INTEGER ARRAY MONTHARR(0:12) = PB :=    << Nr. days in month >><<02546>>01794000
   0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31;          <<00425>>01796000
                                                               <<00425>>01798000
SUBROUTINE GETTOKEN(TARGET);                                   <<00425>>01800000
INTEGER TARGET;                                                <<00425>>01802000
<<FINDS AND COMPUTES EACH PART OF THE DATE FIELD>>             <<00425>>01804000
BEGIN                                                          <<00425>>01806000
SCAN SOURCEPTR WHILE [8/%15,8/" "],1;                          <<00425>>01808000
@SOURCEPTR := TOS;                                             <<00425>>01810000
MOVE SOURCEPTR := SOURCEPTR WHILE N,1;                         <<00425>>01812000
NUMLEN := TOS-@SOURCEPTR;                                      <<00425>>01814000
TARGET := BINARY(SOURCEPTR, NUMLEN);  <<CONVERT TO BINARY>>    <<00425>>01816000
END;                                                           <<00425>>01818000
@SOURCEPTR := @DATASOURCE;                                     <<00425>>01820000
GETTOKEN(MONTH);   <<COMPUTE MONTH VALUE>>                     <<00425>>01822000
IF NOT(1<=NUMLEN<=2) OR NOT(1<=MONTH<=12) THEN   <<INVALID MONT<<00425>>01824000
   CIERR(ERRNUM := FILEXPINVMONTH, SOURCEPTR)                  <<00425>>01826000
ELSE                                                           <<00425>>01828000
   BEGIN   <<MONTH CHECKED OUT OK, DO DAY>>                    <<00425>>01830000
   SCAN SOURCEPTR(NUMLEN) WHILE [8/%15,8/" "],1;               <<00425>>01832000
   IF BPS0 <> "/" THEN                                         <<00425>>01834000
      CIERR(ERRNUM := FILEXPNOSLASHMD, BPS0)                   <<00425>>01836000
   ELSE   <<FOUND SLASH, LOOK FOR DAY>>                        <<00425>>01838000
      BEGIN                                                    <<00425>>01840000
      @SOURCEPTR := TOS+1;                                     <<00425>>01842000
      GETTOKEN(DAY);                                           <<00425>>01844000
      DAYLEN:=NUMLEN; <<SAVE DAY LENGTH 4 LATER USE>>          <<00425>>01846000
      SCAN SOURCEPTR(NUMLEN) WHILE [8/%15,8/" "],1;            <<00425>>01848000
      IF BPS0 <> "/" THEN                                      <<00425>>01850000
         CIERR(ERRNUM := FILEXPNOSLASHDY, BPS0)                <<00425>>01852000
      ELSE                                                     <<00425>>01854000
         BEGIN                                                 <<00425>>01856000
         @SOURCEPTR := TOS+1;                                  <<00425>>01858000
         GETTOKEN(YEAR);                                       <<00425>>01860000
         MAXDAYS := MONTHARR(MONTH)+<<LEAP YEAR CORRECTION>>   <<00425>>01862000
            (IF YEAR MOD 4 = 0 AND MONTH = 2 THEN 1 ELSE 0);   <<00425>>01864000
         IF NOT(1<=DAYLEN<=2) OR                               <<00425>>01866000
            NOT(1<=DAY<=MAXDAYS) THEN                          <<00425>>01868000
            CIERR(ERRNUM:=FILEXPINVDAY,SOURCEPTR,%10000,       <<00425>>01870000
                  MAXDAYS)                                     <<00425>>01872000
         ELSE                                                  <<00425>>01874000
          IF @SOURCEPTR(NUMLEN)-@DATASOURCE <> FIELDLEN THEN   <<00425>>01876000
             CIERR(ERRNUM:=FILEXPXTRNDATA,SOURCEPTR(NUMLEN))   <<00425>>01878000
         ELSE CHECKEXPDATE:=TRUE;  <<ALL CHECKED OUT, DO IT>>  <<00425>>01880000
         END;                                                  <<00425>>01882000
      END;                                                     <<00425>>01884000
   END;                                                        <<00425>>01886000
END;   <<PROCEDURE CHECKEXPDATE>>                              <<00425>>01888000
$PAGE "CXSTORE  --  STORE COMMAND EXECUTOR"                    <<02558>>01890000
$CONTROL SEGMENT=CXSTOREST                                     <<02558>>01892000
                                                                        01894000
   PROCEDURE CXSTORE(P,ENUMBER,PNUMBER);                                01896000
      BYTE ARRAY P;                                                     01898000
      INTEGER ENUMBER,PNUMBER;                                          01900000
      OPTION PRIVILEGED,UNCALLABLE;                                     01902000
                                                                        01904000
<<*******************************************************************>> 01906000
<<    CXSTORE IS INVOKED DIRECTLY BY THE COMMAND INTERPRETER OF      >> 01908000
<<    MPE WHEN A STORE COMMAND IS ENCOUNTERED.  THE PARAMETER P      >> 01910000
<<    IS A BYTE ARRAY CONTAINING THE ENTIRE PARAMETER LIST TO THE    >> 01912000
<<    STORE COMMAND, IN EXACTLY THE FORMAT IN WHICH THE USER         >> 01914000
<<    SPECIFIED IT, EXCEPT THAT THE COMMAND INTERPRETER HAS RESOLVED >> 01916000
<<    CONTINUATION LINES.    CXSTORE SEES P AS ONE LOGICAL STRING,   >> 01918000
<<    CONSISTING OF ONE TO ABOUT 250 CHARACTERS.  THE COMMAND        >> 01920000
<<    INTERPRETER ENSURES THAT THE LAST CHARACTER OF THE STRING IS   >> 01922000
<<    A CARRIAGE RETURN.                                             >> 01924000
<<                                                                   >> 01926000
<<    THE FUNCTION OF CXSTORE IS TO:                                 >> 01928000
<<                                                                   >> 01930000
<<      1) PERFORM SOME SYNTAX CHECKING OF THE PARAMETER LIST.       >> 01932000
<<      2) OPEN TAPE FILE AND TWO DISK WORK FILES(G & E).            >> 01934000
<<      3) CALL ISTORE PROCEDURE, WHICH WRITES G & E, GIVEN P.       >> 01936000
<<      4) IF G IS NOT EMPTY, CALL FSTORE PROCEDURE WHICH DUMPS      >> 01938000
<<         EVERY FILE NAMED IN G ONTO THE STORE TAPE.                >> 01940000
<<      5) PRINT G & E FILES.                                        >> 01942000
<<*******************************************************************>> 01944000
<<                                                                   >> 01946000
<<    THE SYNTAX OF THE STORE COMMAND IS AS FOLLOWS:                 >> 01948000
<<                                                                   >> 01950000
<<      :STORE [FILESET[,FILESET]...] ;DEST [;SHOW] [;FILES=N]       >> 01952000
<<                                                                   >> 01954000
<<*******************************************************************>> 01956000
<<                                                             <<U.RAO>>01958000
<<CXSTORE INVOKES THE COMMAND INTERPRETER ERROR MECHANISM      <<U.RAO>>01960000
<< WHEN AN ERROR IS DETECTED: FERROR' FOR FILE SYSTEM          <<U.RAO>>01962000
<<ERRORS AND CIERR IN ALL CASES.  THE FOLLOWING                <<U.RAO>>01964000
<<ERRORS ARE RETURNED FROM PRINTDFILE:                         <<U.RAO>>01966000
<<                                                             <<U.RAO>>01968000
<<     S-0         S-1        ERROR                            <<U.RAO>>01970000
<<     ---         ---        -----                            <<U.RAO>>01972000
<<      0           -        NONE                              <<U.RAO>>01974000
<<      1     FILE NUMBER    FILE SYSTEM                       <<U.RAO>>01976000
<<     12                    BREAK SENSED                      <<U.RAO>>01978000
<<                                                             <<U.RAO>>01980000
<<*******************************************************************>> 01982000
<<                                                                      01984000
        FORMAT OF A LOGICAL RECORD ON THE ERROR FILE (ENUM):            01986000
                                                                        01988000
                                                                        01990000
                     ************************                           01992000
                   0 *                      *                           01994000
                   1 *       FILE           *                           01996000
                   2 *                      *                           01998000
                   3 *                      *                           02000000
                     ************************                           02002000
                   4 *                      *                           02004000
                   5 *       GROUP          *                           02006000
                   6 *                      *                           02008000
                   7 *                      *                           02010000
                     ************************                           02012000
                   8 *                      *                           02014000
                   9 *     ACCOUNT          *                           02016000
                  10 *                      *                           02018000
                  11 *                      *                           02020000
                     ************************                           02022000
                  12 * FILESET PARM NUMBER  *                           02024000
                     ************************                           02026000
                  13 * ERR CODE *  DETAIL   *                           02028000
                     ************************                           02030000
                                                                   >>   02032000
<<*******************************************************************>> 02034000
<<                                                                      02036000
     THE FORMAT OF A LOGICAL RECORD ON THE DISK WORK FILE GNUM IS       02038000
     AS FOLLOWS:                                                        02040000
                                                                        02042000
         1) EACH LOGICAL RECORD IS 15 WORDS LONG.                RV.PV  02044000
         2) THE FIRST 12 WORDS ARE THE SAME AS THE FIRST 12 WORDS       02046000
            OF ENUM LOGICAL RECORDS.                                    02048000
         3) WORDS 12 & 13 (REL 0) ARE THE SAME AS THE LAST TWO WORDS    02050000
            OF A FILE DIRECTORY ENTRY ( FVOLPNTR & FILEBELPNTR).        02052000
            NOTE:  FVOLPNTR HAS BEEN CONVERTED TO A LOGICAL DEVICE      02054000
                   NUMBER SO THAT FSTORE AND UNLOCKSTORE DON'T HAVE     02056000
                   TO RECOMPUTE IT.  FILE IS LOCKED DOWN SO LDN WON'T   02058000
                   CHANGE.                                              02060000
         4) IF THE GROUP IS ASSIGNED TO A NON-SYSTEM VOLUME SET  RV.PV  02062000
            WORD 14 (REL 0) WILL CONTAIN "PVINFO" AS RETURNED    RV.PV  02064000
            FROM THE MOUNT (CONDITIONAL IN THIS CASE) FUNCTION.  RV.PV  02066000
            OTHERWISE, WORD 14 WILL BE SET TO ZERO (0).          RV.PV  02068000
                                                                     >> 02070000
<<*******************************************************************>> 02072000
<<                                                                      02074000
   THE ERROR FILE (ENUM) CONTAINS THE FOLLOWING TYPES OF ERRORS:        02076000
                                                                        02078000
                                                                        02080000
    ERROR CODE    DETAIL        DESCRIPTION                             02082000
    ----------    ------        -----------                             02084000
                                                                        02086000
       1         1=FILE         NAME NOT FOUND IN DIRECTORY             02088000
                 2=GROUP                                                02090000
                 3=ACCOUNT                                              02092000
                                                                        02094000
       3           0            THE REFERENCED FILE HAS AN ASSOCIATED   02096000
                                LOCKWORD, AND THE STORE COMMAND'S       02098000
                                FILESET LOCKWORD IS OMITTED OR DOES     02100000
                                NOT MATCH THE FILE'S.                   02102000
                                                                        02104000
       4           0            THE REFERENCED FILE CANNOT BE USED      02106000
                                BY STORE BECAUSE IT IS OPEN FOR         02108000
                                 WRITE.                                 02110000
                                                                        02112000
       5           0            FILE WITH NEGATIVE FILECODE AND USER    02114000
                                DOESN'T HAVE PRIVILEGED MODE            02116000
                                CAPABILITY.                             02118000
                                                                        02120000
      10         9=READ         ACCESS FAILURE.                         02122000
                                                                        02124000
      13         1=FILE         LABEL DEFECTIVE                         02126000
                                                                     >> 02128000
<<*******************************************************************>> 02130000
<<*******************************************************************>> 02132000
      BEGIN                                                             02134000
        EQUATE COMMA=0, EQSIGN=1, SEMIC=2, CR=3; <<POS IN DEL>><<C+.08>>02136000
        EQUATE MAXPARMS=100;          <<MAX # OF PARAMETERS>>           02138000
        EQUATE T1=MAXPARMS-1;                                           02140000
        INTEGER N, RSIZE;                                      <<02546>>02146000
        INTEGER NUMPARMS;             <<# OF PARAMETERS>>               02148000
        INTEGER DEVTYPE;  <<TAPE DEVICE FIRST, THEN LIST DEVICE<<04.RO>>02150000
        LOGICAL LDEV;                                          <<02562>>02152000
        LOGICAL FOPTIONS,AOPTIONS;                                      02154000
        LOGICAL                                                <<02558>>02158000
           SPEC'ENTRY := FALSE,                                <<02871>>02160000
           FSTORE'FLAG;    << Flag for 6250 BPI default case >><<02558>>02162000
        INTEGER                                                <<02558>>02164000
           MAX'RECSIZE,    << Maximum record size for device >><<02558>>02166000
           DENSITY,        << Mag tape density >>              <<02558>>02168000
           ERRNUM,                                             <<02558>>02170000
           STACK'INC;      << Stack space needed for buffer >> <<02558>>02172000
        BYTE ARRAY DESIG(0:9);                                          02174000
        DOUBLE ARRAY PARMS(0:T1);     <<PARAMETERS RETURNED BY MYCOM>>  02176000
        DOUBLE PRAM;                                                    02178000
        LOGICAL PTYPE=PRAM+1;        <<PARAMETER TYPE>>                 02180000
        DEFINE NEXTDELIM = PTYPE.(11:5)#;   <<DELIMITER FIELD>><<U.RAO>>02182000
        BYTE PL=PRAM+1;              <<PARAMETER LENGTH>>               02184000
        BYTE POINTER PR=PRAM;        <<PTR TO NEXT PARAMETER>>          02186000
      BYTE ARRAY GOOD(0:4),ERROR(0:5),LIST(0:7);               <<U.RAO>>02188000
BYTE ARRAY DELIMITERS(0:5);                                    <<00425>>02190000
INTEGER RECSIZE,MONTH,DAY,YEAR,PDATE:=0; <<STORE DATE IN ISTORE<<00425>>02192000
INTEGER ARRAY DAYSPERMONTH(1:12)=PB:=0,31,59,90,120,151,181,   <<00425>>02194000
                                 212,243,273,304,334;          <<00425>>02196000
        DOUBLE GNUMFSIZE := 4000D,                             <<C+.08>>02198000
               ENUMFSIZE = GNUMFSIZE;                          <<C+.08>>02200000
        DOUBLE IOB;                                            <<02518>>02202000
        INTEGER STATUS=IOB;                                    <<02518>>02204000
        INTEGER EFRCOUNT := 0, GFRCOUNT := 0;                           02206000
        INTEGER ARRAY RETVAL(*)=EFRCOUNT;                               02208000
        INTEGER OLDSIZE := 0,         <<OLD STACK SIZE>>                02210000
                OLDCRIT := 0,         << OLD CRITICAL STATE >>          02212000
                TNUM := 0,            <<TAPE FILE NUMBER>>              02214000
                GNUM := 0,           <<GOOD FILE NUMBER>>               02216000
                ENUM := 0,            <<ERROR FILE NUMBER>>             02218000
                PNUM := 0,           <<LIST FILE NUMBER>>               02220000
                TSAVE := 1;          << Tape disposition >>    <<02546>>02222000
        LOGICAL SHOWFLAG := FALSE;                                      02224000
        LOGICAL FILESFLAG := FALSE;                            <<C+.08>>02226000
INTEGER DATE:=0; <<<0 IMPLIES SAVE OLD, >0 IMPLIES SAVE NEW>>  <<00425>>02230000
                                                                        02232000
           <<-------------                                              02234000
             CLOSE FILES                                                02236000
           ------------->>                                              02238000
        SUBROUTINE SHUTFILES(NOSHUT);                                   02240000
        VALUE NOSHUT;                                                   02242000
        INTEGER NOSHUT;                                                 02244000
        COMMENT                                                         02246000
          CLOSE ALL FILES IF THEY ARE OPEN EXCEPT FOR THE ONE           02248000
        SPECIFIED BY NOSHUT (IT WILL BE CLOSED BY FERROR);              02250000
        BEGIN                                                           02252000
          IF ENUM<>0 AND ENUM<>NOSHUT THEN FCLOSE(ENUM,0,0);            02254000
          IF GNUM<>0 AND GNUM<>NOSHUT THEN FCLOSE(GNUM,0,0);            02256000
          IF TNUM<>0 AND TNUM<>NOSHUT THEN FCLOSE(TNUM,TSAVE,0);        02258000
          IF PNUM<>0 AND PNUM<>NOSHUT THEN FCLOSE(PNUM,0,0);            02260000
                                                                        02262000
      IF OLDSIZE<>0 THEN ZSIZE(OLDSIZE);<<RESTORE Z>>          <<00425>>02264000
          RESETCRITICAL(OLDCRIT);                                       02266000
          ASSEMBLE(EXIT 3);  <<BAIL OUT>>                      <<U.RAO>>02268000
        END <<SHUTFILES>> ;                                             02270000
<<&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&><<U.RAO>>02272000
<< This subroutine evaluates the double returned by PRINTDFILE.<<U.RAO>>02274000
<<&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&><<U.RAO>>02276000
SUBROUTINE EVALRETURN(B,A);                                    <<U.RAO>>02278000
VALUE B,A;                                                     <<U.RAO>>02280000
INTEGER B,A;                                                   <<U.RAO>>02282000
BEGIN                                                          <<U.RAO>>02284000
<<FIRST REPORT THE ERROR>>                                     <<U.RAO>>02286000
PNUMBER := 0;                                                  <<U.RAO>>02288000
IF A=0 THEN RETURN;   <<NO ERROR DETECTED>>                    <<U.RAO>>02290000
IF A=1 THEN   <<SCRATCH FILE ERROR - PUT MESSAGE BEFORE DEATH>><<U.RAO>>02292000
   BEGIN                                                       <<U.RAO>>02294000
   FERROR'(B, PNUMBER);                                        <<U.RAO>>02296000
   IF B=PNUM THEN   <<ON PRINT FILE>>                          <<U.RAO>>02298000
      CIERR(ENUMBER := STORBADSYSLIST)                         <<U.RAO>>02300000
   ELSE   <<MUST BE ON SCRATCH FILE>>                          <<U.RAO>>02302000
      CIERR(ENUMBER := STORSCRFLFSERR);                        <<U.RAO>>02304000
   END;                                                        <<U.RAO>>02306000
<<NOW QUIT PROCESSING>>                                        <<U.RAO>>02308000
SHUTFILES(-1);  <<CLOSE ALL FILES, RESET Z>>                   <<U.RAO>>02310000
ASSEMBLE(EXIT 3);                                              <<U.RAO>>02312000
END;   <<SUBROUTINE EVALRETURN>>                               <<U.RAO>>02314000
<<---------------------------------------------------->>       <<U.RAO>>02316000
<<      HANDLES TAPE ERRORS                           >>       <<U.RAO>>02318000
<<---------------------------------------------------->>       <<U.RAO>>02320000
SUBROUTINE TAPEERROR;                                          <<U.RAO>>02322000
BEGIN                                                          <<U.RAO>>02324000
UNLOCKSTORE(GNUM, TRUE);  <<UNLOCK FILES TO BE STORED>>        <<U.RAO>>02326000
FERROR'(TNUM, PNUMBER);   <<GIVE USER CAUSE OF ERROR>>         <<U.RAO>>02328000
CIERR(ENUMBER := STORTAPEFSERR);                               <<U.RAO>>02330000
SHUTFILES(TNUM);  <<NEVER RETURNS>>                            <<U.RAO>>02332000
END;                                                           <<U.RAO>>02334000
<<---------------------------------------------------->>       <<U.RAO>>02336000
<<  PARSES TAPE FILE NAME, RETURNS FALSE IF PROBLEM   >>       <<U.RAO>>02338000
<<---------------------------------------------------->>       <<U.RAO>>02340000
LOGICAL SUBROUTINE CHECKTAPENAME;                              <<U.RAO>>02342000
BEGIN                                                          <<U.RAO>>02344000
CHECKTAPENAME := FALSE;                                        <<U.RAO>>02346000
IF PL<>0 THEN   <<NAME PRESENT>>                               <<U.RAO>>02348000
   IF PR="*" THEN  <<IS BACK REFERENCED FILE NAME>>            <<U.RAO>>02350000
      IF PL<=9 THEN  <<LENGTH IS OK>>                          <<U.RAO>>02352000
         IF PR(1) = ALPHA THEN   <<NAME STARTS WITH ALPHA>>    <<U.RAO>>02354000
            BEGIN                                              <<U.RAO>>02356000
            DESIG := "*";                                      <<U.RAO>>02358000
            MOVE DESIG(1) := PR(1) WHILE AN,1;                 <<U.RAO>>02360000
            IF S0-@DESIG <> INTEGER(PL) THEN  <<EMBEDDED SPECIA<<U.RAO>>02362000
               BEGIN  <<SEND ERROR MESSAGE>>                   <<U.RAO>>02364000
               CIERR(ENUMBER := STORTAPEMBEDSPC,PR(S0-@DESIG));<<U.RAO>>02366000
               DEL;  <<POP POINTER>>                           <<U.RAO>>02368000
               END                                             <<U.RAO>>02370000
            ELSE                                               <<U.RAO>>02372000
               BEGIN  <<ALL OK, GET OUT OF HERE>>              <<U.RAO>>02374000
               BPS0 := " ";   <<TERMINATOR>>                   <<U.RAO>>02376000
               DEL;                                            <<U.RAO>>02378000
               CHECKTAPENAME := TRUE;                          <<U.RAO>>02380000
               END;                                            <<U.RAO>>02382000
            END                                                <<U.RAO>>02384000
         ELSE  <<FIRST CHAR NOT AN ALPHA>>                     <<U.RAO>>02386000
            CIERR(ENUMBER := STORTAPXPCTALPH, PR(1))           <<U.RAO>>02388000
      ELSE   <<NAME TOO LONG>>                                 <<U.RAO>>02390000
         CIERR(ENUMBER := STORTAPNAME2LNG, PR)                 <<U.RAO>>02392000
   ELSE   <<NAME NOT BACK REFERENCE>>                          <<U.RAO>>02394000
      CIERR(ENUMBER := STORXPCTBREFTAP, PR)                    <<U.RAO>>02396000
ELSE   <<MISSING TAPE FILE NAME>>                              <<U.RAO>>02398000
   CIERR(ENUMBER := STORREQTAPEFILE, PR);                      <<U.RAO>>02400000
END;                                                           <<U.RAO>>02402000
<<---------------------------------------------->>             <<U.RAO>>02404000
<<   Parse SHOW & FILES parameters.             >>             <<U.RAO>>02406000
<<   Return of false indicates parse failed.    >>             <<U.RAO>>02408000
<<---------------------------------------------->>             <<U.RAO>>02410000
LOGICAL SUBROUTINE PARSEOTHERPARMS;                            <<U.RAO>>02412000
BEGIN                                                          <<U.RAO>>02414000
PARSEOTHERPARMS := TRUE;  <<ASSUME NO PROBLEMS>>               <<U.RAO>>02416000
WHILE NEXTDELIM<>CR DO  <<LOOP OVER NEXT PARM>>                <<U.RAO>>02418000
   BEGIN                                                       <<U.RAO>>02420000
   IF NEXTDELIM <> SEMIC THEN   <<ILLEGAL DELIMITER BETWEEN>>  <<U.RAO>>02422000
      BEGIN   <<STORE KEYWORDS>>                               <<U.RAO>>02424000
      CIERR(ENUMBER := STORXPCTSEMIC, PR(INTEGER(PL)));        <<U.RAO>>02426000
      PARSEOTHERPARMS := FALSE;  <<FAIL ON SYNTAX ERROR>>      <<U.RAO>>02428000
      RETURN;                                                  <<U.RAO>>02430000
      END                                                      <<U.RAO>>02432000
   ELSE   <<HAVE PROPER FORM, AT LEAST>>                       <<U.RAO>>02434000
      BEGIN                                                    <<U.RAO>>02436000
      PRAM := PARMS(PNUMBER);                                  <<U.RAO>>02438000
      PNUMBER := PNUMBER+1;                                    <<U.RAO>>02440000
      IF PL=4 AND PR="SHOW" THEN   <<SHOW PARAMETER>>          <<U.RAO>>02442000
         SHOWFLAG := 1                                         <<U.RAO>>02444000
      ELSE IF PL=5 AND PR="FILES" THEN  <<FILES PARAMETER>>    <<U.RAO>>02446000
         BEGIN                                                 <<U.RAO>>02448000
         IF FILESFLAG THEN  <<REDUNDANT SPECIFICATION>>        <<U.RAO>>02450000
            CIERR(-STORREDUNDFILES, PR);                       <<U.RAO>>02452000
         FILESFLAG := TRUE;                                    <<U.RAO>>02454000
         IF NEXTDELIM <> EQSIGN THEN  <<MISSING COUNT>>        <<U.RAO>>02456000
            BEGIN                                              <<U.RAO>>02458000
            CIERR(ENUMBER := STORXPCTEQFILES, PR(INTEGER(PL)));<<U.RAO>>02460000
            PARSEOTHERPARMS := FALSE;                          <<U.RAO>>02462000
            RETURN;                                            <<U.RAO>>02464000
            END                                                <<U.RAO>>02466000
         ELSE   <<FILES COUNT IS THERE>>                       <<U.RAO>>02468000
            BEGIN                                              <<U.RAO>>02470000
            PRAM := PARMS(PNUMBER); <<GET VALUE>>              <<U.RAO>>02472000
            PNUMBER := PNUMBER+1;                              <<U.RAO>>02474000
            GNUMFSIZE := DBINARY(PR, PL);                      <<U.RAO>>02476000
            IF <> OR GNUMFSIZE <= 0D THEN                      <<U.RAO>>02478000
               BEGIN  <<FILES COUNT OUT OF BOUNDS>>            <<U.RAO>>02480000
               CIERR(STORXPCTFILECNT, PR);                     <<U.RAO>>02482000
               PARSEOTHERPARMS := FALSE;                       <<U.RAO>>02484000
               RETURN                                          <<U.RAO>>02486000
               END;                                            <<U.RAO>>02488000
            END;                                               <<U.RAO>>02490000
         END                                                   <<U.RAO>>02492000
      ELSE IF 4<=INTEGER(PL)<=5 AND PR="DATE" THEN<<DATE PARM>><<00425>>02494000
      BEGIN                                                    <<00425>>02496000
         IF DATE<>0 THEN CIERR(-STOREREDUNDDATE,PR);           <<00425>>02498000
         IF NEXTDELIM=EQSIGN AND PR(4)="<" THEN DATE:=-1       <<00425>>02500000
         ELSE IF NEXTDELIM=EQSIGN AND PR(4)=">" THEN DATE:=1   <<00425>>02502000
         ELSE  <<UNEXPECTED DELIMITER>>                        <<00425>>02504000
         BEGIN                                                 <<00425>>02506000
            CIERR(ENUMBER:=STORXPCTDATELTGT,PR(INTEGER(PL)));  <<00425>>02508000
            PARSEOTHERPARMS:=FALSE;                            <<00425>>02510000
            RETURN;                                            <<00425>>02512000
         END;                                                  <<00425>>02514000
         PRAM:=PARMS(PNUMBER);                                 <<00425>>02516000
         PNUMBER:=PNUMBER+1;                                   <<00425>>02518000
         IF CHECKEXPDATE(ENUMBER,PL,PR,MONTH,DAY,YEAR) THEN    <<00425>>02520000
         BEGIN <<FORMAT DATE INTO WHAT ISTORE LIKES>>          <<00425>>02522000
            PDATE.(0:7):=YEAR;                                 <<00425>>02524000
            PDATE.(7:9):=DAYSPERMONTH(MONTH)+DAY +             <<00425>>02526000
               (IF (YEAR MOD 4)=0 AND MONTH>2 THEN 1 ELSE 0);  <<00425>>02528000
         END                                                   <<00425>>02530000
         ELSE <<BAD DATE SPECIFIED..TELL TURKEY>>              <<00425>>02532000
         BEGIN                                                 <<00425>>02534000
            PARSEOTHERPARMS:=FALSE; <<CIERR ALREADY DONE>>     <<00425>>02536000
            RETURN;                                            <<00425>>02538000
         END;                                                  <<00425>>02540000
      END                                                      <<00425>>02542000
      ELSE IF PL <> 0 THEN  << UNKNOWN PARM>>                  <<U.RAO>>02544000
         BEGIN                                                 <<U.RAO>>02546000
         CIERR(ENUMBER := STORUNKOPTION, PR);                  <<U.RAO>>02548000
         PARSEOTHERPARMS := FALSE;                             <<U.RAO>>02550000
         RETURN                                                <<U.RAO>>02552000
         END;                                                  <<U.RAO>>02554000
      END;                                                     <<U.RAO>>02556000
   END;                                                        <<U.RAO>>02558000
END;   <<SUBROUTINE PARSEOTHERPARMS>>                          <<U.RAO>>02560000
<<=====================================================>>      <<U.RAO>>02562000
<<First step is to parse the parameters to the command.>>      <<U.RAO>>02564000
<<To begin with, we do crude check of command.         >>      <<U.RAO>>02566000
<<=====================================================>>      <<U.RAO>>02568000
MYCOMMAND(P,,MAXPARMS,NUMPARMS,PARMS);                         <<U.RAO>>02570000
IF <> THEN                                                     <<U.RAO>>02572000
   BEGIN   <<TOO MANY PARAMETERS FOR PARMS ARRAY>>             <<U.RAO>>02574000
   PNUMBER := MAXPARMS;                                        <<U.RAO>>02576000
   TOS := ENUMBER := STOR2MP;                                  <<U.RAO>>02578000
   TOS := PARMS(T1);                                           <<U.RAO>>02580000
   DEL;   <<JUST GET BYTE ADDR OF MAXPARM'TH PARM>>            <<U.RAO>>02582000
   CIERR(*, *, %10000, MAXPARMS);                              <<U.RAO>>02584000
   RETURN;                                                     <<U.RAO>>02586000
   END;                                                        <<U.RAO>>02588000
PNUMBER := 0;                                                  <<U.RAO>>02590000
IF NUMPARMS < 2 THEN  <<MISSING TAPE NAME, AT LEAST>>          <<U.RAO>>02592000
   BEGIN                                                       <<U.RAO>>02594000
   CIERR(ENUMBER := STOR'XPCT'TAPE, P);                        <<U.RAO>>02596000
   RETURN;                                                     <<U.RAO>>02598000
   END;                                                        <<U.RAO>>02600000
<<---------------------------------------------------->>       <<U.RAO>>02602000
<<   Scan through fileset list for crude parse.       >>       <<U.RAO>>02604000
<<   Detailed parse later in ISTORE.                  >>       <<U.RAO>>02606000
<<---------------------------------------------------->>       <<U.RAO>>02608000
DO BEGIN   <<LOOP THROUGH FILE SETS>>                          <<U.RAO>>02610000
   PRAM := PARMS(PNUMBER);                                     <<U.RAO>>02612000
   PNUMBER := PNUMBER+1;                                       <<U.RAO>>02614000
   END UNTIL NEXTDELIM <> COMMA;                               <<U.RAO>>02616000
IF NEXTDELIM = EQSIGN THEN   <<STRANGE SYNTAX>>                <<U.RAO>>02618000
   BEGIN                                                       <<U.RAO>>02620000
   TOS := ENUMBER := STORUNXPCTEQFST;  <<UNEXPECTED = IN FILESE<<U.RAO>>02622000
   TOS := @PR+INTEGER(PL);                                     <<U.RAO>>02624000
   CIERR(*,*);                                                 <<U.RAO>>02626000
   RETURN                                                      <<U.RAO>>02628000
   END;                                                        <<U.RAO>>02630000
<<---------------------------------------------------->>       <<U.RAO>>02632000
<<    Have finished filesets, now look at tape name   >>       <<U.RAO>>02634000
<<---------------------------------------------------->>       <<U.RAO>>02636000
IF NEXTDELIM = CR THEN   <<MISSING TAPE FILE NAME>>            <<U.RAO>>02638000
   BEGIN                                                       <<U.RAO>>02640000
   TOS := ENUMBER := STOR'XPCT'TAPE;                           <<U.RAO>>02642000
   TOS := @PR+INTEGER(PL)+1;                                   <<U.RAO>>02644000
   CIERR(*,*);                                                 <<U.RAO>>02646000
   RETURN;                                                     <<U.RAO>>02648000
   END;                                                        <<U.RAO>>02650000
PRAM := PARMS(PNUMBER);  <<GET TAPE NAME PARM>>                <<U.RAO>>02652000
PNUMBER := PNUMBER+1;                                          <<U.RAO>>02654000
IF NOT CHECKTAPENAME <<PARSE TAPE NAME>>                       <<U.RAO>>02656000
   OR NOT PARSEOTHERPARMS  THEN RETURN;                        <<U.RAO>>02658000
PNUMBER := 0;                                                  <<U.RAO>>02660000
<<====================================================>>       <<U.RAO>>02662000
<< This concludes the parse.  If we made it this far, >>       <<U.RAO>>02664000
<< the rough outline of the command is good.  Some    >>       <<U.RAO>>02666000
<< parsing is done in ISTORE, and of course FOPEN may >>       <<U.RAO>>02668000
<< find some problem in the tape file name.  The next >>       <<U.RAO>>02670000
<< step is to set up the environment of the store by  >>       <<U.RAO>>02672000
<< opening two scratch files and allocating the needed>>       <<U.RAO>>02674000
<< stack.                                             >>       <<U.RAO>>02676000
<<====================================================>>       <<U.RAO>>02678000
IF REQUESTSERVICE THEN RETURN;   <<SAW A BREAK>>               <<U.RAO>>02680000
OLDCRIT := SETCRITICAL;  <<NO ABORTS ALLOWED IN HERE>>         <<06.RO>>02682000
MOVE ERROR := "ERROR ";                                        <<U.RAO>>02684000
ENUM := FOPEN(ERROR, %2000,<<NO FEQ, NOCCTL, FIXED, BINARY, NEW<<U.RAO>>02686000
              %104,<<WAIT, NOMULTI, BUF, EXCL, NOMR, READ/WRITE<<U.RAO>>02688000
              14 <<RECSIZE>>, <<DISC>>, <<NO FORMS>>,,<<NOLABEL<<U.RAO>>02690000
              9 <<BLOCKFACTOR>>, 1 <<BUFFER>>,                 <<U.RAO>>02692000
              ENUMFSIZE <<# RECORDS>>, 16 <<EXTENTS>>,         <<U.RAO>>02694000
              (IF FILESFLAG THEN 16 ELSE 1) <<INITALLOC>>);    <<U.RAO>>02696000
IF <> THEN   <<OPEN FAILED ON SCRATCH FILE>>                   <<U.RAO>>02698000
   BEGIN                                                       <<U.RAO>>02700000
   RESETCRITICAL(OLDCRIT);                                     <<U.RAO>>02702000
   FERROR'(ENUM, PNUMBER);                                     <<U.RAO>>02704000
   CIERR(ENUMBER := STORSCRFLFSERR);                           <<U.RAO>>02706000
   RETURN;                                                     <<U.RAO>>02708000
   END;                                                        <<U.RAO>>02710000
MOVE GOOD := "GOOD ";                                          <<U.RAO>>02712000
GNUM:=FOPEN <<SAME AS ERROR FILE>> (GOOD,%2000,%105,15,,,,9,1, <<RV.RS>>02714000
              GNUMFSIZE, 16, (IF FILESFLAG THEN 16 ELSE 1));   <<U.RAO>>02716000
IF <> THEN   <<OPEN FAILED ON "GOOD" FILE>>                    <<U.RAO>>02718000
   BEGIN                                                       <<U.RAO>>02720000
   FERROR'(GNUM, PNUMBER);                                     <<U.RAO>>02722000
   CIERR(ENUMBER := STORSCRFLFSERR);                           <<U.RAO>>02724000
   SHUTFILES(GNUM);  <<NEVER RETURNS, BY THE WAY>>             <<U.RAO>>02726000
   END;                                                        <<U.RAO>>02728000
<<-------------------------------------------------------->>   <<U.RAO>>02730000
<< Finished opening scratch files.  Now we go off to      >>   <<U.RAO>>02732000
<< ISTORE where the file sets get fully parsed, opened,   >>   <<U.RAO>>02734000
<< set busy, and their names and addresses put in GOOD.   >>   <<U.RAO>>02736000
<<-------------------------------------------------------->>   <<U.RAO>>02738000
TOS:=ISTORE(P,ENUM,GNUM,PDATE,RETVAL,-32768,32767,1-DATE);     <<00425>>02740000
ENUMBER := TOS;                                                <<U.RAO>>02742000
PNUMBER := TOS;                                                <<U.RAO>>02744000
IF ENUMBER<>0 THEN SHUTFILES(-1);  <<BAIL OUT>>                <<U.RAO>>02746000
IF GFRCOUNT <> 0 THEN  <<SOME FILES CAN BE STORED>>            <<U.RAO>>02748000
   BEGIN                                                       <<U.RAO>>02750000
   <<------------------------------------------------>>        <<U.RAO>>02752000
   << Open tape, check its characteristics.          >>        <<U.RAO>>02754000
   <<------------------------------------------------>>        <<U.RAO>>02756000
   RSIZE    := 4096;  << Default record size >>                <<02558>>02760000
   FOPTIONS := %200;  << FEQ,NOCCTL,UNDEF,BINARY,NEW >>        <<02518>>02762000
   AOPTIONS := %101;  << WAIT,NOMULTI,BUF,EXCL,NOMR,WRITE >>   <<02518>>02764000
   TNUM := FOPEN(DESIG,FOPTIONS,AOPTIONS,RSIZE);               <<02518>>02766000
   IF <> THEN   <<TAPE OPEN FAILED>>                           <<U.RAO>>02768000
      TAPEERROR;   <<NEVER RETURNS>>                           <<U.RAO>>02770000
   FGETINFO(TNUM,,FOPTIONS,AOPTIONS,RECSIZE,DEVTYPE,LDEV);     <<02562>>02772000
   IF <> THEN TAPEERROR;                                       <<U.RAO>>02774000
   IF (FOPTIONS LAND %2777) <> %200 THEN <<FILE OPTNS BAD>>    <<00615>>02780000
      BEGIN                                                    <<U.RAO>>02782000
XF:   UNLOCKSTORE(GNUM,TRUE);                                  <<02546>>02784000
      CIERR(ENUMBER := STORTFILFOPTION);                       <<U.RAO>>02786000
      SHUTFILES(-1);                                           <<U.RAO>>02788000
      END                                                      <<U.RAO>>02790000
   ELSE IF (AOPTIONS LAND %177377)<>%101 THEN                           02792000
      BEGIN     << AOPTIONS bad >>                                      02796000
      UNLOCKSTORE(GNUM, TRUE);                                 <<U.RAO>>02798000
      CIERR(ENUMBER := STORTFILAOPTION);                       <<U.RAO>>02800000
      SHUTFILES(-1)                                            <<U.RAO>>02802000
      END                                                      <<U.RAO>>02804000
   ELSE IF DEVTYPE.(8:8)<>24 AND DEVTYPE.(8:8)<>SDISC THEN     <<SD.00>>02808000
      <<NOT TAPE OR SERIAL DISC>>                              <<SD.00>>02810000
      BEGIN                                                    <<U.RAO>>02812000
      UNLOCKSTORE(GNUM, TRUE);                                 <<U.RAO>>02814000
      CIERR(ENUMBER := STORXPCTTAPEDEV);                       <<U.RAO>>02816000
      SHUTFILES(-1);                                           <<U.RAO>>02818000
      END;                                                     <<02558>>02820000
   << Can't STORE to a remote labelled tape. >>                <<02649>>02822000
   IF DEVTYPE.DTYPE = MAGTAPE AND LABELED AND VIRTDEV THEN     <<02649>>02824000
      BEGIN                                                    <<02649>>02826000
      UNLOCKSTORE(GNUM,TRUE);                                  <<02649>>02828000
      CIERR(ENUMBER := REMOTELBLINVAL);                        <<02649>>02830000
      SHUTFILES(-1);            << Doesn't return. >>          <<02649>>02832000
      END;                                                     <<02649>>02834000
   << Determine the store device characteristics. >>           <<02558>>02838000
   IF DEVTYPE.DTYPE = SDISC THEN                               <<02558>>02840000
      MAX'RECSIZE := 8192                                      <<02558>>02842000
   ELSE                                                        <<02558>>02844000
      << Get the max. record size and density for tapes. >>    <<02558>>02846000
      IF NOT GET'TAPE'INFO(TNUM,MAX'RECSIZE,DENSITY)           <<02558>>02848000
         THEN TAPEERROR;     << Error handler never returns. >><<02558>>02850000
                                                               <<02558>>02852000
   IF NOT (256 <= RECSIZE <= MAX'RECSIZE) OR                   <<02558>>02854000
      (RECSIZE MOD 256) <> 0 THEN                              <<02558>>02856000
      BEGIN  << RECSIZE must be multiple of 256 and <= max >>  <<02558>>02858000
      UNLOCKSTORE(GNUM,TRUE);                                  <<02558>>02860000
      CIERR(ENUMBER := STORRECSIZEBAD,,%10000,MAX'RECSIZE);    <<02558>>02862000
      SHUTFILES(-1);   << Doesn't return >>                    <<02558>>02864000
      END;                                                     <<02558>>02866000
                                                               <<02558>>02868000
   << Do KLUDGE for 6250 BPI default case >>                   <<02558>>02870000
   SETUP'FLAGS(TNUM,DENSITY,DESIG,FSTORE'FLAG,ERRNUM);         <<02558>>02872000
   IF ERRNUM <> 0 THEN                                         <<02558>>02874000
      BEGIN    << Some sort of error >>                        <<02558>>02876000
      IF ERRNUM < 0 THEN                                       <<02558>>02878000
         TAPEERROR       << File error on TNUM.  No return >>  <<02558>>02880000
      ELSE                                                     <<02558>>02882000
         BEGIN           << XRETPMASK failed >>                <<02558>>02884000
         UNLOCKSTORE(GNUM,TRUE);                               <<02558>>02886000
         CIERR(ENUMBER := XRETPMASKFAIL);                      <<02558>>02888000
         SHUTFILES(-1);  << Doesn't return >>                  <<02558>>02890000
         END;                                                  <<02558>>02892000
      END;                                                     <<02558>>02894000
                                                               <<02558>>02896000
   IF NOT LABELED THEN                                         <<02546>>02898000
      BEGIN    << Unlabeled: start first reel with 2 EOF's. >> <<02546>>02900000
      FCONTROL(TNUM, WEOF, N);                                 <<02546>>02902000
      IF <> THEN TAPEERROR;                                    <<02546>>02904000
      FCONTROL(TNUM, WEOF, N);                                 <<02546>>02906000
      IF <> THEN TAPEERROR;                                    <<02546>>02908000
      END;                                                     <<02546>>02910000
                                                               <<02546>>02912000
   << Increase stack Z to make room for tape buffer.  When >>  <<02558>>02914000
   << using ATTACHIO, need at most 4096 words. >>              <<02558>>02916000
   STACK'INC := RECSIZE;                                       <<02558>>02918000
   IF (STACK'INC > 4096) AND USING'ATTIO THEN                  <<02617>>02920000
      STACK'INC := 4096;                                       <<02617>>02922000
                                                               <<02546>>02924000
   PUSH(Z);                                                    <<02546>>02926000
   OLDSIZE := TOS;    << Save old Z for restoration >>         <<02546>>02928000
   PUSH(S);                                                    <<02546>>02930000
   ZSIZE(S0 + STACK'INC + 2048);                               <<02558>>02932000
   IF <> AND NOT JOBSESSIONMAIN THEN                           <<02546>>02934000
      BEGIN      << No room and not JS Main; quit. >>          <<02546>>02936000
      ENUMBER := STORINSUFSTACK;                               <<02546>>02940000
      UNLOCKSTORE(GNUM,TRUE);                                  <<02546>>02942000
      SHUTFILES(-1);                                           <<02546>>02944000
      END;                                                     <<02546>>02946000
   <<------------------------------------------------>>        <<02546>>02948000
   << Files parsed, put in file GOOD, tape open,     >>        <<02546>>02950000
   << first EOFs written.  Now put files on tape.    >>        <<02546>>02952000
   <<------------------------------------------------>>        <<02546>>02954000
   TOS := FSTORE( IF FSTORE'FLAG THEN -TNUM                    <<02558>>02956000
                                 ELSE  TNUM , GNUM );          <<02558>>02958000
   ENUMBER := TOS;                                             <<02546>>02960000
   PNUMBER := TOS;                                             <<02546>>02962000
   IF ENUMBER <> 0 THEN SHUTFILES(-1);  << Serious failure. >> <<02546>>02964000
   IF NOT LABELED THEN                                         <<02546>>02966000
      BEGIN         << Unlabeled: rewind/unload. >>            <<02546>>02968000
      FCONTROL(TNUM,REWUNLOAD,N);                              <<02546>>02970000
      IF <> THEN TAPEERROR;                                    <<02546>>02972000
      END;                                                     <<02546>>02974000
   FCLOSE(TNUM,1,0);                                           <<02546>>02976000
   TNUM := 0;   << Inhibit any future FCLOSE to tape >>        <<02546>>02978000
   END;                                                        <<02546>>02980000
<<===================================================>>        <<U.RAO>>02982000
<< The tape has been written and is rewinding.  It   >>        <<U.RAO>>02984000
<< only remains to do the fairly trivial task of     >>        <<U.RAO>>02986000
<< printing out the status information.              >>        <<U.RAO>>02988000
<<===================================================>>        <<U.RAO>>02990000
MOVE LIST := "SYSLIST ";                                       <<U.RAO>>02992000
PNUM := FOPEN(LIST, %514,<<FEQ, CCTL, VAR, $STDLIST, ASCII, NEW<<U.RAO>>02994000
           2 <<WAIT, NOMULTI, BUF, NOMR, WRITE(SAVE)>>, -72);  <<U.RAO>>02996000
IF <> THEN   <<OPEN FAILED ON LIST FILE>>                      <<U.RAO>>02998000
   BEGIN                                                       <<U.RAO>>03000000
   FERROR'(PNUM, PNUMBER);                                     <<U.RAO>>03002000
   CIERR(ENUMBER := -STORBADSYSLIST);                          <<U.RAO>>03004000
   IF JOBSESSIONMAIN THEN  <<FORCE TO FILE 2, $STDLIST>>       <<U.RAO>>03006000
      PNUM := 2  <<AND GO ON WITH LISTING>>                    <<U.RAO>>03008000
   ELSE   <<FATAL ERROR>>                                      <<U.RAO>>03010000
      SHUTFILES(-1);                                           <<U.RAO>>03012000
   END;                                                        <<U.RAO>>03014000
IF SHOWFLAG THEN                                               <<04.RO>>03016000
   BEGIN  <<POSSIBLY TIME STAMP FILE LIST>>                    <<04.RO>>03018000
   FGETINFO(PNUM,,,,,DEVTYPE);                                 <<04.RO>>03020000
   IF DEVTYPE.(8:8) >= 8 THEN  <<NOT DISC>>                    <<04.RO>>03022000
      BEGIN                                                    <<04.RO>>03024000
      DATE'LINE(PARMS);                                        <<04.RO>>03026000
      FWRITE(PNUM, PARMS, -27, %60);                           <<04.RO>>03028000
      END                                                      <<04.RO>>03030000
   END;                                                        <<04.RO>>03032000
MOVE DESIG := "STORED ";                                       <<U.RAO>>03034000
TOS := PRINTDFILE(PNUM,GNUM,GFRCOUNT,1,DESIG,SHOWFLAG);        <<U.RAO>>03036000
EVALRETURN(*,*);                                               <<U.RAO>>03038000
TOS := PRINTDFILE(PNUM,ENUM,EFRCOUNT,0,DESIG,SHOWFLAG);        <<U.RAO>>03040000
EVALRETURN(*,*);                                               <<U.RAO>>03042000
SHUTFILES(-1);   <<ALL OF THEM>>                               <<U.RAO>>03044000
END <<CXSTORE>> ;                                              <<U.RAO>>03046000
$PAGE "ISTORE  --  PRODUCE LIST OF FILES TO BE STORED"                  03048000
$CONTROL SEGMENT=STORE                                                  03050000
   DOUBLE PROCEDURE ISTORE(PTR,ENUM,GNUM,PDATE,RETVAL,FCLLIM,           03052000
                           FCULIM,FLAG);                                03054000
      VALUE ENUM,GNUM,PDATE,FCLLIM,FCULIM,FLAG;                         03056000
      INTEGER ENUM,GNUM,FCLLIM,FCULIM;                                  03058000
      BYTE ARRAY PTR;                                                   03060000
      INTEGER ARRAY RETVAL;                                             03062000
      LOGICAL PDATE,FLAG;                                               03064000
      OPTION PRIVILEGED,UNCALLABLE;                                     03066000
<<*******************************************************************>> 03068000
<<                                                                   >> 03070000
<<   THE FUNCTION OF ISTORE IS:                                      >> 03072000
<<                                                                   >> 03074000
<<      1) PER FILESET PARM  IN PTR                                  >> 03076000
<<                                                                   >> 03078000
<<           A) CALL PRODUCEPARMS TO VALIDATE AND PRODUCE RESULT     >> 03080000
<<              ARRAY WHICH IS PASSED TO DIRECSCAN.                  >> 03082000
<<                                                                   >> 03084000
<<           B) CALL DIRECSCAN. FOR A SINGLE CALL OF DIRECSCAN,      >> 03086000
<<              WHICH HAS A PROCEDURE NAME (SAY X) AS ONE PARAMETER, >> 03088000
<<              DIRECSCAN WILL INVOKE X ONCE PER FILE FOUND. SEE THE >> 03090000
<<              TABLE IN RCSTORE FOR DETAILS.                        >> 03092000
<<                                                                   >> 03094000
<<      2) WRITE AN ENTRY ON ENUM FILE FOR EACH FILE THAT DIRECSCAN  >> 03096000
<<         CANNOT FIND IN THE DIRECTORY.                             >> 03098000
<<                                                                   >> 03100000
<<*******************************************************************>> 03102000
<<                                                                      03104000
       PROCEDURE ISTORE PARAMETERS:                                     03106000
                                                                        03108000
          PTR     A BYTE ARRAY CONTAINING A LIST OF FILESET             03110000
                  SPECIFICATIONS, SEPARATED BY COMMAS. THE LAST         03112000
                  FILESET SPECIFICATION MUST BE FOLLOWED BY A           03114000
                  SEMICOLON.                                            03116000
                                                                        03118000
          ENUM    THE FILE NUMBER OF AN OPEN FILE WHICH WILL            03120000
                  CONTAIN THE NAMES OF DISK FILES THAT STORE WILL       03122000
                  NOT DUMP.                                             03124000
                                                                        03126000
          GNUM    THE FILE NUMBER OF AN OPEN FILE WHICH WILL CONTAIN    03128000
                  THE NAMES OF ALL DISK FILES DUMPED BY STORE.          03130000
                                                                        03132000
          PDATE   THE DATE THE OLDEST FILE TO BE DUMPED WAS LAST        03134000
                  CHANGED.  THE FORMAT IS PDATE.(0:7) = YEAR,           03136000
                  PDATE.(7:9) = JULIAN DATE.                            03138000
                  BUT .. IF FLAG.(14:1) = 1 THEN THE DATE THE           03140000
                  NEWEST FILE TO BE DUMPED WAS LAST ACCESSED.           03142000
                                                                        03144000
          RETVAL  (0)--# OF RECORDS IN ENUM                             03146000
                  (1)--# OF RECORDS IN GNUM.                            03148000
                                                                        03150000
          FCLLIM  LOWEST VALUE OF FILECODE TO BE DUMPED                 03152000
                                                                        03154000
          FCULIM  HIGHEST VALUE OF FILECODE TO BE DUMPED                03156000
                                                                        03158000
          FLAG    .(15:1)=1 SAYS IGNORE PRIVILEGED MODE CHECK FOR       03160000
                  FILES WITH NEGATIVE FILECODES.                        03162000
                  .(0:1)=1 SAYS SS OR SM PRESUMED.                      03164000
                  .(14:1)=1 SAYS REVERSE SENSE OF PDATE.                03166000
                                                                        03168000
       SEE CXSTORE FOR ISTORE RETURNS                                   03170000
                                                                     >> 03172000
<<------------------------------------------------------------------->> 03174000
<<                                                                   >> 03176000
<<    PRODUCEPARMS RETURNS:         -1  =  NULL FILESET              >> 03178000
<<                                   0  =  OKAY                      >> 03180000
<<                                  +1  =  SYNTAX ERROR              >> 03182000
<<                                                                   >> 03184000
<<    DIRECSCAN RETURNS:                                             >> 03186000
<<                            CCE  =   SUCCESSFUL                    >> 03188000
<<     A=S-0                  CCL  =   I/O ERROR                     >> 03190000
<<     B=S-1                  CCG  =   NON-EXISTENT NAME (A=2 AND    >> 03192000
<<                                      B=0,1,2,3 FOR FILE,GROUP,    >> 03194000
<<                                      ACCT,USER.)                  >> 03196000
<<                                                                   >> 03198000
<<------------------------------------------------------------------->> 03200000
<<                                                                   >> 03202000
<<    PRODUCEPARMS, WHEN GIVEN A NULL FILESET PARAMETER BY LISTF     >> 03204000
<<    OR STORE COMMAND, WILL RETURN THE EQUIVLENT OF THE DEFAULT     >> 03206000
<<    FILESET "@" IN THE RESULT ARRAY.                               >> 03208000
<<                                                                   >> 03210000
<<------------------------------------------------------------------->> 03212000
<<******************************************************************>>  03214000
<<                                                                      03216000
       INTEGER ARRAY PARMS     **************************               03218000
                            0  *    ENUM                *               03220000
                               **************************               03222000
                            1  *    GNUM                *               03224000
                               **************************               03226000
                            2  *    PDATE               *               03228000
                               **************************               03230000
                            3  *  FILESET  NUMBER       *               03232000
              ************************************************          03234000
              *             4  *        MODE (WHO)      *               03236000
              *                **************************               03238000
              *             5  *    CAPABILITY (WHO)    *               03240000
              *             6  *                        *               03242000
              *                **************************               03244000
              *             7  *                        *               03246000
              *             8  *    USERN    (WHO)      *               03248000
              *             9  *                        *               03250000
                           10  *                        *               03252000
            WHO                **************************               03254000
                           11  *                        *               03256000
              *            12  *    GROUPN  (WHO)       *               03258000
              *            13  *                        *               03260000
              *            14  *                        *               03262000
              *                **************************               03264000
              *            15  *                        *               03266000
              *            16  *     ACCTN   (WHO)      *               03268000
              *            17  *                        *               03270000
              *            18  *                        *               03272000
              *                **************************               03274000
              *            19  *                        *               03276000
              *            20  *     HOMEN   (WHO)      *               03278000
              *            21  *                        *               03280000
              *            22  *                        *               03282000
              ************************************************          03284000
              *            23  *      TYPE              *  R(0)         03286000
              *                **************************               03288000
              *            24  *      LINKAGE'INDEXP    *  R(1)         03290000
              *            25  *                        *               03292000
              *                **************************               03294000
              *            26  *                        *  R(3)         03296000
              *            27  *    ACCTNAME            *               03298000
              *            28  *     (OR BLANK)         *               03300000
              *            29  *                        *               03302000
              *                **************************               03304000
              *            30  *                        *  R(7)         03306000
              *            31  *     GROUPNAME          *               03308000
                           32  *      (OR BLANK)        *               03310000
        RESULT ARRAY       33  *                        *               03312000
           FROM                **************************               03314000
        PRODUCEPARMS       34  *                        *  R(11)        03316000
                           35  *     FILENAME           *               03318000
              *            36  *       (OR BLANK)       *               03320000
              *            37  *                        *               03322000
              *                **************************               03324000
              *            38  *  DELIMITER  (BYTE)     *  R(15)        03326000
              *                **************************               03328000
              *            39  * PTR TO NEXT PARM       *  R(16)        03330000
              *                **************************               03332000
              *            40  *                        *  R(17)        03334000
              *            41  *     LOCKWORD           *               03336000
              *            42  *      (OR BLANK)        *               03338000
              *            43  *                        *               03340000
              ************************************************          03342000
              *            44  * NO. RECORDS ON ENUM    *               03344000
              *                **************************               03346000
                           45  * NO. RECORDS ON GNUM    *               03348000
            MISC               **************************               03350000
                           46  * RCSTORE-TO-ISTORE ARET *               03352000
              *                **************************               03354000
              *            47  * RCSTORE-TO-ISTORE BRET *               03356000
              *                **************************               03358000
              *            48  * # TIMES RCSTORE INVOKED*               03360000
              *                **************************               03362000
              *            49  * FILE CODE LOWER LIMIT  *               03364000
              *                **************************               03366000
              *            50  * FILE CODE UPPER LIMIT  *               03368000
              *                **************************               03370000
              *            51  * FLAG                   *               03372000
              *                **************************               03374000
              *            52  * FLAB SIR RETURN        *               03376000
              *                **************************               03378000
              *            53  *    GROUP               *               03380000
              *            54  *        SECURITY        *               03382000
              *                **************************               03384000
              *            55  *  ACCOUNT SECURITY      *               03386000
              *                **************************               03388000
              *            56  *    COLD LOAD ID        *               03390000
              *                **************************               03392000
              *            57  * MOUNTED VOL TAB INX    *               03394000
              *                **************************               03396000
              *             58 * ?? SP.PV ??           *       16JAN77  03398000
              *                *************************       16JAN77  03400000
              *******************************************               03402000
                                                                    >>  03404000
                                                              <<00.GEN>>03406000
  COMMENT:                                                    <<00.GEN>>03408000
    IN ORDER TO IMPLEMENT THE GENERIC NAME FEATURE IN         <<00.GEN>>03410000
    SHORT-ORDER (1 DAY!), WE INTRODUCE THE FOLLOWING          <<00.GEN>>03412000
    KLUDGES (TO BE CLEANED UP WITHIN 14 DAYS):                <<00.GEN>>03414000
                                                              <<00.GEN>>03416000
    (A) "PARMS" HAS BEEN EXTENDED BY 12 WORDS AT THE END      <<00.GEN>>03418000
        TO CONTAIN THE GENERIC NAMES SPECIFIED ("G'..."       <<00.GEN>>03420000
        IN "PRODUCEPARMS" RESULT)                             <<00.GEN>>03422000
                                                              <<00.GEN>>03424000
    (B) "PPRESULT" (RETURNED BY "PRODUCEPARMS") IS            <<00.GEN>>03426000
        DISTRIBUTED INTO "PARMS" IN ORDER TO RETAIN ITS       <<00.GEN>>03428000
        CURRENT STRUCTURE                                     <<00.GEN>>03430000
                                                              <<00.GEN>>03432000
    THE INTENTION IN THE FUTURE IS TO:                        <<00.GEN>>03434000
                                                              <<00.GEN>>03436000
    (A) RESTRUCTURE "PARMS" SO THAT THE "PRODUCEPARMS"        <<00.GEN>>03438000
        RESULTS ARE TOGETHER AT THE END OF "PARMS".  THUS,    <<00.GEN>>03440000
        "PARMS" WOULD BE EXTENDED AT BOTH ENDS WITH FEW       <<00.GEN>>03442000
        CHANGES                                               <<00.GEN>>03444000
                                                              <<00.GEN>>03446000
    (B) ACCESS "PARMS" ENTIRELY VIA MNEMONIC VALUES           <<00.GEN>>03448000
        (EQUATE'S & DEFINE'S).  THUS, FUTURE EXTENSIONS       <<00.GEN>>03450000
        CAN BE INCORPORATED MORE EASILY.                      <<00.GEN>>03452000
                                                              <<00.GEN>>03454000
    (C) DECLARE "PARMS" AS AN INDIRECT ARRAY TO AVOID         <<00.GEN>>03456000
        CHEWING UP PRECIOUS DIRECTLY-ACCESSIBLE Q-            <<00.GEN>>03458000
        RELATIVE LOCATIONS (OR AT LEAST DECLARE "PARMS"       <<00.GEN>>03460000
        LAST!);                                               <<00.GEN>>03462000
                                                              <<00.GEN>>03464000
<<*******************************************************************>> 03466000
  BEGIN                                                                 03468000
                                                              <<00.GEN>>03470000
   DEFINE P'TYPE=     PARMS(23) #,                            <<00.GEN>>03472000
          P'INX1=     PARMS(24) #,                            <<00.GEN>>03474000
          P'DELIM=    PARMS(38) #,                            <<00.GEN>>03476000
          P'NEXT=     PARMS(39) #,                            <<00.GEN>>03478000
          P'LOCKWORD= PARMS(40) #,                            <<00.GEN>>03480000
          P'GFNAME=   PARMS(ST'PPRINX) #;                     <<00.GEN>>03482000
   INTEGER BRET=ISTORE, ARET=ISTORE+1;                                  03484000
   INTEGER ARRAY PARMS (0:ST'PARMLEN-1)= Q;                   <<00.GEN>>03486000
   INTEGER ARRAY PARMS'PPR(*)= PARMS(ST'PPRINX);              <<00.GEN>>03488000
   INTEGER ARRAY PPRESULT(0:PPR'LEN-1);                       <<00.GEN>>03490000
   INTEGER EFRCOUNT = PARMS+44;                                <<38.PV>>03492000
   LOGICAL MODE=PARMS+4;                                                03494000
   DOUBLE CAPABILITY=PARMS+5;                                           03496000
   LOGICAL ATTRIB = PARMS+5;                                            03498000
   INTEGER ARRAY EBUF(0:13);                                            03500000
   BYTE ARRAY BEBUF(*) = EBUF;                                 <<U.RAO>>03502000
   INTEGER K:=0;                                                        03504000
   INTEGER MVTABX := 0;                                        <<PV.PV>>03506000
   INTEGER ARRAY R(*)=PARMS(23);                                        03508000
   BYTE ARRAY USERN(*)  =PARMS(7);                                      03510000
   BYTE ARRAY GROUPN(*)  =PARMS(11);                                    03512000
   BYTE ARRAY ACCTN(*)  =PARMS(15);                                     03514000
   BYTE ARRAY HOMEN(*)  =PARMS(19);                                     03516000
   BYTE POINTER FILESET;                                                03518000
   BYTE POINTER DELIM;                                        <<00.GEN>>03520000
   DOUBLE DR;   INTEGER DRB=DR, DRA=DR+1;                               03522000
LOGICAL FAKE'CONTINUE := FALSE;  <<ERROR HANDLING KLUDGE STATE><<U.RAO>>03524000
<<*******************************************************************>> 03526000
<<    SUBROUTINE TO RESET SYSTEM MANAGER BIT IN PCBX.                >> 03528000
<<*******************************************************************>> 03530000
   SUBROUTINE RESET;                                                    03532000
   BEGIN                                                                03534000
          IF ATTRIB.(5:1) AND NOT ATTRIB.(0:1) THEN                     03536000
       BEGIN                                                            03538000
          PUSH(DL);                                                     03540000
          X := TOS-PS0(-1).(4:12);  <<DISPLACEMENT OF PCBX>>            03542000
              DB2(X).(0:1) := 0;                                        03544000
        END;                                                            03546000
   END <<RESET>> ;                                                      03548000
                                                              <<00.GEN>>03550000
<<**************************>>                                <<00.GEN>>03552000
<<  SUBROUTINE FIXUP'PARMS  >>                                <<00.GEN>>03554000
<<**************************>>                                <<00.GEN>>03556000
                                                              <<00.GEN>>03558000
SUBROUTINE FIXUP'PARMS;                                       <<00.GEN>>03560000
BEGIN                                                         <<00.GEN>>03562000
  P'TYPE:=D'TYPE;                                             <<00.GEN>>03564000
  MOVE P'INX1:=D'INX1,(2),2;                                  <<00.GEN>>03566000
  MOVE * := D'ANAME,(4),2;                                    <<00.GEN>>03568000
  MOVE * := D'GNAME,(4),2;                                    <<00.GEN>>03570000
  MOVE * := D'FNAME,(4);                                      <<00.GEN>>03572000
  P'DELIM:=DELIM;                                             <<00.GEN>>03574000
  P'NEXT:=@DELIM(1);                                          <<00.GEN>>03576000
  MOVE P'LOCKWORD:=D'LOCKWORD,(4);                            <<00.GEN>>03578000
  MOVE P'GFNAME:=G'FNAME,(12);                                <<00.GEN>>03580000
END <<SUBROUTINE FIXUP'PARMS>>;                               <<00.GEN>>03582000
                                                              <<00.GEN>>03584000
<<---------------------------------------------------------->> <<U.RAO>>03586000
<<  Subroutine to pack file name for output                 >> <<U.RAO>>03588000
<<---------------------------------------------------------->> <<U.RAO>>03590000
SUBROUTINE PACKFILENAME;                                       <<U.RAO>>03592000
BEGIN                                                          <<U.RAO>>03594000
EBUF := 0;                                                     <<U.RAO>>03596000
MOVE EBUF(1) := EBUF,(13);  <<ZERO ARRAY (SO MOVE WHILE WORKS)><<U.RAO>>03598000
MOVE EBUF := R(11),(4);  <<MOVE IN FILE NAME>>                 <<38.PV>>03600000
MOVE BEBUF := BEBUF WHILE AN,1;  <<SCAN UNTIL BLANK OR 0>>     <<U.RAO>>03602000
BPS0 := ".";   <<PUT IN DELIMITER BETWEEN FILE & GROUP>>       <<U.RAO>>03604000
TOS := TOS+1;  <<BUMP POINTER PAST PERIOD>>                    <<U.RAO>>03606000
ASSEMBLE(DUP);  <<SAVE COPY FOR MOVE WHILE AN>>                <<U.RAO>>03608000
TOS := @R(7)&LSL(1);  <<MAKE BYTE ADDRESS FOR GROUP>>          <<38.PV>>03610000
MOVE * := *, (8); <<MOVE GROUP INTO NAME>>                     <<U.RAO>>03612000
MOVE BPS0 := BPS0 WHILE AN,1;  <<SCAN THROUGH GROUP NAME>>     <<U.RAO>>03614000
BPS0 := ".";  <<ETC. >>                                        <<U.RAO>>03616000
TOS := TOS+1;                                                  <<U.RAO>>03618000
ASSEMBLE(DUP);                                                 <<U.RAO>>03620000
TOS := @R(3)&LSL(1);  <<ACCT NAME>>                            <<38.PV>>03622000
MOVE * := *, (8);                                              <<U.RAO>>03624000
BPS0 := 0;   <<TERMINATOR FOR GENMSG>>                         <<U.RAO>>03626000
DEL;  <<POP POINTER>>                                          <<U.RAO>>03628000
END;   <<SUBROUTINE PACKFILENAME>>                             <<U.RAO>>03630000
<<:::::::::::::::::::::::::::::::::::::::::::::::>>            <<U.RAO>>03632000
<<                BODY OF PROCEDURE              >>            <<U.RAO>>03634000
<<:::::::::::::::::::::::::::::::::::::::::::::::>>            <<U.RAO>>03636000
      X := 42;                                                          03638000
      DO PARMS(X:=X+1) := 0 UNTIL X=47;                                 03640000
      PARMS (49) := FCLLIM;                                    <<38.PV>>03642000
      PARMS (50) := FCULIM;                                    <<38.PV>>03644000
      PARMS (51) := FLAG;                                      <<38.PV>>03646000
      PARMS:=ENUM;                                                      03648000
      PARMS(1):=GNUM;                                                   03650000
      PARMS(2):=PDATE;                                                  03652000
      PARMS (56) := ABSOLUTE(COLDLOADIDN);                     <<38.PV>>03654000
      PARMS (57) := 0;                                         <<38.PV>>03656000
      TOS := 0; TOS.(4:4) := MVTABX;                           <<SP.PV>>03658000
      PARMS (58) := TOS;                                       <<SP.PV>>03660000
      WHO(MODE,CAPABILITY,,USERN,GROUPN,ACCTN,HOMEN);                   03662000
      IF ATTRIB.(5:1) THEN                                              03664000
        BEGIN  <<SYSTEM SUPERVISOR>>                                    03666000
          PUSH(DL);                                                     03668000
          X := TOS-PS0(-1).(4:12);                                      03670000
          DB2(X).(0:1) := 1;  <<SET SYSTEM MANAGER BIT>>                03672000
          TOS := 1;                                                     03674000
        END                                                             03676000
      ELSE IF ATTRIB.(0:1)  <<SM>> THEN TOS:=1                          03678000
      ELSE TOS := 0;                                                    03680000
      PARMS (51).(0:1) := TOS;<<SYSTEM MANAGER OR SYSTEM SUP>> <<38.PV>>03682000
      @FILESET := @PTR;                                                 03684000
IF MODE.(12:2)=2 AND JOBSESSIONMAIN THEN  <<JOB AND JSMAIN>>   <<U.RAO>>03686000
   BEGIN  <<NEED TO KLUDGE UP ERROR HANDLING SO THAT CAN UNLOCK<<U.RAO>>03688000
   <<FILES IF ERROR DETECTED IN PRODUCEPARMS.  DONE BY FAKING>><<U.RAO>>03690000
   <<CONTINUE FLAG SO THAT CIERR THINKS IT IS A SESSION.  WE>> <<U.RAO>>03692000
   <<KILL THE JOB LATER WITH A NOMSG CALL TO CIERR>>           <<U.RAO>>03694000
   SETXPXFIXED+PXFWCONT;                                       <<U.RAO>>03696000
   IF DB0(X)>=0 THEN  <<CONTINUE NOT ALLREADY SET>>            <<U.RAO>>03698000
      FAKE'CONTINUE := TRUE;   <<FLAG TO DO FAKING>>           <<U.RAO>>03700000
   END;                                                        <<U.RAO>>03702000
DO BEGIN   <<LOOP UNTIL ALL FILESETS PARSED>>                  <<U.RAO>>03704000
   K := K+1;   <<BUMP PARAMETER COUNTER>>                      <<U.RAO>>03706000
   IF FAKE'CONTINUE THEN  <<DO KLUDGE>>                        <<U.RAO>>03708000
      BEGIN                                                    <<U.RAO>>03710000
      SETXPXFIXED+PXFWCONT;                                    <<U.RAO>>03712000
      DB0(X) := -1;                                            <<U.RAO>>03714000
      END;                                                     <<U.RAO>>03716000
   TOS:=PRODUCEPARMS(0 <<FILE>>,FILESET,PPRESULT,DELIM,ARET); <<00.GEN>>03718000
   IF FAKE'CONTINUE THEN   <<CLEAN UP KLUDGE>>                 <<U.RAO>>03720000
      BEGIN                                                    <<U.RAO>>03722000
      SETXPXFIXED+PXFWCONT;                                    <<U.RAO>>03724000
      DB0(X) := 0;  <<CLEAR CONTINUE FLAG>>                    <<U.RAO>>03726000
      END;                                                     <<U.RAO>>03728000
   IF NOT TOS THEN   <<PRODUCEPARMS' FAILED, HANDLE ERROR>>    <<U.RAO>>03730000
      BEGIN  <<PARSE OF NAME FAILED>>                          <<U.RAO>>03732000
      BRET := K;                                               <<U.RAO>>03734000
      IF PARMS (45) > 0 THEN UNLOCKSTORE(GNUM, TRUE);          <<38.PV>>03736000
      IF FAKE'CONTINUE THEN CIERR;   <<CAUSE ABORT OF JOB>>    <<U.RAO>>03738000
      PARMS (45) := 0;                                         <<38.PV>>03740000
      END                                                      <<U.RAO>>03742000
   ELSE  <<PARSED FILESET OK>>                                 <<U.RAO>>03744000
      BEGIN                                                    <<U.RAO>>03746000
      FIXUP'PARMS;                                            <<00.GEN>>03748000
      PARMS(3) := K;                                           <<U.RAO>>03750000
      TOS := 0D;  <<RETURN SPACE FOR DIRECSCAN>>               <<U.RAO>>03752000
      TOS := R;  <<MASK FOR DIRECSCAN>>                        <<U.RAO>>03754000
      TOS.(5:1) := 1;  <<SET HIT FLAG>>                        <<U.RAO>>03756000
      TOS.(13:3) := 0;  <<LEVEL FOR DIRECSCAN>>                <<U.RAO>>03758000
      TOS := R (1).(MVTABXF); <<LINKAGE>>                      <<42.PV>>03760000
      TOS := R (2); <<INDEXP>>                                 <<38.PV>>03762000
      PARMS (52) := GETSIR(FISIR);   << Lock files >>          <<00482>>03764000
      DR := DIRECSCAN (*,*,R(3),R(7),R(11),                    <<SP.PV>>03766000
                       RCSTORE,PARMS,MVTABX);                  <<SP.PV>>03768000
      IF <> THEN  <<PROBLEM WITH DIRECSCAN>>                   <<U.RAO>>03770000
         IF DRA <> 2 THEN  <<NOT A MISSING FILE, PROBLEM>>     <<U.RAO>>03772000
            SUDDENDEATH(533)                                   <<U.RAO>>03774000
         ELSE  <<NON-EXISTANT FILE, GROUP, ACCT>>              <<U.RAO>>03776000
            BEGIN   <<WRITE RECORD TO ERROR FILE>>             <<U.RAO>>03778000
            RELSIR (FISIR, PARMS(52));                         <<00482>>03780000
            EBUF(12) := K;  <<FILESET #>>                      <<U.RAO>>03782000
            EBUF(13) := (DRB+1) CAT 1 (0:8:8);                 <<U.RAO>>03784000
               <<DRB = 0=> FILE, 1=> GROUP, 2=> ACCT>>         <<U.RAO>>03786000
            IF NOT(0<=DRB<=2) THEN  <<DIRECTORY PROBLEM>>      <<U.RAO>>03788000
               SUDDENDEATH(533);                               <<U.RAO>>03790000
            MOVE EBUF := R (11), (4);  <<FILE NAME>>           <<38.PV>>03792000
            MOVE EBUF (4) := R (7), (4); <<GROUP NAME>>        <<38.PV>>03794000
            MOVE EBUF (8) := R (3), (4);  <<ACCT NAME>>        <<38.PV>>03796000
            FWRITE(ENUM, EBUF, 14, 0);                         <<U.RAO>>03798000
            IF <> THEN  <<PROBLEM ON ERROR FILE>>              <<U.RAO>>03800000
               BEGIN                                           <<U.RAO>>03802000
               IF PARMS (45) > 0 THEN                          <<38.PV>>03804000
                  UNLOCKSTORE(GNUM, TRUE);  <<CLEAN UP>>       <<U.RAO>>03806000
               PARMS (45) := 0;                                <<38.PV>>03808000
               FERROR'(ENUM, BRET);                            <<U.RAO>>03810000
               CIERR(ARET := STORSCRFLFSERR);                  <<U.RAO>>03812000
               END;                                            <<U.RAO>>03814000
            EFRCOUNT := EFRCOUNT+1;                            <<U.RAO>>03816000
            END                                                <<U.RAO>>03818000
      ELSE  <<NO PROBLEM WITH DIRECSCAN>>                      <<U.RAO>>03820000
         BEGIN  <<CHECK FOR PROBLEMS IN RCSTORE>>              <<U.RAO>>03822000
         RELSIR (FISIR, PARMS(52));                            <<00482>>03824000
         IF PARMS (46) <> 0 THEN  <<PROBLEM>>                  <<38.PV>>03826000
            BEGIN  <<PUT OUT MESSAGE, IF NECESSARY>>           <<U.RAO>>03828000
            ARET := PARMS (46);                                <<38.PV>>03830000
            IF PARMS (45) > 0 THEN   <<SOME FILES ARE LOCKED>> <<38.PV>>03832000
               UNLOCKSTORE(GNUM, TRUE);                        <<U.RAO>>03834000
            PARMS (45) := 0;                                   <<38.PV>>03836000
            IF ARET = STORSCRFLFSERR THEN                      <<U.RAO>>03838000
               BEGIN  <<FILE SYS PROB ON SCRATCH FILE>>        <<U.RAO>>03840000
               TOS := BRET;                                    <<U.RAO>>03842000
               FERROR'(*, BRET);                               <<U.RAO>>03844000
               CIERR(ARET);                                    <<U.RAO>>03846000
               END                                             <<U.RAO>>03848000
            ELSE IF ARET = STOR'ATTIO'FAIL THEN                <<U.RAO>>03850000
               BEGIN  <<ATTACHIO PROBLEM ON FILE LABEL>>       <<U.RAO>>03852000
               PACKFILENAME;  <<FILE THAT HAD PROBLEM>>        <<U.RAO>>03854000
               BRET := 0;                                      <<U.RAO>>03856000
               CIERR(ARET, , 0, @BEBUF);                       <<U.RAO>>03858000
               END;                                            <<U.RAO>>03860000
            END;                                               <<U.RAO>>03862000
         END;                                                  <<U.RAO>>03864000
      @FILESET := R (16);  <<POINTER TO NEXT FILESET>>         <<38.PV>>03866000
      END;  <<OK PARSE CASE>>                                  <<U.RAO>>03868000
   END UNTIL R (15)<>"," OR ARET<>0;  <<END OF MAIN LOOP>>     <<38.PV>>03870000
IF R (15) <> ";" AND ARET = 0 THEN                             <<38.PV>>03872000
   BEGIN   <<UNKNOWN DELIMITER>>                               <<U.RAO>>03874000
   IF PARMS (45) > 0 THEN                                      <<38.PV>>03876000
      UNLOCKSTORE(GNUM, TRUE);                                 <<U.RAO>>03878000
   TOS := ARET := STORFSETUNKDEL;                              <<U.RAO>>03880000
   BRET := K;  <<NUMBER OF PARAMETER, MORE OR LESS>>           <<U.RAO>>03882000
   TOS := R (16); <<BYTE ADDRESS OF PROBLEM>>                  <<38.PV>>03884000
   CIERR(*, *);                                                <<U.RAO>>03886000
   END;                                                        <<U.RAO>>03888000
      RETVAL := EFRCOUNT;       << RECORDS  ON ENUM >>         <<38.PV>>03890000
      RETVAL (1) := PARMS (45); << RECORDS  ON GNUM >>         <<38.PV>>03892000
      RESET;                                                            03894000
 END << ISTORE >>;                                                      03896000
$PAGE "RCSTORE  --  DETERMINE IF FILE CAN BE STORED"                    03898000
 INTEGER PROCEDURE RCSTORE(ELEMENT,LEVEL,PARMS,SIR);                    03900000
     VALUE LEVEL,PARMS,SIR;                                             03902000
     INTEGER LEVEL,PARMS;                                               03904000
     INTEGER ARRAY ELEMENT;                                             03906000
     DOUBLE SIR;                                                        03908000
   OPTION PRIVILEGED,UNCALLABLE;                                        03910000
<<*******************************************************************>> 03912000
<<                                                                   >> 03914000
<<     PARAMETERS TO RCSTORE:                                        >> 03916000
<<                                                                   >> 03918000
<<       ELEMENT  -  A DIRECTORY DATA SEGMENT POINTER TO FILE/GROUP/ >> 03920000
<<                   ACCT ENTRY.                                     >> 03922000
<<                                                                   >> 03924000
<<       LEVEL    -  0=FILE,   1=GROUP,  2=ACCT,  3=USER(CAN'T HAPPEN)>>03926000
<<                                                                   >> 03928000
<<       PARMS    -  CALLER'S Q-RELATIVE NEGATIVE DISPLACEMENT OF    >> 03930000
<<                   STACK PARAMETERS PASSED TO DIRECSCAN ( DELTA Q  >> 03932000
<<                   MUST BE SUBTRACTED TO REFERENCE AS QAR(PARMS).) >> 03934000
<<                                                                   >> 03936000
<<       SIR      -  SIR AND A TO RELSIR                             >> 03938000
<<                                                                   >> 03940000
<<    RCSTORE RETURNS (TO DIRECSCAN) :                               >> 03942000
<<                                                                   >> 03944000
<<       0 + L   -   CONTINUE SCAN                                   >> 03946000
<<       2 + L   -   SKIP THIS TREE (SCAN BROTHER)                   >> 03948000
<<       4 + L   -   STOP SCAN                                       >> 03950000
<<                                                                   >> 03952000
<<             WHERE  L = 0 IF DIRECTORY NOT LOCKED DOWN             >> 03954000
<<                             ( RCSTORE UNLOCKED IT).  (FALSE)      >> 03956000
<<                    L = 1 IF DIRECTORY IS STILL LOCKED DOWN. (TRUE)>> 03958000
<<                                                                   >> 03960000
<<*******************************************************************>> 03962000
<<                                                                   >> 03964000
<<     RCSTORE RETURNS A DOUBLE IN PARMS(46) AND PARMS(47) TO ISTORE >> 03966000
<<     SEE CXSTORE FOR POSSIBLE RETURNS                              >> 03968000
<<                                                                   >> 03970000
<<*******************************************************************>> 03972000
<<                                                                   >> 03974000
<<    DIRECSCAN CALLS RCSTORE FOR EACH ELEMENT ENCOUNTERED IN SCAN,  >> 03976000
<<    WITH DB AT DDS.   DIRECTORY IS ALWAYS LOCKED DOWN WHEN RCSTORE >> 03978000
<<    IS CALLED AND WILL STAY LOCKED DOWN UNLESS RCSTORE UNLOCKS IT. >> 03980000
<<                                                                   >> 03982000
<<*******************************************************************>> 03984000
<<*******************************************************************>> 03986000
<<*******************************************************************>> 03988000
<<              F.G.A RETURNED      NO. CALLS        LEVEL PARM      >> 03990000
<< FILESET      BY PRODUCEPARMS     OF RECIP         PASSED TO RECIP >> 03992000
<<               (B=BLANK)          BY DIRECSCAN            PER CALL >> 03994000
<<------------------------------------------------------------------->> 03996000
<<                                                                   >> 03998000
<<  F.G.A           F.G.A               1                0           >> 04000000
<<                                                                   >> 04002000
<<  F.G             F.G.B               1                0           >> 04004000
<<                                                                   >> 04006000
<<  F               F.B.B               1                0           >> 04008000
<<                                                                   >> 04010000
<<  @               B.B.B               F             0,0,0,...,0    >> 04012000
<<                                                                   >> 04014000
<<  @.G             B.G.B               F             0,0,0,...,0    >> 04016000
<<                                                                   >> 04018000
<<  @.G.A           B.G.A               F             0,0,0,...,0    >> 04020000
<<                                                                   >> 04022000
<<  @.@             B.B.B             (F+1)*G       1,0,0,0,...,0    >> 04024000
<<                                                  1,0,0,0,...,0    >> 04026000
<<                                                      ETC.         >> 04028000
<<                                                                   >> 04030000
<<  @.@.A           B.B.A             (F+1)*G       1,0,0,0,...,0    >> 04032000
<<                                                  1,0,0,0,   ,0    >> 04034000
<<                                                  1,0,0,0,...,0    >> 04036000
<<                                                      ETC.         >> 04038000
<<                                                                   >> 04040000
<<  @.@.@           B.B.B          ((F+1)*G+1)*A  2,1,0,0,0,...,0    >> 04042000
<<                                                  1,0,0,0,...,0    >> 04044000
<<                                                  1,0,0,0,...,0    >> 04046000
<<                                                     ETC.          >> 04048000
<<                                                2,1,0,0,0,...,0    >> 04050000
<<                                                  1,0,0,0,...,0    >> 04052000
<<                                                    ETC.           >> 04054000
<<*******************************************************************>> 04056000
 BEGIN                                                                  04058000
                                                                        04060000
  DEFINE QP'TYPE=   ARQ(PARMS+23) #,                          <<00.GEN>>04062000
         QP'GFNAME= ARQ(PARMS+ST'PPRINX) #;                   <<00.GEN>>04064000
  DEFINE P'GFNAME= PPRESULT #,                                <<00.GEN>>04066000
         P'GGNAME= PPRESULT(4) #,                             <<00.GEN>>04068000
         P'GANAME= PPRESULT(8) #;                             <<00.GEN>>04070000
  EQUATE SKIPTREE= 2,                                         <<00.GEN>>04072000
         SKIPNODE= SKIPTREE;                                  <<00.GEN>>04074000
  DOUBLE ARRAY DELEMENT(*)= ELEMENT;                          <<01.GEN>>04076000
  INTEGER ARRAY LEAFNAME(*)= S-3;                             <<00.GEN>>04078000
  INTEGER POINTER PPRESULT;                                   <<00.GEN>>04080000
                                                              <<00.GEN>>04082000
   DEFINE ENUM=ARQ(PARMS)#,                                             04084000
          GNUM = ARQ (PARMS+1) #,                              <<RV.PV>>04086000
          PVSYS'BYPASS = ARQ (PARMS+51).(10:1)#,               <<01188>>04088000
          MVTABX = ARQ (PARMS+57).(4:4) #;                     <<38.PV>>04090000
   EQUATE                                                      <<RV.PV>>04092000
       DIRDST = 20,                                            <<RV.PV>>04096000
       CONDMOUNT'BIND = -3;                                    <<RC.PV>>04098000
   INTEGER RCSTORERESULT=RCSTORE;      << KLUDGE >>                     04100000
   INTEGER  XREG=X;                                                     04102000
<<*******************************************************************>> 04104000
<<   WARNING:  PROGRAMS MUST NOT CLOBBER ANY 'UNDEFINED' PORTIONS    >> 04106000
<<             OF FILE LABEL BECAUSE THAT'S WHERE THE EXTENT MAP IS. >> 04108000
<<*******************************************************************>> 04110000
    EQUATE DTIMU=5;  << DDS UNLOCKED BY RCSTORE EVERY DTIMU CALLS >>    04112000
   INTEGER ARRAY ARQ(*)=Q+0;                                            04114000
   LOGICAL DSIR := TRUE,FSIR := TRUE;                                   04116000
   LOGICAL SPEC;                                                        04118000
   INTEGER                                                     <<RV.PV>>04120000
       LDN,                                                    <<RV.PV>>04122000
       P1,                                                     <<RV.PV>>04124000
       P2,                                                     <<RV.PV>>04126000
       HVSIND := [8/"*", 8/" "],                               <<RV.PV>>04128000
       REQTYPE,                                                <<RV.PV>>04130000
       PVINFO;                                                 <<RV.PV>>04132000
   DOUBLE IOB;                                                          04134000
   INTEGER STATUS=IOB;                                         <<U.RAO>>04136000
   BYTE ARRAY                                                  <<RV.PV>>04138000
       LMESS (0:90) = Q;                                       <<RV.PV>>04140000
   INTEGER ARRAY                                               <<RV.PV>>04142000
       FLAB (0:127) = Q,                                       <<RV.PV>>04144000
       GENTRY (*) = FLAB;                                      <<RV.PV>>04146000
   DOUBLE ARRAY FLABDBL(*)=FLAB;                                        04148000
                                                                        04150000
<<------------------------------------------------------------------->> 04152000
<<    SUBROUTINE TO WRITE A RECORD ON ERROR FILE (ENUM)             >>  04154000
<<------------------------------------------------------------------->> 04156000
    SUBROUTINE SETERRDATA(ETYPE,DETAIL);                                04158000
         VALUE ETYPE,DETAIL;    INTEGER ETYPE,DETAIL;                   04160000
      BEGIN                                                             04162000
        FLAB(12) := ARQ(PARMS+3);     << FILESET # >>                   04164000
        FLAB(13):=DETAIL CAT ETYPE (0:8:8);                             04166000
        FWRITE(ENUM,FLAB,14,0);                                         04168000
        IF <> THEN                                                      04170000
           BEGIN                                                        04172000
           ARQ(PARMS+46) := 1;   << File error >>              <<02546>>04174000
           ARQ(X := X+1) := ENUM;                              <<02546>>04176000
           RCSTORERESULT := 4;      << stop scan  >>           <<02546>>04178000
           END ELSE ARQ (X) := ARQ (PARMS+44) + 1;             <<38.PV>>04180000
    END << SETERRDATA >> ;                                              04182000
<<------------------------------------------------------------------->> 04184000
<<    SUBROUTINE TO LOCK DOWN A FILE IF IT IS NOT ALREADY IN USE     >> 04186000
<<------------------------------------------------------------------->> 04188000
    LOGICAL SUBROUTINE LOCKFILE;                                        04190000
    BEGIN                                                               04192000
      IF FLCLID <> ARQ (PARMS+56) THEN                         <<38.PV>>04194000
        BEGIN   <<COLD LOAD ID NOT VALID>>                              04196000
          FLRESTORE := 0;                                               04198000
          FLRW := 0;                                                    04200000
          FLLOADED := 0;                                                04202000
          FLFCBVECT := 0;                                               04204000
          FLCLID := ARQ (PARMS+56);                            <<38.PV>>04206000
          CHECKSUM;                                                     04208000
          FLCHECKSUM := TOS;                                            04210000
          GOTO LOCK;                                                    04212000
        END                                                             04214000
      ELSE IF FLRESTORE=0 AND FLWRITE=0 THEN                            04216000
        BEGIN                                                           04218000
  LOCK:   FLSTORE := 1;  <<LOCK IT DOWN>>                               04220000
          IOB := ATTACHIO(LDN,0,0,@FLAB,1,128,P1,P2,1);                 04222000
          IF STATUS.(13:3) <> 1 THEN GOTO IOERR;                        04224000
        END                                                             04226000
      ELSE                                                              04228000
        BEGIN   <<CAN'T BE LOCKED; MARK BUSY>>                          04230000
          SETERRDATA(4,0);                                              04232000
          LOCKFILE := TRUE;                                             04234000
        END;                                                            04236000
    END <<LOCKFILE>> ;                                                  04238000
<<------------------------------------------------------------------->> 04240000
<<    SUBROUTINE TO PERFORM AN 8-BYTE COMPARE.  ONE OPERAND IS IN    >> 04242000
<<    THE STACK (PARMS); THE OTHER IS IN THE EXTRA DATA SEGMENT.     >> 04244000
<<------------------------------------------------------------------->> 04246000
   LOGICAL SUBROUTINE COMPARE(PDISPL,TARRAY);                           04248000
       VALUE PDISPL;                                                    04250000
       INTEGER PDISPL;                                                  04252000
       INTEGER ARRAY TARRAY;  << ACCESSED VIA DS3=S-3 >>                04254000
    BEGIN                                                               04256000
         TOS := ARQ(PARMS+PDISPL);                                      04258000
         TOS := ARQ(XREG+1);                                            04260000
         IF TOS = DPS3 THEN                                             04262000
            BEGIN                                                       04264000
               TOS := ARQ(XREG+1);                                      04266000
               TOS := ARQ(XREG+1);                                      04268000
               IF TOS = DPS3(1) THEN COMPARE := TRUE;                   04270000
            END;                                                        04272000
    END << COMPARE >> ;                                                 04274000
<<------------------------------------------------------------------->> 04276000
<<    SUBROUTINE TO COPY FILE NAME FROM ARQPARMS TO FLAB             >> 04278000
<<------------------------------------------------------------------->> 04280000
    SUBROUTINE FILENAMECOPY;                                            04282000
    BEGIN                                                               04284000
           MOVE FLAB := ARQ (PARMS+34),(4);                    <<38.PV>>04286000
           MOVE FLAB (4) := ARQ (PARMS+30),(4);                <<38.PV>>04288000
           MOVE FLAB (8) := ARQ (PARMS+26),(4);                <<38.PV>>04290000
           FLAB (2) := LOGICAL (FLAB (2)) LAND %77777;         <<C+.09>>04292000
    END;  <<FILENAMECOPY>>                                              04294000
                                                                        04296000
<<------------------------------------------------------------------->> 04298000
<<    RCSTORE - main procedure                                      >>  04300000
<<------------------------------------------------------------------->> 04302000
   PARMS := PARMS - ARQ;   << SUBTRACT DELTA Q TO GET TOTAL DISTANCE >> 04304000
          SPEC := ARQ(PARMS+51).(0:1);  <<SM OR SS>>           <<38.PV>>04306000
   IF REQUESTSERVICE THEN      <<BREAK>>                                04308000
      BEGIN                                                             04310000
      ARQ(PARMS+46) := STORBREAK;                              <<02546>>04312000
      RCSTORERESULT := 4;                                      <<02546>>04314000
      GOTO EXIT;                                               <<02546>>04316000
      END;                                                              04318000
                                                              <<00.GEN>>04320000
   IF LOGICAL(QP'TYPE.(ALLFLAG)) THEN                         <<00.GEN>>04322000
   BEGIN                                                      <<00.GEN>>04324000
     TOS:=DELEMENT;                    <<LEAF NAME>>          <<01.GEN>>04326000
     TOS:=DELEMENT(1);                                        <<01.GEN>>04328000
     EXCHANGEDB(0);                                           <<00.GEN>>04330000
     @PPRESULT:=@QP'GFNAME;                                   <<00.GEN>>04332000
     CASE *LEVEL OF BEGIN                                     <<00.GEN>>04334000
       TOS:=DIRMATCH(P'GFNAME,LEAFNAME);                      <<00.GEN>>04336000
       TOS:=DIRMATCH(P'GGNAME,LEAFNAME);                      <<00.GEN>>04338000
       TOS:=DIRMATCH(P'GANAME,LEAFNAME);                      <<00.GEN>>04340000
       <<USER LEVEL>>;                                        <<00.GEN>>04342000
       <<VSD LEVEL>>;                                         <<00.GEN>>04344000
     END;                                                     <<00.GEN>>04346000
     XREG:=TOS;                                               <<00.GEN>>04348000
     DDEL;   DDEL;                     <<LEAF NAME>>          <<00.GEN>>04350000
     EXCHANGEDB(DIRDST);                                      <<00.GEN>>04352000
     IF X<>0 THEN                      << DIRMATCH<>0 >>      <<00.GEN>>04354000
        BEGIN                                                  <<02546>>04356000
        RCSTORERESULT := IF < THEN SKIPTREE ELSE SKIPNODE;     <<02546>>04358000
        GO EXIT;                                               <<02546>>04360000
        END;                                                   <<02546>>04362000
      END;                                                     <<02546>>04364000
                                                              <<00.GEN>>04366000
   IF LEVEL=2 THEN                                                      04368000
       BEGIN  <<ACCOUNT>>                                               04370000
          TOS:=ELEMENT (3); TOS:=ELEMENT (2);                  <<C+.09>>04372000
          TOS:=ELEMENT (1); TOS:=ELEMENT;                      <<C+.09>>04374000
          ARQ (PARMS+26):=TOS; ARQ (X:=X+1):=TOS;              <<38.PV>>04376000
          ARQ (X:=X+1):=TOS; ARQ (X:=X+1):=TOS;                <<38.PV>>04378000
          ARQ (PARMS+55) := ELEMENT (26); <<ACCOUNT SECURITY>> <<38.PV>>04380000
          GOTO EXIT;                                                    04382000
       END;                                                             04384000
   IF LEVEL=1 THEN                                                      04386000
       BEGIN <<GROUP>>                                                  04388000
          PVSYS'BYPASS := 0;                                   <<01188>>04390000
          TOS := ELEMENT(21);  <<GROUP SECURITY>>                       04392000
          TOS := ELEMENT(22);                                           04394000
          TOS:=ELEMENT (3); TOS:=ELEMENT (2);                  <<C+.09>>04396000
          TOS:=ELEMENT (1); TOS:=ELEMENT;                      <<C+.09>>04398000
          ARQ (PARMS+30):=TOS; ARQ (X:=X+1):=TOS;              <<38.PV>>04400000
          ARQ (X:=X+1):=TOS; ARQ (X:=X+1):=TOS;                <<38.PV>>04402000
          ARQ (PARMS+54) := TOS;                               <<38.PV>>04404000
          ARQ(X:=X-1) := TOS;                                           04406000
          IF ELEMENT (GLINKAGE).(PVF) = PV THEN                <<RC.RV>>04408000
          BEGIN  <<GROUP ASSIGNED TO PV>>                      <<RC.RV>>04410000
              EXCHANGEDB (0);                                  <<RC.RV>>04412000
              TOS := SIR;                                      <<RC.PC>>04414000
              RELSIR (*,*);                                    <<RC.PC>>04416000
              REQTYPE := CONDMOUNT'BIND;                       <<RC.RV>>04418000
              MOUNT (HVSIND,ARQ (PARMS+30),ARQ (PARMS+26),     <<RC.RV>>04420000
                     REQTYPE,-1,ARQ (PARMS+57));               <<RC.RV>>04422000
              IF < THEN                                        <<RC.RV>>04424000
              BEGIN <<MOUNT PROBLEM>>                          <<RC.RV>>04426000
                  PVSYS'BYPASS := 1;                           <<01188>>04428000
                  MOVE FLAB := "@       ",2;                   <<RC.RV>>04430000
                  MOVE * := ARQ (PARMS+30), (4),2;             <<RC.RV>>04432000
                  MOVE * := ARQ (X:=X-4), (4);                 <<RC.RV>>04434000
                  SETERRDATA (14,2);                           <<RC.RV>>04436000
                  RCSTORE.(14:1) := 1; << STOP TREE SCAN >>    <<01160>>04438000
                  ARQ (PARMS+57) := 0;                         <<RC.RV>>04440000
              END ELSE                                         <<RC.RV>>04442000
               ARQ (PARMS+57).(0:2) := 3; <<IND MOUNT REQUIRED><<RC.RV>>04444000
              EXCHANGEDB (DIRDST);                             <<RC.RV>>04446000
              RCSTORE.(0:1) := 1;   <<NEED TO REDO ENTRY>>     <<RC.PV>>04448000
              DSIR := FALSE;                                   <<RV.PV>>04450000
          END ELSE ARQ (PARMS+57) := ARQ (PARMS+58);           <<SP.RC>>04452000
          GOTO EXIT;                                                    04454000
       END;                                                             04456000
   IF LEVEL <> 0 <<FILE>> THEN                                          04458000
      BEGIN                                                             04460000
      SUDDENDEATH(534);      << Directory error. >>            <<02546>>04462000
      END;                                                              04464000
   IF PVSYS'BYPASS=1 THEN                                      <<01188>>04466000
      BEGIN                                                    <<01188>>04468000
          SETERRDATA (10,9);                                   <<01188>>04470000
          GOTO FIN;                                            <<01188>>04472000
      END;                                                     <<01188>>04474000
   ARQ (X) _ ARQ (PARMS+48)+1;   <<#TIMES RCSTORE CALLED>>     <<38.PV>>04476000
   TOS:=ELEMENT (4); TOS:=ELEMENT (5);                         <<RV.PV>>04478000
   TOS:=ELEMENT (3); TOS:=ELEMENT (2);                         <<C+.09>>04480000
   TOS:=ELEMENT (1); TOS:=ELEMENT;                             <<C+.09>>04482000
   ARQ (PARMS+34):=TOS; ARQ (X:=X+1):=TOS;                     <<38.PV>>04484000
   ARQ (X:=X+1):=TOS; ARQ (X:=X+1):=TOS;                       <<38.PV>>04486000
   LDN := LUN (S1.(0:8),MVTABX);                               <<RV.PV>>04488000
   P1 := S1.(8:8);    << HIGH ORDER DISC ADDRESS >>            <<RV.PV>>04490000
   P2 := S0;          << LOW ORDER DISC ADDRESS >>             <<RV.PV>>04492000
   EXCHANGEDB(0);                                                       04494000
   IF ARQ (PARMS+34+2) < 0 THEN  GO FLABERR;                   <<38.PV>>04496000
   IOB := ATTACHIO(LDN,0,0,@FLAB,0,128,P1,P2,1);                        04498000
   IF STATUS.(13:3) <> 1 THEN                                           04500000
      BEGIN      <<SOFT ERROR TO ALLOW STORE AROUND BAD DIRECTORY>>     04502000
      FILENAMECOPY;                                                     04504000
      SETERRDATA(7,9);  <<READ ERROR ON THIS FILE>>                     04506000
      DEL;DEL;                                                          04508000
      GOTO FIN;                                                         04510000
      END;                                                              04512000
   IF TOS<>FLEXTMAPD THEN                                               04514000
      BEGIN  <<DIRECTORY OR FILE LABEL ERROR>>                          04516000
FLABERR:                                                                04518000
      FILENAMECOPY;                                                     04520000
      SETERRDATA(13,1);                                                 04522000
      GOTO FIN                                                          04524000
      END;                                                              04526000
   TOS := @FLAB&LSL(1);                                                 04528000
   X := 0;                                                              04530000
   DO IF BPS0(X)=SPECIAL AND INTEGER(BPS0(X))<>%40 THEN GO FLABERR      04532000
   UNTIL (X:=X+1) = 24;                                                 04534000
   DEL;                                                                 04536000
   IF ARQ (PARMS+51).(14:1)=0 THEN BEGIN                       <<38.PV>>04538000
   IF LOGICAL(ARQ(PARMS+2)) > LOGICAL(FLLASTMOD) THEN GO FIN; <<DATE>>  04540000
   END                                                                  04542000
   ELSE IF LOGICAL(ARQ(PARMS+2))<LOGICAL(FLLASTACC) THEN GO FIN;        04544000
                                        <<FOR PURGEOLD>>                04546000
   TOS := ARQ (PARMS+49);   <<FILECODE LOWER LIMIT>>           <<38.PV>>04548000
   TOS := ARQ(X:=X+1);    <<FILECODE UPPER LIMIT>>                      04550000
   X := FLFILECODE;                                                     04552000
   IF NOT (TOS<=X<=TOS) THEN                                            04554000
      BEGIN    <<NOT IN RANGE>>                                         04556000
         SETERRDATA(5,1);                                               04558000
         GO FIN;                                                        04560000
      END;                                                              04562000
   IF LOGICAL(FLSECURE) THEN                                            04564000
       BEGIN   <<CHECK SECURITY>>                                       04566000
          TOS := ARQ (PARMS+53);  <<GROUP SECURITY>>           <<38.PV>>04568000
          TOS := ARQ(X:=X+1);                                           04570000
          IOB := TOS;                                                   04572000
          TOS := ACCCHECK (0,FLACCTNAME,ARQ (PARMS+55),        <<38.PV>>04574000
                           FLGRPNAME,IOB,FLUSERID,FLSECMX);    <<38.PV>>04576000
          IF NOT TOS.(10:1) THEN                                        04578000
            BEGIN  <<READ ACCESS FAILURE>>                              04580000
              IF NOT LOGICAL(ARQ(PARMS+23)).(9:1) THEN SETERRDATA(10,9);04582000
              GOTO FIN;                                                 04584000
            END;                                                        04586000
       END;                                                             04588000
   IF NOT SPEC THEN                                                     04590000
      BEGIN   <<  NOT SM OR SS >>                                       04592000
         IF FLFILECODE < 0 THEN   <<NEGATIVE FILECODE>>                 04594000
         IF NOT LOGICAL (ARQ (PARMS+51).(15:1)) THEN   <<IGNORE<<38.PV>>04596000
         IF NOT LOGICAL(ARQ(PARMS+6).(9:1)) THEN                        04598000
            BEGIN   <<DOESN'T HAVE PRIV MODE>>                          04600000
               SETERRDATA(5,0);                                         04602000
               GO FIN;                                                  04604000
            END;                                                        04606000
          IF ARQ(PARMS+5).(1:1)=1 AND COMPARE(15,FLACCTNAME) THEN GO OK;04608000
         IF COMPARE (40,FLLOCKWORD) THEN GO OK                          04610000
         ELSE IF ARQ (PARMS+40)="  " THEN  <<NOT SUPPLIED>>    <<38.PV>>04612000
           BEGIN   <<PROMPT USER FOR LOCKWORD>>                         04614000
              IF LOCKFILE THEN GO FIN;                                  04616000
              TOS := SIR;                                               04618000
              RELSIR(*,*);  <<RELEASE DIRECTORY SIR>>                   04620000
              RELSIR (FISIR, ARQ(PARMS+52));  <<Rel file SIR>> <<00482>>04622000
              FSIR := FALSE;                                            04624000
              DSIR := FALSE;                                            04626000
              TOS := 0;   <<FOR FREPLY>>                                04628000
              TOS := @LMESS;                                            04630000
              ASSEMBLE(DUP,DUP);                                        04632000
              MOVE * := "LOCKWORD: ",2;                                 04634000
              TOS := @FLLOCNAME&ASL(1);                                 04636000
              MOVE * := *,(8),2;                                        04638000
  BACKF:      TOS := TOS-1;                                             04640000
              IF BPS0=" " THEN GO BACKF;                                04642000
              TOS := TOS+1;                                             04644000
              TOS := @FLGRPNAME&ASL(1);                                 04646000
              BPS1 := ".";                                              04648000
              ASSEMBLE(INCB);                                           04650000
              MOVE * := *,(8),2;                                        04652000
  BACKG:      TOS := TOS-1;                                             04654000
              IF BPS0 = " " THEN GO BACKG; <<TRAILING BLANK>>           04656000
              TOS := TOS+1;                                             04658000
              TOS := @FLACCTNAME&ASL(1);                                04660000
              BPS1 := ".";                                              04662000
              ASSEMBLE(INCB);                                           04664000
              MOVE * := * ,(8),2;                                       04666000
  BACKA:      TOS := TOS-1;                                             04668000
              IF BPS0=" " THEN GO BACKA;  <<TRAILING BLANK>>            04670000
              TOS := TOS+1;                                             04672000
              BPS0 := "?";                                     <<02546>>04674000
              ASSEMBLE(SUB,NEG;INCA);  <<MESSAGE LENGTH>>               04676000
              TOS := FREPLY(*,*);  <<GET LOCKWORD FROM USER>>           04678000
              TOS := @ARQ (PARMS+40)&ASL(1);                   <<38.PV>>04680000
              MOVE * := LMESS,(8);   <<SO COMPARE WILL WORK>>           04682000
              IF NOT TOS THEN                                           04684000
                 BEGIN         << bad reply >>                 <<02546>>04686000
UNLOCK:          ARQ(PARMS+52) := GETSIR(FISIR);               <<02546>>04688000
                 FSIR := TRUE;                                 <<02546>>04690000
                 FLSTORE := 0;    << unlock file >>            <<02546>>04692000
                 IOB := ATTACHIO(LDN,0,0,@FLAB,1,128,P1,P2,1); <<02546>>04694000
                 IF STATUS.(13:3) <> 1 THEN                    <<02546>>04696000
                    BEGIN   << error writing label >>          <<02546>>04698000
IOERR:              ARQ(PARMS+46) := STOR'ATTIO'FAIL;          <<02546>>04700000
UGH:                RCSTORERESULT := 4;                        <<02546>>04702000
                    GOTO FIN;                                  <<02546>>04704000
                    END;                                       <<02546>>04706000
                 END                                           <<02546>>04708000
              ELSE IF COMPARE (40,FLLOCKWORD) THEN GOTO LOCKED <<38.PV>>04710000
              ELSE GOTO UNLOCK;                                         04712000
            END;                                                        04714000
         SETERRDATA(3,0);   <<FILE LOCKWORD WRONG>>                     04716000
         GO FIN;                                                        04718000
      END;  << NOT SM OR SS >>                                          04720000
 OK:                                                                    04722000
   IF NOT LOCKFILE THEN                                                 04724000
      BEGIN   <<CAN BE STORED>>                                         04726000
  LOCKED:                                                               04728000
         CHECKSUM;                                                      04730000
         ASSEMBLE (TEST);                                               04732000
         IF = OR FLCHECKSUM <> 0 THEN                                   04734000
          IF TOS <> FLCHECKSUM THEN                                     04736000
           FLAB := LOGICAL (FLAB) LOR %100000                  <<RV.PV>>04738000
          ELSE                                                 <<RV.PV>>04740000
         ELSE DEL <<CHECKSUM>>;                                <<RV.PV>>04742000
         TOS := P1;   <<1ST WORD OF DISC ADDRESS>>                      04744000
         TOS.(0:8) := LDN;   <<REPLACE VTAB INDEX WITH LDN>>            04746000
         TOS := P2;                                                     04748000
         FLABDBL(6) := TOS;                                             04750000
         FLAB (14) := ARQ (PARMS+57);  <<FLAGS & PVINFO>>      <<38.PV>>04752000
         FWRITE (GNUM,FLAB,15,0);                              <<RV.PV>>04754000
         IF <> THEN                                                     04756000
               BEGIN                                                    04758000
                   ARQ (PARMS+46) := STORSCRFLFSERR;           <<38.PV>>04760000
                   ARQ(X:=X+1) := GNUM;                                 04762000
                   ATTACHIO(LDN,0,0,@FLAB,0,128,P1,P2,1);      <<U.RAO>>04764000
                         <<GET FRESH COPY OF LABEL>>           <<U.RAO>>04766000
                   FLSTORE := 0;  <<UNLOCK FILE>>              <<U.RAO>>04768000
                   ATTACHIO(LDN,0,0,@FLAB,1,128,P1,P2,1);      <<U.RAO>>04770000
                         <<WRITE UPDATED COPY OF FLAB>>        <<U.RAO>>04772000
                   RCSTORERESULT := 4;  << stop DIRECSCAN >>   <<02546>>04774000
                   GO TO FIN;   <<QUIT LOOP>>                  <<U.RAO>>04776000
               END;                                                     04778000
         ARQ (PARMS+57).(1:1) := 0; <<ONE MOUNT PER GROUP>>    <<38.PV>>04780000
         ARQ (X) := ARQ (PARMS+45)+1;   <<# OF RECS ON GNUM>>  <<38.PV>>04782000
      END;                                                              04784000
  FIN:                                                                  04786000
   IF (ARQ (PARMS+48) MOD DTIMU) = 0 THEN                      <<38.PV>>04788000
       BEGIN      << UNLOCK DDS  >>                                     04790000
         IF DSIR THEN                                                   04792000
            BEGIN                                                       04794000
              TOS := SIR;                                               04796000
              RELSIR(*,*);  <<RELEASE DIRECTORY SIR>>                   04798000
              DSIR := FALSE;                                            04800000
            END;                                                        04802000
         IF FSIR THEN RELSIR(FISIR, ARQ(PARMS+52));            <<00482>>04804000
  GETF:  ARQ(PARMS+52) := GETSIR(FISIR);    << Get file SIR >> <<00482>>04806000
      END                                                               04808000
   ELSE IF NOT FSIR THEN GOTO GETF;                                     04810000
   ARQ(PARMS+40) := "  ";                                      <<02546>>04812000
   MOVE ARQ(X := X+1) := ARQ(X := X-1),(3);  << blank Lockword <<02546>>04814000
EXIT:                                                          <<02546>>04816000
   IF DSIR THEN RCSTORE.(15:1) := 1;<<Directory still locked>> <<02546>>04818000
   EXCHANGEDB(DIRDST);   << back to Directory dataseg >>       <<02546>>04820000
   END;      << procedure RCSTORE >>                           <<02546>>04822000
INTEGER PROCEDURE CHKFORDISMOUNT (PREV'PVINFO,CURR'PVINFO,     <<RC.PV>>04824000
                                  PREVGBUF);                   <<RC.PV>>04826000
    VALUE   PREV'PVINFO,CURR'PVINFO;                           <<RV.PV>>04828000
    LOGICAL PREV'PVINFO,CURR'PVINFO;                           <<RV.PV>>04830000
    ARRAY   PREVGBUF;                                          <<RC.PV>>04832000
   OPTION PRIVILEGED, UNCALLABLE;                              <<04.RO>>04834000
    BEGIN                                                      <<RV.PV>>04836000
        EQUATE                                                 <<RV.PV>>04838000
            CONDDISMOUNT'BIND = -3;                            <<00482>>04840000
        INTEGER                                                <<RV.PV>>04842000
            REQTYPE := CONDDISMOUNT'BIND,                      <<RC.PV>>04844000
            HVSIND := [8/"*", 8/" "],                          <<RC.PV>>04846000
            ERRCODE = REQTYPE;                                 <<00482>>04848000
        CC := CCE; <<OK UNTIL FAILURE>>                        <<RV.PV>>04850000
        IF PREV'PVINFO.(0:1) = 1 <<LAST ONE WAS MOUNTED>> THEN <<RV.PV>>04852000
         IF CURR'PVINFO.(0:1) = 0<<MOUNTED => NOT MOUNTED>> OR <<RV.PV>>04854000
            CURR'PVINFO.(1:1) = 1 <<DIFFERENT MOUNT>> THEN     <<RV.PV>>04856000
         BEGIN                                                 <<RV.PV>>04858000
             DISMOUNT (HVSIND,PREVGBUF (4),PREVGBUF (8),       <<RC.PV>>04860000
                       REQTYPE,PREV'PVINFO);                   <<RC.PV>>04862000
             IF <> THEN                                        <<RV.PV>>04864000
             BEGIN                                             <<RV.PV>>04866000
                 CHKFORDISMOUNT := ERRCODE;                    <<RV.PV>>04868000
                 CC := CCG;                                    <<RV.PV>>04870000
             END;                                              <<RV.PV>>04872000
         END;                                                  <<RV.PV>>04874000
    END;<<OF CHKFORDISMOUNT>>                                  <<RV.PV>>04876000
$PAGE "FSTORE & UTILITY PROCEDURES  --  WRITE FILES TO TAPE"            04878000
<<----------------------------------------------------------->>         04882000
<<   WRITETAPE: Write tape and support multi-reel files      >>         04884000
<<----------------------------------------------------------->>         04886000
  LOGICAL PROCEDURE WRITETAPE(WORDC,BUFFER,IGNOREOT,           <<02546>>04888000
                         TDBUF,TRAILBL,TNUM,GNUM,K,L);                  04890000
     VALUE WORDC,IGNOREOT,TNUM,GNUM,K,L;                                04892000
       INTEGER WORDC,TNUM,GNUM,K,L;   LOGICAL IGNOREOT;                 04894000
       INTEGER ARRAY BUFFER,TDBUF,TRAILBL;                              04896000
    OPTION PRIVILEGED, UNCALLABLE;                                      04898000
<<                                                                      04900000
     WRITETAPE RETURNS:    FALSE - OK                                   04902000
                           TRUE  - error - die                          04904000
>>                                                                      04906000
     BEGIN                                                              04908000
     INTEGER I, DEVTYPE;                                       <<02546>>04910000
     LOGICAL ECODE;                                                     04912000
     LOGICAL SPEC'ENTRY:=FALSE;                                <<02871>>04914000
     LOGICAL FOPTIONS,LDEV;                                    <<02546>>04916000
     EQUATE EOTCODE = 23;                                               04918000
                                                                        04920000
   FGETINFO(TNUM,,FOPTIONS,,,DEVTYPE,LDEV);                             04922000
   IF WORDC < 0              << only for NOWAIT I/O >>                  04924000
      THEN GO NEWREEL;                                                  04926000
   IF LABELED THEN                                                      04928000
      BEGIN      << Try FWRITE and see what happens. >>                 04930000
      IF WORDC = 0 THEN RETURN;   << Nothing to do. >>                  04932000
      FWRITE(TNUM,BUFFER,WORDC,0);                                      04934000
      IF <> THEN                                                        04936000
         BEGIN                                                          04938000
         FCHECK(TNUM,ECODE);                                            04940000
         GO ERA;                                                        04942000
         END;                                                           04944000
      IF LRELSW(TNUM) THEN                                              04946000
         BEGIN         << FWRITE did a REELSWITCH. >>                   04948000
         REELNUM := REELNUM+1;                                          04950000
         GO NXRLAB;     << write header on new reel. >>                 04952000
         END;                                                           04954000
      RETURN;                                                           04956000
      END;                                                              04958000
   IF WORDC = 0 THEN FCONTROL(TNUM,WEOF,I) ELSE                         04960000
      FWRITE(TNUM,BUFFER,WORDC,0);                                      04962000
   IF = THEN RETURN;       << Done >>                                   04964000
   IF > THEN GO ERA;       << shouldn't occur >>                        04966000
   FCHECK(TNUM,ECODE);  << Get details about error >>                   04968000
   IF ECODE.(8:8) <> EOTCODE THEN GO ERA;                               04970000
                                                                        04972000
<< EOT was encountered on write.  Write trailer label,                  04974000
rewind, and set up next reel.  >>                                       04976000
                                                                        04978000
NEWREEL:                                                                04980000
   IF IGNOREOT THEN RETURN;                                             04982000
   IF WORDC < 0 THEN                                                    04984000
      WORDC := IF WORDC = -1 THEN 0 ELSE -WORDC;                        04986000
   IF WORDC > 0 THEN                                                    04988000
      BEGIN                << EOT sensed on WRITE >>                    04990000
      IF WRITETAPE(0,TDBUF <<ignored>>,TRUE,                            04992000
          TDBUF,TRAILBL,TNUM,GNUM,K,L) THEN GO ERA;                     04994000
      XFIELD := 0;   << More data from this file on next vol >>         04996000
      END                                                               04998000
   ELSE                                                                 05000000
      BEGIN          << EOT sensed on WEOF >>                           05002000
      XFIELD := 1;  <<EOF is genuine. Next reel is next file. >>        05004000
      IF L = K THEN ZFIELD := 1;   << WEOF final file sensed >>         05006000
      END;                                                              05008000
   IF WRITETAPE(40,TRAILBL,TRUE,                                        05010000
       TDBUF,TRAILBL,TNUM,GNUM,K,L) THEN GO ERA;                        05012000
   IF WRITETAPE(0,TDBUF <<ignored>>,TRUE,                               05014000
       TDBUF,TRAILBL,TNUM,GNUM,K,L) THEN GO ERA;                        05016000
   IF WRITETAPE(0,TDBUF <<ignored>>,TRUE,                               05018000
       TDBUF,TRAILBL,TNUM,GNUM,K,L) THEN GO ERA;                        05020000
   IF ZFIELD = 1 THEN RETURN;  << All files written >>         <<02717>>05022000
   FCONTROL(TNUM,REWUNLOAD,I);                                          05024000
   IF <> THEN GO ERA;                                                   05026000
   GENMSG(1,19,%10000,LDEV,,,,,0);   << Want next reel. >>              05030000
   REELNUM := REELNUM+1;      << Bump physical reel count >>            05032000
NXTRL:                                                                  05034000
   COMMENT:                                                             05036000
     In order to guarantee that the tape is at                          05038000
     load point (for unlabelled tapes!) before                          05040000
     the header label is written, a Rewind is issued.                   05042000
     This will:                                                         05044000
       1)  Leave tape at load point if already there,                   05046000
       2)  Bring it back to load point if past load point,              05048000
       3)  Repeatedly wind the tape off the end if                      05050000
           it is somehow on-line before load point.                     05052000
     This kludge is dependent on the Rewind-unload                      05054000
     (in particular the Unload) preceding the Rewind.                   05056000
     ;                                                                  05058000
   FCONTROL(TNUM,REWIND,I);                                    <<02558>>05062000
   IF <> THEN GO ERA;                                          <<02558>>05064000
                                                                        05066000
<< New tape is ready.  Write header label, and (if not                  05068000
labelled) the file directory. >>                                        05070000
                                                                        05072000
NXRLAB:                                                                 05074000
   MOVE IIBID := "VIIB";                                                05076000
   SPANTOG := (NOT LOGICAL(XFIELD)).(15:1); <<1st file is partial>>     05078000
<< FFILEINX is index in directory of 1st file on volume. >>             05080000
   FFILEINX:=(IF USING'ATTIO AND WORDC=0 THEN L+1 ELSE         <<02730>>05082000
              IF L=0 THEN 0 ELSE (L-1));                       <<02730>>05084000
   TOS := -1;                                                           05086000
   X := 39;                                                             05088000
   DO TOS := TOS XOR LOGICAL(HDRLBL(X)) UNTIL (X := X-1) < 0;           05090000
   CHKSUM := TOS;                                                       05092000
   IF LABELED THEN                                                      05094000
      BEGIN       << Write Store header as UHL1. >>                     05096000
      FWRITELABEL(TNUM,HDRLBL,40);                                      05098000
      IF <> THEN GO ERA;                                                05100000
      RETURN;       << Directory goes on later. >>                      05102000
      END;                                                              05104000
   FWRITE(TNUM,HDRLBL,40,0);                                            05106000
   IF < THEN                                                            05108000
      BEGIN                                                             05110000
      FCONTROL(TNUM,3,ECODE);   << get hardware status >>               05112000
      IF <> THEN GO ERA;       << can't get it - doom. >>               05114000
      IF ECODE.(6:1) THEN                                               05116000
         BEGIN       << No write ring. >>                               05118000
         FCONTROL(TNUM,REWUNLOAD,I);   << rewind/offline >>             05120000
         GENMSG(1,220,%10000,LDEV,,,,,0);  << No Write Ring>>           05122000
         GO NXTRL;                                                      05124000
         END                                                            05126000
      ELSE GO ERA;    << Some other error; die. >>                      05128000
      END;                                                              05130000
   IF > THEN GO ERA;    << Possible other FWRITE error >>               05132000
   IF DIREC'TO'TAPE(GNUM,L,TDBUF,TRAILBL,                               05134000
              TNUM,K,L) <> 0D THEN                                      05136000
ERA:  WRITETAPE := TRUE;    << Fatal error. >>                          05138000
   END;      << procedure WRITETAPE >>                                  05140000
DOUBLE PROCEDURE DIREC'TO'TAPE (GNUM,CURR'GOODREC,                      05142000
                         TDBUF,TRAILBL,TNUM,K,L);              <<02546>>05144000
    VALUE   GNUM,CURR'GOODREC,TNUM;                                     05146000
    INTEGER GNUM,CURR'GOODREC,TNUM,K,L;                        <<02546>>05148000
    ARRAY TDBUF,TRAILBL;                                                05150000
    OPTION PRIVILEGED, UNCALLABLE;                             <<04.RO>>05152000
    BEGIN                                                               05154000
        INTEGER ARRAY GBUF (0:14);                                      05156000
        DEFINE PVINFO = GBUF (14) #;                                    05158000
        EQUATE LRECLG = 15;                                             05160000
        INTEGER POINTER BP;                                             05162000
   INTEGER NLRTD,BLKTD;                                        <<00425>>05164000
        INTEGER                                                         05166000
            DEVTYPE,                                           <<02558>>05168000
            I,                                                          05170000
            BRET = DIREC'TO'TAPE,                                       05172000
            ARET = BRET+1;                                              05174000
        SUBROUTINE TAPEFILEERROR(NEEDUNLOCK, UNLOCKSTATE);              05176000
            VALUE NEEDUNLOCK, UNLOCKSTATE;                              05178000
            LOGICAL NEEDUNLOCK;  <<TRUE => UNLOCK FILES>>               05180000
            LOGICAL UNLOCKSTATE; <<TRUE => RWD GOOD FILE BEFORE UNLOCK>>05182000
            BEGIN                                                       05184000
                ARET := STORTAPEFSERR;  <<FILE SYSTEM ERROR ON TAPE>>   05186000
                IF NEEDUNLOCK THEN                                      05188000
                 UNLOCKSTORE (GNUM,UNLOCKSTATE,PVINFO);                 05190000
                FERROR'(TNUM, BRET);                                    05192000
                CIERR(ARET);                                            05194000
                ASSEMBLE (EXIT 7);  << BAIL OUT >>             <<02562>>05196000
            END;                                                        05198000
        SUBROUTINE GOODFILEERROR;                                       05200000
            BEGIN                                                       05202000
                ARET := STORSCRFLFSERR;                                 05204000
                FERROR'(GNUM, BRET);                                    05206000
                CIERR(ARET);                                            05208000
                ASSEMBLE (EXIT 7);  << BAIL OUT >>             <<02562>>05210000
            END;                                                        05212000
                                                               <<02546>>05214000
<< DIREC'TO'TAPE main procedure >>                             <<02546>>05216000
                                                               <<02546>>05218000
   FGETINFO(TNUM,,,,,DEVTYPE);                                 <<02558>>05220000
   BLKTD := TAPEBLOCKSIZE;  << Get block size from label >>    <<02558>>05222000
                                                               <<02558>>05224000
   << For magtapes, directory records never exceed 4096 W. >>  <<02558>>05226000
   IF (BLKTD > 4096) AND (DEVTYPE.DTYPE = MAGTAPE) THEN        <<02558>>05228000
      BLKTD := 4096;                                           <<02558>>05230000
                                                               <<02558>>05232000
   NLRTD:=BLKTD/LRECLTD; <<CALCULATE # DIR. RECORDS/BLOCK>>    <<00425>>05236000
   BLKTD:=NLRTD*LRECLTD; <<MAKE DIR BLOCK MULTIPLE OF ENTRY SIZ<<00425>>05238000
        K := 0;                                                         05240000
        @BP := @TDBUF;                                                  05242000
        FCONTROL (GNUM,REWIND,I);                                       05244000
        IF <> THEN GOODFILEERROR;                                       05246000
        FREAD(GNUM, GBUF, LRECLG);  <<GET FIRST ENTRY>>                 05248000
        WHILE = DO   <<SCAN THROUGH FILE>>                              05250000
        BEGIN                                                           05252000
            K := K+1;  <<BUMP RECORD NUMBER COUNTER>>                   05254000
            GBUF := LOGICAL(GBUF) LAND %77777;                          05256000
            MOVE BP := GBUF, (LRECLTD);  <<DIREC ELEMENT>>              05258000
            @BP := @BP+LRECLTD;                                         05260000
            IF REQUESTSERVICE THEN   <<BREAK HIT>>                      05262000
            BEGIN                                                       05264000
                UNLOCKSTORE (GNUM, TRUE, 0);                            05266000
                ARET := STORBREAK;                                      05268000
                RETURN;                                                 05270000
            END;                                                        05272000
            IF K MOD NLRTD = 0 THEN  <<DIR BLOCK TO TAPE>>              05274000
             IF WRITETAPE (BLKTD,TDBUF,FALSE,                           05276000
                TDBUF,TRAILBL,TNUM,GNUM,K,L) THEN              <<02546>>05278000
              TAPEFILEERROR(TRUE, TRUE)                                 05280000
             ELSE  <<WRITE SUCCEEDED>>                                  05282000
              @BP := @TDBUF;  <<REINITIALIZE BUFFER>>                   05284000
            FREAD(GNUM, GBUF, LRECLG);  <<NEXT FILE NAME>>              05286000
        END;   <<OF WHILE LOOP>>                                        05288000
        IF < THEN   <<ERROR ON "GOOD" FILE>>                            05290000
         GOODFILEERROR                                                  05292000
        ELSE  <<WRITE OUT LAST BLOCK>>                                  05294000
         IF @BP<>@TDBUF AND                                             05296000
            WRITETAPE (@BP-@TDBUF,TDBUF,FALSE,                          05298000
                  TDBUF,TRAILBL,TNUM,GNUM,K,L) OR              <<02546>>05300000
            WRITETAPE (0,TDBUF,FALSE,                                   05302000
            TDBUF,TRAILBL,TNUM,GNUM,K,L) <<EOF>> THEN          <<02546>>05304000
          TAPEFILEERROR(TRUE, TRUE);                                    05306000
   <<ELSE WE HAVE WRITTEN THE DIRECTORY OF FILES ON THE TAPE>>          05308000
        FCONTROL (GNUM,REWIND,I);                                       05310000
        IF <> THEN GOODFILEERROR;                                       05312000
        FPOINT (GNUM,DOUBLE (CURR'GOODREC));                            05314000
        IF <> THEN GOODFILEERROR;                                       05316000
    END;<<OF DIREC'TO'TAPE>>                                            05318000
 DOUBLE PROCEDURE FSTORE(TNUM,GNUM);                                    05320000
       VALUE TNUM,GNUM;                                                 05322000
      INTEGER TNUM,GNUM;                                                05324000
   OPTION PRIVILEGED,UNCALLABLE;                                        05326000
                                                                        05328000
<<*******************************************************************>> 05330000
<<                                                                      05332000
       FSTORE PARAMETERS:                                               05334000
                                                                        05336000
         TNUM  -  THE FILE NUMBER OF AN OPENED FILE TO WHICH DISK       05338000
                  FILES WILL BE DUMPED.  (TAPE)                         05340000
                  CXSTORE OPENS TNUM WITH UNDEFINED LENGTH RECORDS,     05342000
                  RECSIZE=1024, NOBUF, AND NOLABEL.                     05344000
                                                                        05346000
         GNUM  -  THE FILE NUMBER OF A TEMPORARY DISK FILE CONTAINING   05348000
                  14-WORD LOGICAL RECORDS.  THE FIRST 12 WORDS ARE      05350000
                  A FILE-GROUP-ACCT NAME FOLLOWED BY TWO WORDS OF       05352000
                  POINTER INFO WHICH DESCRIBE THE LOCATION OF THE FILE. 05354000
                  EACH FILE NAMED IN GNUM WILL BE DUMPED TO TAPE.       05356000
                                                                        05358000
     SEE CXSTORE FOR FSTORE RETURNS                                     05360000
                                                                        05362000
      THE FUNCTION OF FSTORE IS TO DUMP ONTO TAPE TNUM ALL OF THE       05364000
      FILES NAMED IN GNUM.  ALL SUCH FILES ARE LOCKED DOWN FOR          05366000
      EXCLUSIVE USE (RCSTORE PERFORMED THIS FUNCTION).  AS EACH FILE    05368000
      IS DUMPED TO TAPE, FSTORE RELEASES THE FILE FOR USE BY OTHERS.    05370000
                                                                    >>  05372000
<<******************************************************************>>  05374000
<<                                                                      05376000
      INTERPRETATION OF FIELDS IN STORE TAPE TRAILER LABELS:            05378000
                                                                        05380000
         IF ZFIELD=1, XFIELD IS UNDEFINED.  THE EOF WHICH PRECEDES      05382000
                      THIS TRAILER LABEL REPRESENTS THE TRUE EOF        05384000
                      FOR THIS FILE. IT ALSO DENOTES THAT THIS IS THE   05386000
                      LAST PHYSICAL REEL OF THE LOGICAL STORE TAPE.     05388000
                                                                        05390000
         IF ZFIELD=0,   XFIELD=0 MEANS DATA FOR CURRENT FILE IS         05392000
                                 CONTINUED ON NEXT REEL.                05394000
                        XFIELD=1 MEANS THAT THE EOF WHICH PRECEDES      05396000
                                 THIS TRAILER LABEL REPRESENTS THE      05398000
                                 TRUE EOF FOR THIS FILE.  NEXT REEL     05400000
                                 BEGINS A NEW FILE.                     05402000
                                                                     >> 05404000
<<*******************************************************************>> 05406000
  BEGIN                                                                 05408000
                                                                        05410000
   DOUBLE  BLK'SIZE,REC'SIZE;  <<for RIO files only>>          <<04305>>05412000
   INTEGER BLK'FACT;           <<for RIO files only>>          <<04305>>05414000
   INTEGER LDN,MSIR,CURBUFF,DEVTYPE,IOQP;                      <<02518>>05416000
   INTEGER B,B',C,D,E,F,G,M,N;                                 <<02518>>05418000
   INTEGER MAXSECT,                   << Sectors per buffer >> <<02573>>05420000
           MAXDS := 32640;                 << Max. DST Size >> <<02573>>05422000
   INTEGER ARRAY BUFF (0:NUMBUFF);          << XDST numbers >> <<02518>>05424000
   LOGICAL ARRAY BUFF'STAT(0:NUMBUFF);     << Buffer Status >> <<02645>>05426000
   INTEGER ARRAY RSIZE(0:NUMBUFF*255+1);     <<Tape Rec Size>> <<03750>>05428000
   DOUBLE  ARRAY IOQ  (0:NUMBUFF*255);        << IOQ Status >> <<02573>>05430000
   INTEGER ARRAY IOQW (*)=IOQ; << integer portion of status >> <<02518>>05432000
   INTEGER XLDN; <<USED FOR LDEV TO ATTACHIO>>                          05434000
   DOUBLE ARRAY DEXTMAP(0:31);  <<TEMP EXTMAP FOR DISK ADDR>>           05436000
   ARRAY        EXTMAP(*)=DEXTMAP;                                      05440000
   BYTE ARRAY   BEXTMAP(*)=DEXTMAP;                                     05442000
   INTEGER ARRAY  FLAB(0:127) ;     << FILE LABEL FROM DISK >>          05446000
   DOUBLE ARRAY  FLABDBL(*)=FLAB;                                       05448000
        INTEGER K,I; LOGICAL ECODE;                            <<U.RAO>>05450000
      INTEGER L:=0; << For File System writes: # files >>      <<02717>>05452000
      INTEGER A:=0; << For ATTACHIO writes:    # files >>      <<02717>>05454000
      INTEGER LAST'RECSIZE;  << LAST ATTACHIO REC WRITTEN >>   <<02687>>05456000
      INTEGER ARRAY GBUF (0:14),                               <<RC.PV>>05458000
                    PREVGBUF (0:14);                           <<RC.PV>>05460000
INTEGER POINTER TDBUF; <<POINTER TO TAPE I/O BUFFER>>          <<00425>>05462000
  DOUBLE SECTORS,DISKADR;                                               05464000
  INTEGER P1=DISKADR,P2=DISKADR+1;                                      05466000
      INTEGER BLOCKSFILLED;                                    <<U.RAO>>05468000
      INTEGER LDNUM:=0,BRET=FSTORE,ARET=FSTORE+1;                       05470000
   INTEGER NUM'EXTENTS, HOLD'EXTENTS;                          <<03750>>05472000
      LOGICAL CNT,SECTORSLEFT,MM,NN;                                    05476000
      LOGICAL FOUND'EOT:=FALSE,    << Used by ATTACHIO writes>><<02727>>05478000
              PROCESS'THIS'BUFFER; << Used by CHK'STAT sub >>  <<02727>>05480000
    LOGICAL FOPTIONS,AOPTIONS,LDEV;                            <<00615>>05482000
      LOGICAL NEWTAPE:=FALSE;  << START OF NEW TAPE >>         <<02687>>05484000
      DOUBLE IOB;                                                       05486000
   INTEGER STATUS=IOB,                                         <<02518>>05488000
           TAPCNT=IOB+1;                                       <<02518>>05490000
   LOGICAL                                                     <<02558>>05492000
      SPEC'ENTRY:=FALSE,                                       <<02871>>05494000
      STACK'INC,  << Stack increment for tape buffer >>        <<02558>>05496000
      DEFAULT'6250 := FALSE;                                   <<02558>>05498000
      << TRUE when user takes defaults for 6250 BPI tape >>    <<02558>>05500000
                                                               <<02558>>05502000
      DOUBLE POINTER ENTRE;                                             05504000
      INTEGER                                                  <<RV.PV>>05506000
          REQTYPE,                                             <<RV.PV>>05508000
          PVINFO := 0;                                         <<RV.PV>>05510000
      DEFINE                                                   <<RV.PV>>05512000
          MVTABX = PVINFO.(4:4) #;                             <<RV.PV>>05514000
      EQUATE                                                   <<RV.PV>>05518000
          CONDDISMOUNT'BIND = -3;                              <<RC.PV>>05520000
<<                                                                   >> 05522000
<<   NOTE:  THE HEADER AND TRAILER LABEL FORMATS WRITTEN BY STORE    >> 05524000
<<          DO NOT CONFORM TO ANY STANDARDS.  TAPE IS UNLABELED.     >> 05526000
<<                                                                   >> 05528000
      INTEGER ARRAY TRAILBL(0:39);                                      05530000
      BYTE ARRAY                                               <<RV.PV>>05532000
          HTLBLS (*) = TRAILBL;                                <<RV.PV>>05534000
      INTEGER POINTER BP;                                               05536000
      INTEGER NLRPTR; <<# OF SECTORS TO TAPE BLOCK BUFFER>>    <<00425>>05538000
      EQUATE LRECLG=15;                                        <<RV.PV>>05542000
      DEFINE TPBLK=TAPEBLOCKSIZE#;                             <<02518>>05544000
<<***********************************************************>><<02518>>05546000
<<             CHECK STATUS OF TAPE I/O REQUEST              >><<02518>>05548000
<<***********************************************************>><<02518>>05550000
LOGICAL SUBROUTINE CHK'STAT (BUFFP);                           <<02727>>05554000
VALUE BUFFP;  INTEGER BUFFP;                                   <<02727>>05556000
BEGIN                                                          <<02727>>05558000
<<    This subroutine is used only for ATTACHIO writes to the>><<02727>>05560000
<< STORE device.  Tape will be written past the EOT reflector>><<02727>>05562000
<< only by the number of records still awaiting processing in>><<02727>>05564000
<< the buffers defined by BUFF, and currently pointed to by  >><<02727>>05566000
<< the variable, CURBUFF.                                    >><<02727>>05568000
<<    The status TRUE is returned by CHK'STAT if any tape er->><<02727>>05570000
<< rors occurred during the status check.                    >><<02727>>05572000
                                                               <<02727>>05574000
  B:=0;  WHILE BUFFP<>BUFF(B) DO B:=B+1;<<Find Current buffer>><<02727>>05576000
  G := B;  << save current buffer pointer >>                   <<02727>>05578000
  PROCESS'THIS'BUFFER := TRUE;                                 <<02727>>05580000
                                                               <<02727>>05582000
  WHILE PROCESS'THIS'BUFFER DO                                 <<02727>>05584000
     BEGIN << If EOT found, complete all pending writes >>     <<02727>>05586000
     TOS := B;       TOS := MAXSECT;                           <<02727>>05588000
     ASSEMBLE (DDUP, MPY, DDUP, ADD);                          <<02727>>05590000
     B' := TOS;      C := TOS;                                 <<02727>>05592000
     ASSEMBLE (DDEL);                                          <<02727>>05594000
     N:=C;  << Save the start of IOQ tests >>                  <<02730>>05596000
                                                               <<02730>>05598000
     WHILE C<B' AND IOQ(C)<>0D DO                              <<02727>>05600000
        BEGIN  <<Check status return of IOQ's in buffer BUFFP>><<02727>>05602000
           IOQP := IOQW (C & LSL(1));  <<1st word of IOQ indx>><<02727>>05604000
           IOB  := WAITFORIO (IOQP);   <<Check for completion>><<02727>>05606000
                   IF <> THEN GOTO IO'ERR;    << PCB is zero >><<02727>>05608000
                                                               <<02727>>05610000
           IF STATUS.(13:3) <> 1 THEN  << * * * ERROR * * * *>><<02727>>05612000
              BEGIN                                            <<02727>>05614000
     IO'ERR:      IOQ(C) := 0D;        << Clear the IOQ      >><<02727>>05616000
               << B := IOSTAT(STATUS); <<Convert to FS error >><<02727>>05618000
               << POST'ACB'ERROR (TNUM,B',B); >>               <<02727>>05620000
                  CHK'STAT := TRUE;                            <<02727>>05622000
                  RETURN;                                      <<02727>>05624000
              END;                                             <<02727>>05626000
                                                               <<02727>>05628000
           << Otherwise, if no error occurred, zero the IOQ, >><<02727>>05630000
           << and continue checking until no more IOQ in the >><<02727>>05632000
           << buffer. >>                                       <<02727>>05634000
           IOQ(C) := 0D;                                       <<02727>>05636000
           C:=C+1;                                             <<02727>>05638000
           END; << End of all IOQ's to be checked>>            <<02727>>05640000
                                                               <<02727>>05642000
     << If the last STATUS we processed is one that indicates>><<02727>>05644000
     << that we went past EOT, continue to check the other   >><<02727>>05646000
     << buffers to finish off writes before next reel.       >><<02727>>05648000
     IF STATUS.(8:8) = %31 << Write succeeded but past EOT   >><<02727>>05650000
        THEN FOUND'EOT := TRUE                                 <<02727>>05652000
        ELSE PROCESS'THIS'BUFFER:=FALSE;                       <<02727>>05654000
                                                               <<02727>>05656000
     IF N<>C THEN LAST'RECSIZE:=RSIZE(C-1); <<At least one>>   <<02730>>05658000
     C := B * MAXSECT;                                         <<02727>>05660000
     DO RSIZE(C):=0 UNTIL (C:=C+1) >= B'; <<Zero record sizes>><<02727>>05662000
                                                               <<02727>>05664000
     IF (B:=B+1)=NUMBUFF THEN B:=0;                            <<02727>>05666000
     IF B=G THEN PROCESS'THIS'BUFFER:=FALSE; <<Already done>>  <<02727>>05668000
     END;  << End PROCESS'THIS'BUFFER >>                       <<02727>>05670000
                                                               <<02727>>05672000
  IF NOT(FOUND'EOT) THEN RETURN; << Did not encounter EOT >>   <<02727>>05674000
                                                               <<02727>>05676000
  <<   Now write the trailer and start a new tape volume, if >><<02727>>05678000
  << necessary.  Records currently processed is A-1.         >><<02727>>05680000
        C:=(IF LAST'RECSIZE=1 THEN A-1 ELSE L);                <<02730>>05682000
  IF WRITETAPE(-LAST'RECSIZE,TDBUF<<Ignored>>,FALSE,           <<02727>>05684000
                     TDBUF,TRAILBL,TNUM,GNUM,K,C) THEN         <<02730>>05686000
     BEGIN << Error writing trailer or header >>               <<02727>>05688000
         C:=0;                                                 <<02727>>05690000
         DO IOQ(C):=0D UNTIL (C:=C+1)>=MAXSECT*NUMBUFF;        <<02727>>05692000
         STATUS:=%54; << Unit Failure Error >>                 <<02727>>05694000
         GOTO IO'ERR;                                          <<02727>>05696000
     END;                                                      <<02727>>05698000
  IF LAST'RECSIZE=1 AND K<>A-1 THEN FREAD(GNUM,GBUF,LRECLG);   <<02730>>05700000
  FOUND'EOT := FALSE;                                          <<02730>>05702000
END;  << END CHK'STAT >>                                       <<02727>>05704000
<<***********************************************************>><<02518>>05706000
<<          This subroutine packs a name for GENMSG          >><<02518>>05708000
<<***********************************************************>><<02518>>05710000
SUBROUTINE PACKNAME;                                           <<02518>>05712000
BEGIN                                                          <<02518>>05714000
TRAILBL := 0;                                                  <<U.RAO>>05716000
MOVE TRAILBL(1) := TRAILBL, (13);  <<ZERO OUT>>                <<U.RAO>>05718000
MOVE TRAILBL := GBUF, (4);  <<MOVE IN FILE NAME>>              <<U.RAO>>05720000
MOVE HTLBLS := HTLBLS WHILE AN,1; <<SCAN FOR BLANK OR 0>>      <<U.RAO>>05722000
BPS0 := ".";  <<INSERT FILE NAME DELIMITER>>                   <<U.RAO>>05724000
TOS := TOS+1;  <<BUMP POINTER PAST PERIOD>>                    <<U.RAO>>05726000
ASSEMBLE(DUP);  <<SAVE FOR NEXT SCAN WHILE>>                   <<U.RAO>>05728000
TOS := @GBUF(4)&LSL(1);                                        <<U.RAO>>05730000
MOVE * := *, (8);                                              <<U.RAO>>05732000
MOVE BPS0 := BPS0 WHILE AN,1;                                  <<U.RAO>>05734000
DELB;  <<POP POINTER FROM PREVIOUS MOVE>>                      <<U.RAO>>05736000
BPS0 := ".";                                                   <<U.RAO>>05738000
TOS := TOS+1;                                                  <<U.RAO>>05740000
ASSEMBLE(DUP);                                                 <<U.RAO>>05742000
TOS := @GBUF(8)&LSL(1);                                        <<U.RAO>>05744000
MOVE * := *, (8);                                              <<U.RAO>>05746000
MOVE BPS0 := BPS0 WHILE AN,1;                                  <<U.RAO>>05748000
BPS0 := 0;                                                     <<U.RAO>>05750000
DDEL                                                           <<U.RAO>>05752000
END;   <<SUBROUTINE PACKNAME>>                                 <<U.RAO>>05754000
<<vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv>>       <<U.RAO>>05756000
<< This subroutine is called when an error was        >>       <<U.RAO>>05758000
<< encountered in the middle of writing a file to     >>       <<U.RAO>>05760000
<< tape.  It fixes up the current file, unlocks all   >>       <<U.RAO>>05762000
<< the rest, puts out the error, then returns.        >>       <<U.RAO>>05764000
<<^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^>>       <<U.RAO>>05766000
SUBROUTINE TAPEFILEERRUNLD;                                    <<U.RAO>>05768000
BEGIN                                                          <<U.RAO>>05770000
P1 := GBUF(12).(8:8); <<PART OF DISC ADDR>>                    <<U.RAO>>05772000
FLSTORE := 0;                                                  <<U.RAO>>05774000
ATTACHIO(LDN,0,0,@FLAB,1,128,P1,GBUF(13),1);                   <<U.RAO>>05776000
UNLOCKSTORE (GNUM, FALSE, PVINFO, PREVGBUF);                   <<RC.PV>>05778000
FERROR'(TNUM,BRET);                                            <<02546>>05780000
CIERR(ARET := STORTAPEFSERR);  <<TAPE FILE ERROR OF SOME SORT>><<U.RAO>>05782000
ASSEMBLE(EXIT 2);  <<BAIL OUT>>                                <<U.RAO>>05784000
END;                                                           <<U.RAO>>05786000
<<++++++++++++++++++++++++++++++++++++++++++++++++++++>>       <<U.RAO>>05788000
<< This subroutine copes with misc tape file errors   >>       <<U.RAO>>05790000
<<++++++++++++++++++++++++++++++++++++++++++++++++++++>>       <<U.RAO>>05792000
SUBROUTINE TAPEFILEERROR(NEEDUNLOCK, UNLOCKSTATE);             <<U.RAO>>05794000
VALUE NEEDUNLOCK, UNLOCKSTATE;                                 <<U.RAO>>05796000
LOGICAL NEEDUNLOCK;  <<TRUE => UNLOCK FILES>>                  <<U.RAO>>05798000
LOGICAL UNLOCKSTATE;  <<TRUE => REWIND GOOD FILE BEFORE UNLOCK><<U.RAO>>05800000
BEGIN                                                          <<U.RAO>>05802000
ARET := STORTAPEFSERR;  <<FILE SYSTEM ERROR ON TAPE>>          <<02692>>05804000
IF NEEDUNLOCK THEN UNLOCKSTORE (GNUM,UNLOCKSTATE,PVINFO,       <<RC.PV>>05806000
                                PREVGBUF);                     <<RC.PC>>05808000
FERROR'(TNUM,BRET);                                            <<02546>>05810000
CIERR(ARET);  <<UNABLE TO COMPLETE STORE DUE TO TAPE FILE ERROR<<U.RAO>>05812000
ASSEMBLE(EXIT 2);  <<BAIL OUT>>                                <<U.RAO>>05814000
END;                                                           <<02518>>05816000
<<***********************************************************>><<02518>>05818000
<<                 CLEANUP FSTORE RESOURCES                  >><<02518>>05820000
<<***********************************************************>><<02518>>05822000
SUBROUTINE RELEASE'FSTORE;                                     <<02518>>05824000
BEGIN                                                          <<02518>>05826000
   IF BUFF=0 THEN RETURN;                                      <<02518>>05828000
   E:=0;                                                       <<02518>>05830000
   WHILE BUFF(E)<>CURBUFF DO E:=E+1;                           <<02518>>05832000
   B':=E;                                                      <<02518>>05834000
   DO BEGIN                                                    <<02518>>05836000
      C:=0;                                                    <<02518>>05838000
      DO BEGIN                                                 <<02518>>05840000
         IF IOQ(E*MAXSECT+C)<>0D THEN                          <<02518>>05842000
            WAITFORIO(IOQW((E*MAXSECT+C)&LSL(1)));             <<02518>>05844000
         IOQ(E*MAXSECT+C):=0D;                                 <<02518>>05846000
         END UNTIL (C:=C+1)>MAXSECT;                           <<02518>>05848000
      IF BUFF(E)<>0 THEN                                       <<02518>>05850000
         BEGIN                                                 <<02518>>05852000
            IF BUFF'STAT(E)= 2 THEN  UNFREEZE(BUFF(E),1,0);    <<02645>>05854000
            IF BUFF'STAT(E)>=1 THEN UNLOCKSEG(BUFF(E),1,0);    <<02645>>05856000
            RELDATASEG(BUFF(E));                               <<02518>>05858000
            BUFF(E) := 0;                                      <<02518>>05860000
         END;                                                  <<02518>>05862000
      IF (E:=E+1)=NUMBUFF THEN E:=0;                           <<02518>>05864000
      END UNTIL E=B';                                          <<02518>>05866000
END; << END RELEASE'FSTORE >>                                  <<02518>>05868000
<<'''''''''''''''''''''''''''''''''''''''''''''''''''''>>      <<U.RAO>>05870000
<< This subroutine copes with misc errors on file GOOD >>      <<U.RAO>>05872000
<<'''''''''''''''''''''''''''''''''''''''''''''''''''''>>      <<U.RAO>>05874000
SUBROUTINE GOODFILEERROR;                                      <<U.RAO>>05876000
BEGIN                                                          <<U.RAO>>05878000
ARET := STORSCRFLFSERR;                                        <<U.RAO>>05880000
FERROR'(GNUM, BRET);                                           <<U.RAO>>05882000
CIERR(ARET);                                                   <<U.RAO>>05884000
ASSEMBLE(EXIT 2);  <<BAIL OUT>>                                <<U.RAO>>05886000
END;                                                           <<U.RAO>>05888000
<<***********************************************************>><<02518>>05890000
<<                 NOBUF NOWAITIO WRITE                      >><<02518>>05892000
<<***********************************************************>><<02518>>05894000
DOUBLE SUBROUTINE WRITE'NOWAITIO;                              <<02518>>05896000
BEGIN                                                          <<02518>>05898000
   B:=D:=0;                                                    <<02518>>05900000
   WHILE CURBUFF<>BUFF(B) DO B:=B+1;                           <<02518>>05902000
   TOS:=B;     TOS:=MAXSECT;                                   <<02518>>05904000
   ASSEMBLE(DDUP,MPY,DDUP,ADD);                                <<02518>>05906000
   B':=TOS+1;  << ALLOW ONE MORE FOR TM >>                     <<02518>>05908000
   C:=TOS;                                                     <<02518>>05910000
   ASSEMBLE(DDEL);                                             <<02518>>05912000
   WHILE C<=B' AND RSIZE(C)<>0 DO                              <<02518>>05914000
      BEGIN                                                    <<02518>>05916000
        F := IF RSIZE(C)=1 THEN WEOF ELSE TWRITE;              <<02518>>05918000
        IOQ(C) := ATTACHIO(LDEV,0,CURBUFF,D,F,RSIZE(C),        <<02727>>05920000
                           0,4 <<Write past EOT>>,0<<Flags>>); <<02727>>05922000
        D := D + RSIZE(C);                                     <<02518>>05924000
        C := C + 1;                                            <<02518>>05926000
      END;                                                     <<02518>>05928000
   CURBUFF := BUFF(IF (B:=B+1)=NUMBUFF THEN 0 ELSE B);         <<02518>>05930000
END;  << END WRITE'NOWAITIO >>                                 <<02518>>05932000
                                                               <<02546>>05936000
<<********************************************************************>>05938000
<<       FSTORE Main Procedure                                        >>05940000
<<    First, write header label and tape directory (one tape file).   >>05942000
<<********************************************************************>>05944000
   FCONTROL(GNUM,REWIND,I);                                    <<02546>>05946000
   IF <> THEN      << unable to rewind Good file >>            <<02546>>05948000
      GOODFILEERROR;     << never returns >>                   <<02546>>05950000
                                                               <<02558>>05952000
   << When TNUM is negative, the user did not specify a >>     <<02558>>05954000
   << record size for a 6250 BPI unlabelled tape. >>           <<02558>>05956000
   << FGETINFO will return a record size of 4096 words, >>     <<02558>>05958000
   << but the tape should actually be written at 8192. >>      <<02558>>05960000
   IF TNUM < 0 THEN                                            <<02558>>05962000
      BEGIN    << Special case >>                              <<02558>>05964000
      TNUM := -TNUM;                                           <<02558>>05966000
      DEFAULT'6250 := TRUE;                                    <<02558>>05968000
      END                                                      <<02558>>05970000
   ELSE        << Normal processing >>                         <<02558>>05972000
      DEFAULT'6250 := FALSE;                                   <<02558>>05974000
                                                               <<02558>>05976000
   << Set up for labeled tape >>                               <<02546>>05978000
   TRAILBL := 0;                                               <<02546>>05980000
   MOVE TRAILBL(1) := TRAILBL,(39);                            <<02546>>05982000
   FGETINFO(TNUM,,FOPTIONS,,TAPEBLOCKSIZE,DEVTYPE,LDEV);       <<02546>>05984000
   IF <> THEN TAPEFILEERROR(TRUE,TRUE);   << error - quit. >>  <<02546>>05986000
   IF DEFAULT'6250 THEN TAPEBLOCKSIZE:=8192;                   <<02658>>05988000
                                                                        05990000
<< Limit the number of records to be streamed to the HP7976 >> <<02658>>05992000
<< to no more than 10 (or 20 since there are 2 data segment >> <<02658>>05994000
<< buffers), else we'll use too many IOQs.                  >> <<02658>>05996000
   WHILE (MAXDS/TAPEBLOCKSIZE)>10 <<10 IOQs per XDS>> DO       <<02658>>05998000
      BEGIN                                                    <<02658>>06000000
      MAXDS:=(IF MAXDS>30000 THEN 16384                        <<02658>>06002000
              ELSE MAXDS&LSR(1));                              <<02658>>06004000
      END;                                                     <<02658>>06006000
                                                               <<02658>>06008000
   ZFIELD := 0;                                                <<02546>>06010000
   REELNUM := 1;        << physical reel number >>             <<02546>>06012000
   MOVE HTLBLS := LABELTEXT;      << identification >>         <<02546>>06014000
   TOS := CALENDAR;          << Get date >>                    <<02546>>06016000
   TOS := CLOCK;             << and time >>                    <<02546>>06018000
   CHSSTT := TOS;                                              <<02546>>06020000
   CHHHMM := TOS;                                              <<02546>>06022000
   CHDATE := TOS;                                              <<02546>>06024000
   MOVE IIBID := "VIIB";                                       <<02546>>06026000
   SPANTOG := 0;     << This is first file on first volume. >> <<02546>>06028000
                                                               <<02546>>06030000
   << Allocate tape block buffer.  When using ATTACHIO, >>     <<02558>>06034000
   << need at most 4096 words. >>                              <<02558>>06036000
   STACK'INC := TAPEBLOCKSIZE;                                 <<02558>>06038000
   IF (STACK'INC > 4096) AND USING'ATTIO THEN                  <<02558>>06040000
      STACK'INC := 4096;                                       <<02558>>06042000
                                                               <<02546>>06044000
   PUSH(S);                                                    <<02546>>06046000
   @TDBUF := TOS+1;                                            <<02546>>06048000
   TOS := STACK'INC;                                           <<02558>>06050000
   ASSEMBLE (ADDS 0);                                          <<02546>>06052000
   FFILEINX := L;      << First file is partial >>             <<02546>>06054000
   TOS := -1;                                                  <<02546>>06056000
   X := 39;                                                    <<02546>>06058000
   DO TOS := TOS XOR LOGICAL(HDRLBL(X)) UNTIL (X := X-1) <= 0; <<02546>>06060000
   CHKSUM := TOS;                                              <<02546>>06062000
   IF LABELED THEN                                             <<02546>>06064000
      FWRITELABEL(TNUM,HDRLBL,40)    << Write header label >>  <<02546>>06066000
   ELSE                                                        <<02546>>06068000
      FWRITE(TNUM,HDRLBL,40,0);                                <<02546>>06070000
   IF <> THEN   << Bad news if can't write 40 word header! >>  <<02546>>06072000
      TAPEFILEERROR(TRUE,TRUE);  << Bail out and unlock. >>    <<02546>>06074000
   IF NOT LABELED THEN                                         <<02546>>06076000
      BEGIN         << Write EOF after header label. >>        <<02546>>06078000
      FCONTROL(TNUM,WEOF,I);                                   <<02546>>06080000
      IF <> THEN   << Can't write EOF after header? Ouch! >>   <<02546>>06082000
         TAPEFILEERROR(TRUE,TRUE);  << Bail out. >>            <<02546>>06084000
      END;                                                     <<02546>>06086000
   B := 0;                                                     <<02546>>06088000
   WHILE B < NUMBUFF DO                                        <<02546>>06090000
      BEGIN                                                    <<02546>>06092000
      IF USING'ATTIO THEN                                      <<02558>>06094000
         BEGIN                                                 <<02546>>06096000
         BUFF'STAT(B):=0; << For error conditions during the >><<02645>>06098000
            << allocation of an XDS, the XDS needs to be re- >><<02645>>06100000
            << frozen, unlocked, and/or released.            >><<02645>>06102000
 GETDST: L:=GETDATASEG((MAXDS+10<<Sys comm.>>),0);             <<02562>>06104000
         IF < THEN                                             <<02562>>06106000
            IF (MAXDS:=(IF MAXDS>30000 THEN 16384 ELSE         <<02562>>06108000
                        (MAXDS&LSR(1))))<TAPEBLOCKSIZE         <<02573>>06110000
               THEN BEGIN << Buffer smaller than rec size >>   <<02573>>06112000
                      ARET := INSUFFMEMORY;                    <<02573>>06114000
      MEM'ERR:        UNLOCKSTORE (GNUM,FALSE,PVINFO,PREVGBUF);<<02625>>06116000
                      B':=0;                                   <<02645>>06118000
                      WHILE B'<B DO                            <<02645>>06120000
                         BEGIN << RELEASE ACQUIRED BUFFERS >>  <<02645>>06122000
                         IF BUFF'STAT(B')=2 THEN               <<02645>>06124000
                            UNFREEZE(BUFF(B'),1,0);            <<02645>>06126000
                         IF BUFF'STAT(B')>=1 THEN              <<02645>>06128000
                            UNLOCKSEG(BUFF(B'),1,0);           <<02645>>06130000
                         IF BUFF(B')>0 THEN                    <<02645>>06132000
                            RELDATASEG(BUFF(B'));              <<02645>>06134000
                         B' := B' + 1;                         <<02645>>06136000
                         END;                                  <<02645>>06138000
                      CIERR(ARET);                             <<02645>>06140000
                      BRET := 0;                               <<02625>>06142000
                      RETURN;                                  <<02625>>06144000
                    END                                        <<02573>>06146000
               ELSE GOTO GETDST;                               <<02573>>06148000
         IF L=0 THEN                                           <<02562>>06150000
            BEGIN << Unable to get Extra Data Seg >>           <<02562>>06152000
   XDS'ERROR: ARET := DATASEGERROR;                            <<02645>>06154000
              GOTO MEM'ERR;                                    <<02625>>06156000
            END;                                               <<02562>>06158000
         BUFF(B) := L;                                         <<02645>>06160000
         LOCKSEG(L,1,0);                                       <<02645>>06162000
         IF < THEN GO XDS'ERROR;                               <<02645>>06164000
         BUFF'STAT(B):=1;  << XDS is now locked >>             <<02645>>06166000
         FREEZE (L,1,0);                                       <<02645>>06168000
         IF < THEN GO XDS'ERROR;                               <<02645>>06170000
         BUFF'STAT(B):=2;  << XDS is now locked and frozen >>  <<02645>>06172000
         END ELSE BUFF(B) := 0;                                <<02546>>06174000
      B := B+1;                                                <<02546>>06176000
      END;                                                     <<02546>>06178000
                                                               <<02573>>06180000
   << Set size of disk block buffer(s) >>                      <<02573>>06182000
   MAXSECT := MAXDS / 128;                                     <<02573>>06184000
   NLRPTR := IF USING'ATTIO THEN MAXSECT                       <<02573>>06186000
             ELSE TAPEBLOCKSIZE / 128;                         <<02573>>06188000
   @BP := @TDBUF;                                              <<02546>>06190000
   L := 0;                                                     <<02562>>06192000
   DIREC'TO'TAPE(GNUM,L,TDBUF,TRAILBL,TNUM,K,L);               <<02546>>06194000
   IF LABELED THEN                                             <<02546>>06196000
      BEGIN        << Close directory file and open next >>    <<02546>>06198000
      NEXTTAPEFILE(TNUM);                                      <<02546>>06200000
      IF <> THEN TAPEFILEERROR(TRUE,TRUE);                     <<02546>>06202000
      END;                                                     <<02546>>06204000
<<*******************************************************************>> 06206000
<<          Now dump specified disk files to tape.                   >> 06208000
<<          ( one disk file per tape file )                          >> 06210000
<<*******************************************************************>> 06212000
   FCONTROL(GNUM,REWIND,I);                                    <<02546>>06214000
   IF <> THEN   << Unable to rewind GOOD file >>               <<02546>>06216000
      GOODFILEERROR;    << Never returns >>                    <<02546>>06218000
   PVINFO := 0;    B := -1;    L := 0;    PREVGBUF := 0;       <<02546>>06220000
   WHILE (B := B+1) <= NUMBUFF*MAXSECT DO IOQ(B) := 0D;        <<02546>>06222000
   CURBUFF := BUFF(0);                                         <<02546>>06224000
   PREVGBUF := 0;                                              <<02546>>06226000
NEXTFILE:                                                      <<02546>>06228000
      IF REQUESTSERVICE THEN    <<BREAK>>                               06230000
        BEGIN                                                           06232000
           UNLOCKSTORE (GNUM,FALSE,PVINFO,PREVGBUF);           <<RC.PV>>06234000
           ARET := STORBREAK;                                  <<U.RAO>>06236000
          RELEASE'FSTORE;                                      <<02518>>06238000
           RETURN;                                                      06240000
        END;                                                            06242000
      FREAD(GNUM,GBUF,LRECLG);                                 <<U.RAO>>06244000
      IF < THEN   <<ERROR ON READ OF GOOD FILE>>               <<U.RAO>>06246000
         GOODFILEERROR;                                        <<U.RAO>>06248000
      IF > THEN                                                <<RV.PV>>06250000
      BEGIN  <<EOF ON GFILE>>                                  <<RV.PV>>06252000
          CHKFORDISMOUNT (PVINFO,0,PREVGBUF);                  <<RC.PV>>06254000
          GO TO ENDLOGREEL;                                    <<RV.PV>>06256000
      END;                                                     <<RV.PV>>06258000
      L:=L+1;  A:=A+1;  << Increment # files processed >>      <<02717>>06260000
      P1 := GBUF(12).(8:8);                                             06262000
      LDN := GBUF(12).(0:8);   << RCSTORE CONVERTED FVOLPNTR TO LDN >>  06264000
      CHKFORDISMOUNT (PVINFO,GBUF (14),PREVGBUF);              <<RC.PV>>06266000
      PVINFO := GBUF (14);                                     <<RV.PV>>06268000
      IOB := ATTACHIO(LDN,0,0,@FLAB,0,128,P1,GBUF(13),1);               06270000
      <<JUST READ FILE LABEL>>                                          06272000
      IF STATUS.(13:3) <> 1 THEN   <<ATTACHIO FAILED>>         <<U.RAO>>06274000
         BEGIN                                                 <<U.RAO>>06276000
         PACKNAME;   <<NAME OF FILE ON WHICH IT FAILED>>       <<U.RAO>>06278000
         UNLOCKSTORE (GNUM, FALSE, PVINFO, PREVGBUF);          <<RC.PV>>06280000
         CIERR(ARET := STOR'ATTIO'FAIL,, 0, @HTLBLS);          <<U.RAO>>06282000
         BRET := 0;                                            <<U.RAO>>06284000
         RETURN;                                               <<U.RAO>>06286000
         END;                                                  <<U.RAO>>06288000
      IF FLFOPTIONS.(8:2)=1 THEN TOS:=FLFLIM ELSE TOS:=FLEOF;           06290000
   IF FLFOPTIONS.(2:3) = 2 THEN         <<RIO file>>           <<04305>>06292000
         << RIO files have a very special format.            >><<04305>>06294000
         << At the end of each block is a bit map which      >><<04305>>06296000
         << tells if each record in the block is allocated.  >><<04305>>06298000
         << The blocksize in words of a RIO file is          >><<04305>>06300000
         <<  (recsize in words)*(blockfactor) + blockfactor/8>><<04305>>06302000
         << So the blockfactor of a RIO file is              >><<04305>>06304000
         <<  (16*blksize in words)/((16*recsize in words)+1) >><<04305>>06306000
      BEGIN                                                    <<04305>>06308000
         BLK'SIZE := DOUBLE(FLBLKSIZE) & DASL(4);              <<04305>>06310000
         IF FLRECSIZE = 0 THEN REC'SIZE := 128D                <<04305>>06312000
         ELSE IF FLRECSIZE<0 THEN                              <<04305>>06314000
            REC'SIZE := DOUBLE ( (-FLRECSIZE+1) & LSR(1) )     <<04305>>06316000
         ELSE REC'SIZE := DOUBLE (FLRECSIZE);                  <<04305>>06318000
         REC'SIZE := (REC'SIZE & DASL(4)) + 1D;                <<04305>>06320000
         BLK'FACT := INTEGER(BLK'SIZE / REC'SIZE);             <<04305>>06322000
         X := BLK'FACT;                                        <<04305>>06324000
      END                                                      <<04305>>06326000
   ELSE                                                        <<04305>>06328000
                                                               <<04305>>06330000
   BEGIN                                                       <<04305>>06332000
      TOS := FLBLKSIZE ;                                                06334000
      TOS := FLRECSIZE ;                                                06336000
      IF = THEN  TOS:=TOS+128  ELSE                                     06338000
         IF < THEN TOS:=(-TOS+1)&LSR(1);                                06340000
      ASSEMBLE(DIV,DEL);                                                06342000
      X := TOS;   <<BLOCKING FACTOR>>                                   06344000
   END;                                                        <<04305>>06346000
                                                               <<04305>>06348000
      ASSEMBLE(ZERO,CAB;LDXA,LDIV;CAB,LDXA;LDIV);                       06350000
            << IF END-OF-FILE MOD BLOCKFACTOR <> 0 THEN BUMP BLK COUNT>>06352000
      IF TOS <> 0 THEN TOS:=TOS+1D;  << EOF IN BLOCKS >>                06354000
      X:=(FLBLKSIZE+127)&LSR(7);   << SECTORS PER BLOCK >>              06356000
               << BLOCKS *  SECTORS PER BLOCK >>                        06358000
      ASSEMBLE(LDXA,LMPY; CAB,LDXA; MPY,ZERO; DADD,ZERO);               06360000
      TOS := FLSECTOFF;                                                 06362000
      ASSEMBLE(DADD);  <<TOTAL NUMBER OF USED SECTORS>>                 06364000
<<                                                          >> <<03750>>06366000
<< STORE previously calculated the sector count for variable>> <<03750>>06368000
<< files was to add up the sectors in all the allocated     >> <<03750>>06370000
<< extents.  The new method which takes care of MSG or CIR  >> <<03750>>06372000
<< files adds up the sectors in all the extents.  Then      >> <<03750>>06374000
<< afterwards the sector count is pushed back to the last   >> <<03750>>06376000
<< allocated extent.  This takes care of files which have   >> <<03750>>06378000
<< non-allocated extents in between allocated extents, a    >> <<03750>>06380000
<< circumstance that only happens in MSG and CIR files.     >> <<03750>>06382000
      IF FLFOPTIONS.(8:2)=1 THEN                                        06384000
        BEGIN  <<VARIABLE LENGTH RECORDS>>                              06386000
          SECTORS := 0D;                                                06388000
          I := -1;                                                      06390000
          WHILE (I:=I+1) < FLNUMEXTS DO                                 06392000
                                                               <<03750>>06394000
             SECTORS:=SECTORS+DOUBLE(LOGICAL(FLEXTSIZE));      <<00714>>06396000
                                                               <<03750>>06398000
                                                               <<03750>>06400000
              TOS := FLEXTSIZE;                                <<00714>>06402000
              ASSEMBLE(LDIV,DELB; TEST);                                06404000
              IF = THEN                                                 06406000
                BEGIN  <<NORMAL SIZED>>                                 06408000
                  DEL;                                                  06410000
                  TOS := FLEXTSIZE;                                     06412000
                END;                                                    06414000
              ASSEMBLE(ZERO,XCH);                                       06416000
              SECTORS := TOS+SECTORS;                                   06418000
                                                               <<03750>>06420000
                                                               <<03750>>06422000
        END                                                             06424000
      ELSE SECTORS := TOS;   <<# OF USED SECTORS>>                      06426000
<< The next few lines of code take care of a problem        >> <<03750>>06428000
<< that occurs when eof occurs in a non-allocated extent    >> <<03750>>06430000
<< The method is to move the eof pointer back to the last   >> <<03750>>06432000
<< allocated extent.                                        >> <<03750>>06434000
      NUM'EXTENTS :=(SECTORS-1D)// LOGICAL(FLEXTSIZE);         <<03750>>06436000
      HOLD'EXTENTS := NUM'EXTENTS;                             <<03750>>06438000
      WHILE FLABDBL (22 + NUM'EXTENTS) = 0D DO                 <<03750>>06440000
         NUM'EXTENTS := NUM'EXTENTS -1;                        <<03750>>06442000
      IF NUM'EXTENTS < HOLD'EXTENTS THEN                       <<03750>>06444000
         SECTORS :=DOUBLE(NUM'EXTENTS+1)                       <<03750>>06446000
                     * DOUBLE (FLEXTSIZE);                     <<03750>>06448000
<<------------------------------------------------------------------->> 06450000
<<    NOTE:   THE FOLLOWING ALGORITHM TAKES ADVANTAGE OF THE FACT    >> 06452000
<<            THAT SECTORS WITHIN AN EXTENT ARE CONTIGUOUS.          >> 06454000
<<            (I.E., ONE ATTIO READS MULTIPLE SECTORS).              >> 06456000
<<------------------------------------------------------------------->> 06458000
      GBUF (14) := REELNUM;  <<VOLUME # WHERE FILE WAS STORED>><<RV.RS>>06460000
      FUPDATE (GNUM,GBUF,15);                                  <<RV.RS>>06462000
      VTABTOLDEV (DEXTMAP,FLEXTMAPD,FLNUMEXTS+1,MVTABX);       <<28.PV>>06464000
          <<PUTS ADDRESSES IN DEXTMAP - LDEV IN LEFTMOST BYTE>>         06466000
      BLOCKSFILLED := I := 0;                                           06468000
      DO BEGIN << PER EXTENT >>                                         06470000
            @ENTRE := I&LSL(1) + @EXTMAP;                               06472000
                                                                        06474000
            TOS := SECTORS;                                             06476000
            TOS := 0;                                                   06478000
            TOS := FLEXTSIZE;                                           06480000
            ASSEMBLE(DSUB);                                             06482000
            IF < THEN                                                   06484000
               BEGIN                                                    06486000
                  CNT := INTEGER(SECTORS);                              06488000
                  SECTORS := 0D;                                        06490000
                  DDEL;                                                 06492000
               END ELSE                                                 06494000
               BEGIN                                                    06496000
                  CNT := FLEXTSIZE;                                     06498000
                  SECTORS := TOS;                                       06500000
               END;                                                     06502000
            IF ENTRE=0D THEN GO NULLEXT;      << NULL EXTENT >>         06504000
            NN := 0;                                                    06506000
            XLDN:=BEXTMAP(I*4);                                         06508000
            BEXTMAP(X):=0;  <<NOW ENTRE HAS A VALID DISKADDR>>          06510000
            WHILE NN < CNT DO                                           06512000
               BEGIN        << SECTORS WITHIN EXTENT I >>               06514000
                 IF USING'ATTIO THEN                           <<02558>>06516000
                    BEGIN                                      <<02518>>06518000
                    M := 0;                                    <<02518>>06520000
                    WHILE CURBUFF<>BUFF(M) DO M:=M+1;          <<02518>>06522000
                    IF CHK'STAT(BUFF(M)) THEN                  <<02518>>06524000
                       BEGIN                                   <<02518>>06526000
                       RELEASE'FSTORE;                         <<02518>>06528000
                       TAPEFILEERRUNLD;                        <<02518>>06530000
                       END;                                    <<02518>>06532000
                    END;                                       <<02518>>06534000
                  SECTORSLEFT := CNT - NN;                              06536000
                  IF USING'ATTIO THEN                          <<02558>>06538000
                     MM := MAXSECT      ELSE                   <<02518>>06540000
                     MM := NLRPTR - BLOCKSFILLED;              <<02518>>06542000
                  IF SECTORSLEFT < MM THEN MM := SECTORSLEFT;           06544000
                  TOS := 0;                                             06546000
                  TOS := NN;                                            06548000
                  DISKADR := TOS + ENTRE;                               06550000
                  IF USING'ATTIO THEN                          <<02558>>06552000
                     BEGIN      << read into XDS >>            <<02546>>06554000
                      B := 0;                                  <<02518>>06556000
                      WHILE CURBUFF<>BUFF(B) DO B:=B+1;        <<02518>>06558000
                      D := MM * 128<<WORDS PER SECTOR>>;       <<02518>>06560000
                      B := B*MAXSECT;     B' := B+MAXSECT;     <<02518>>06562000
                      C := D;                                  <<02518>>06564000
                         WHILE B<B' AND C<>0 DO                <<02518>>06566000
                           BEGIN                               <<02518>>06568000
                           RSIZE(B):=(IF C>TAPEBLOCKSIZE THEN  <<02518>>06570000
                                      TAPEBLOCKSIZE ELSE C);   <<02518>>06572000
                           IF (C:=C-TAPEBLOCKSIZE)<0 THEN C:=0;<<02518>>06574000
                           B:=B+1;                             <<02518>>06576000
                           END;                                <<02518>>06578000
                     IF (NN+MM)=CNT THEN                       <<02518>>06580000
                        IF (SECTORS=0D) OR (I+1)>FLNUMEXTS THEN<<02518>>06582000
                           RSIZE(B):=1;<<put tape make at end>><<02518>>06584000
                     IOB:=ATTACHIO(XLDN,0,CURBUFF,0,0,D,       <<02518>>06586000
                                   P1,P2,1);                   <<02518>>06588000
                     END                                       <<02518>>06590000
                  ELSE << read into stack >>                   <<02518>>06592000
                  IOB := ATTACHIO(XLDN,0,0,@TDBUF(BLOCKSFILLED&LSL(7)), 06594000
                                    0,MM&LSL(7),P1,P2,1);               06596000
                  IF STATUS.(13:3) <> 1 THEN                            06598000
                     BEGIN      << REWRITE FILE LABEL AND UNLOCK >>     06600000
                        P1:=GBUF(12).(8:8);                    <<U.RAO>>06602000
                        MSIR:=GETSIR(FISIR);<<File label SIR>> <<01022>>06604000
                        IOB:=ATTACHIO(LDN,0,0,@FLAB,0,128,P1,  <<01022>>06606000
                             GBUF(13),1); << Read label >>     <<01022>>06608000
                        IF STATUS.(13:3)=1 THEN                <<01022>>06610000
                        BEGIN                                  <<01022>>06612000
                        FLSTORE := 0;                          <<U.RAO>>06614000
                        ATTACHIO(LDN,0,0,@FLAB,1,128,P1,GBUF(13),1);    06616000
                        END;                                   <<01022>>06618000
                        RELSIR(FISIR,MSIR);<<Release lbl SIR>> <<01022>>06620000
                        UNLOCKSTORE (GNUM,FALSE,PVINFO,        <<RC.PV>>06622000
                                     PREVGBUF);                <<RC.PV>>06624000
                        PACKNAME;                              <<U.RAO>>06626000
                        CIERR(ARET:= STOR'ATTIO'FAIL,,0,@HTLBLS);<<RAO>>06628000
                        BRET := 0;                             <<U.RAO>>06630000
                        RETURN;                                         06632000
                     END;                                               06634000
                  IF (BLOCKSFILLED:=(BLOCKSFILLED+INTEGER(MM)) <<02518>>06636000
                     MOD NLRPTR)=0 AND USING'FILESYS THEN      <<02558>>06638000
                     BEGIN                                     <<02518>>06642000
                     IF WRITETAPE (TPBLK,TDBUF,FALSE,          <<RV.RS>>06644000
                      TDBUF,TRAILBL,TNUM,GNUM,K,L) THEN        <<02546>>06646000
                        TAPEFILEERRUNLD;  <<STOP>>             <<U.RAO>>06648000
                     END;                                      <<02518>>06650000
                  IF USING'ATTIO THEN                          <<02558>>06652000
                     IF D<>0 THEN WRITE'NOWAITIO;              <<02518>>06654000
                  NN := NN + MM;                                        06656000
               END;                                                     06658000
 NULLEXT:   I:=I+1;                                                     06660000
         END UNTIL SECTORS=0D  OR  I>FLNUMEXTS;                         06662000
      IF SECTORS <> 0D THEN SUDDENDEATH(531);                           06664000
<<                                                                   >> 06666000
<<  End of disk file.  Flush partial tape file and WEOF.         >>     06668000
<<  Then unlock the disk file to enable use by others.           >>     06670000
<<                                                                   >> 06672000
   IF BLOCKSFILLED > 0 AND USING'FILESYS THEN                  <<02558>>06678000
       IF WRITETAPE (BLOCKSFILLED&LSL(7),TDBUF,FALSE,TDBUF,    <<02546>>06680000
        TRAILBL,TNUM,GNUM,K,L) THEN TAPEFILEERRUNLD;           <<02546>>06682000
   IF LABELED THEN                                             <<02546>>06684000
      BEGIN                                                    <<02546>>06686000
      NEXTTAPEFILE(TNUM);                                      <<02546>>06688000
      IF <> THEN TAPEFILEERRUNLD;                              <<02546>>06690000
      IF LDIRECTF(TNUM) THEN                                   <<02546>>06692000
         BEGIN    << Reelswitch was done; write directory file <<02546>>06694000
         DIREC'TO'TAPE(GNUM,L,TDBUF,TRAILBL,TNUM,K,L);         <<02546>>06696000
         NEXTTAPEFILE(TNUM);                                   <<02546>>06698000
         IF <> THEN TAPEFILEERRUNLD;                           <<02546>>06700000
         END;                                                  <<02546>>06702000
      END                                                      <<02546>>06704000
   ELSE                                                        <<02546>>06706000
      IF USING'FILESYS THEN                                    <<02558>>06710000
      IF WRITETAPE(0,TDBUF,FALSE, <<WEOF>>                     <<02546>>06712000
         TDBUF,TRAILBL,TNUM,GNUM,K,L) THEN                     <<02546>>06714000
         TAPEFILEERRUNLD;                                      <<U.RAO>>06716000
      P1 := GBUF(12).(8:8);                                             06720000
      MSIR:=GETSIR(FISIR);<< Get file label SIR >>             <<01022>>06722000
      IOB := ATTACHIO(LDN,0,0,@FLAB,0,128,P1,GBUF(13),1);      <<01022>>06724000
      IF STATUS.(13:3) <> 1 THEN                               <<01022>>06726000
           BEGIN                                               <<01022>>06728000
               RELSIR(FISIR,MSIR); << Release label SIR >>     <<01022>>06730000
               UNLOCKSTORE (GNUM,FALSE,PVINFO,PREVGBUF);       <<01022>>06732000
               PACKNAME;                                       <<01022>>06734000
               CIERR(ARET := STOR'ATTIO'FAIL,,0,@HTLBLS);      <<01022>>06736000
               BRET := 0;                                      <<01022>>06738000
               RETURN;                                         <<01022>>06740000
           END;                                                <<01022>>06742000
      FLSTORE := 0;    <<UNLOCK FILE>>                                  06744000
      IOB := ATTACHIO(LDN,0,0,@FLAB,1,128,P1,GBUF(13),1);               06746000
      IF STATUS.(13:3) <> 1 THEN                                        06748000
           BEGIN                                                        06750000
               RELSIR(FISIR,MSIR); << Release label SIR >>     <<01022>>06752000
               UNLOCKSTORE (GNUM,FALSE,PVINFO,PREVGBUF);       <<RC.PV>>06754000
               PACKNAME;                                       <<U.RAO>>06756000
               CIERR(ARET := STOR'ATTIO'FAIL,,0,@HTLBLS);      <<U.RAO>>06758000
               BRET := 0;                                      <<U.RAO>>06760000
               RETURN;                                                  06762000
           END;                                                         06764000
      RELSIR(FISIR,MSIR);          << Release label SIR >>     <<01022>>06766000
      MOVE PREVGBUF := GBUF, (15);                             <<01521>>06768000
      GO NEXTFILE ;                                                     06770000
      DEBUG;       << dummy call >>                            <<02546>>06772000
<<*******************************************************************>> 06774000
<<  All files have been Stored and unlocked; close logical reel.     >> 06776000
<<*******************************************************************>> 06778000
ENDLOGREEL:                                                    <<02546>>06780000
   IF USING'ATTIO THEN                                         <<02558>>06782000
      BEGIN    << Wait for I/O to complete >>                  <<02546>>06784000
      M:=0;  A:=A+1;                                           <<02717>>06786000
      WHILE CURBUFF <> BUFF(M) DO M := M+1;                    <<02546>>06788000
      DO BEGIN << Finish off writes >>                         <<02717>>06790000
      IF CHK'STAT(BUFF(M)) THEN                                <<02546>>06792000
         BEGIN                                                 <<02546>>06794000
         RELEASE'FSTORE;                                       <<02546>>06796000
         TAPEFILEERRUNLD;                                      <<02546>>06798000
         END;                                                  <<02546>>06800000
      IF (M:=M+1)=NUMBUFF THEN M:=0;                           <<02717>>06802000
      END UNTIL (BUFF(M)=CURBUFF);                             <<02717>>06804000
      END;                                                     <<02546>>06808000
   IF LABELED THEN RETURN;                                     <<02546>>06810000
   IF ZFIELD = 1 THEN RETURN;                                  <<02546>>06814000
   ZFIELD := 1;            << Indicate end of logical reel >>  <<02546>>06816000
   IF WRITETAPE(40,TRAILBL,TRUE,                               <<02546>>06818000
         TDBUF,TRAILBL,TNUM,GNUM,K,L) OR                       <<02546>>06820000
      WRITETAPE(0,TDBUF<<ignored>>,TRUE,                       <<02546>>06822000
         TDBUF,TRAILBL,TNUM,GNUM,K,L) OR                       <<02546>>06824000
      WRITETAPE(0,TDBUF<<ignored>>,TRUE,                       <<02546>>06826000
         TDBUF,TRAILBL,TNUM,GNUM,K,L) THEN                     <<02546>>06828000
      BEGIN                                                    <<02546>>06830000
      RELEASE'FSTORE;                                          <<02546>>06832000
      TAPEFILEERROR(FALSE,FALSE);                              <<02546>>06834000
      END;                                                     <<02546>>06836000
TAPE'EOJ:  RELEASE'FSTORE;                                     <<02717>>06838000
   END;     << procedure FSTORE >>                             <<02546>>06840000
$PAGE "UNLOCKSTORE  --  UNLOCK FILES LOCKED BY STORE"                   06842000
 PROCEDURE UNLOCKSTORE (GNUM,REW,PVINFO,PREVGBUF);             <<RC.PV>>06844000
   VALUE GNUM,REW,PVINFO;                                      <<RV.PV>>06846000
   INTEGER GNUM;                                                        06848000
   LOGICAL REW,PVINFO;                                         <<RV.PV>>06850000
   ARRAY PREVGBUF;                                             <<RC.PV>>06852000
   OPTION PRIVILEGED,UNCALLABLE,VARIABLE;                      <<RV.PV>>06854000
<<*******************************************************************>> 06856000
<<                                                                      06858000
      UNLOCKSTORE IS A PROCEDURE WHICH IS INVOKED ONLY WHEN AN ERROR    06860000
      OCCURS BETWEEN THE TIME THE FIRST DISK FILE IS LOCKED DOWN FOR    06862000
      EXCLUSIVE USE AND THE TIME THE LAST DISK FILE IS DUMPED TO TAPE   06864000
      AND UNLOCKED.   UNLOCKSTORE UNLOCKS ALL FILES NAMED IN GNUM SO    06866000
      THAT THEY ARE NOT LOST UNTIL THE NEXT COLD LOAD.  SINCE AN ERROR  06868000
      HAS ALREADY OCCURRED, UNLOCKSTORE IGNORES ALL SUBSEQUENT ERRORS.  06870000
                                                                        06872000
      UNLOCKSTORE PARAMETERS:                                           06874000
                                                                        06876000
         GNUM  -  FILE NUMBER OF THE DISK WORK FILE CONTAINING THE      06878000
                  NAMES OF ALL FILES TO BE UNLOCKED.                    06880000
                                                                        06882000
         REW   -  TRUE = REWIND GNUM BEFORE PROCESSING                  06884000
                  FALSE = DO NOT REWIND GNUM BEFORE PROCESSING          06886000
                                                                     >> 06888000
<<*******************************************************************>> 06890000
 BEGIN                                                                  06892000
   INTEGER I,LDN,P1;                                                    06894000
   INTEGER MSIR;                                                        06896000
   DOUBLE IOB;                                                          06898000
   INTEGER                                                     <<RV.PV>>06900000
       STATUS = IOB;                                           <<RV.PV>>06902000
   LOGICAL                                                     <<RV.PV>>06904000
       PMASK = Q-4;                                            <<RV.PV>>06906000
   INTEGER ARRAY GBUF (0:14), ALTGBUF (0:14) ,FLAB (0:127);    <<RC.PV>>06908000
   LOGICAL ARRAY MG(0:12);                                              06910000
   DEFINE                                                      <<RV.PV>>06912000
       PVINFO'M = (14:1) #,                                    <<RC.PV>>06914000
       PREVGBUF'M = (15:1) #,                                  <<RC.PV>>06916000
       PVINFO'P = PMASK.PVINFO'M #,                            <<RV.PV>>06918000
       PREVGBUF'P = PMASK.PREVGBUF'M #;                        <<RC.PV>>06920000
<<------------------------------------------------------------------->> 06922000
      IF NOT PVINFO'P THEN PVINFO := 0;                                 06924000
      IF NOT PREVGBUF'P THEN @PREVGBUF := @ALTGBUF;            <<RC.PV>>06926000
      IF REW THEN                                                       06928000
         BEGIN                                                          06930000
         FCONTROL(GNUM,REWIND,I);                                       06932000
         IF <> THEN RETURN;                                    <<00482>>06934000
         END;                                                           06936000
 RDNEXTF:                                                               06938000
      FREAD (GNUM,GBUF,15);                                    <<RV.PV>>06940000
      IF <> THEN                                               <<RV.PV>>06942000
      BEGIN                                                    <<RV.PV>>06944000
          IF > THEN <<EOF>> CHKFORDISMOUNT (PVINFO,0,PREVGBUF);<<RC.PV>>06946000
         RETURN;                                               <<00482>>06948000
      END;                                                     <<RV.PV>>06950000
      P1:=GBUF(12).(8:8);                                               06952000
      LDN := GBUF(12).(0:8);   << RCSTORE CONVERTED FVOLPNTR TO LDN >>  06954000
      CHKFORDISMOUNT (PVINFO,GBUF (14),PREVGBUF);              <<RC.PV>>06956000
      MOVE PREVGBUF := GBUF, (15);                             <<RC.PV>>06958000
      PVINFO := GBUF (14);                                     <<RC.PV>>06960000
      MSIR := GETSIR(FISIR);    << Get file label SIR >>       <<00482>>06962000
      IOB := ATTACHIO(LDN,0,0,@FLAB,0,128,P1,GBUF(13),1);               06964000
      IF STATUS.(13:3) <> 1 THEN GOTO RDNEXTF;                          06966000
          FLSTORE := 0;                                                 06968000
      IOB := ATTACHIO(LDN,0,0,@FLAB,1,128,P1,GBUF(13),1);               06970000
      RELSIR(FISIR,MSIR);       << release label SIR >>        <<00482>>06972000
      GO RDNEXTF;                                                       06974000
 END << UNLOCKSTORE >> ;                                                06976000
$PAGE "PRINTDFILE --  LIST GOOD OR ERROR FILE"                          06978000
$CONTROL SEGMENT=CXSTOREST                                              06980000
   DOUBLE PROCEDURE PRINTDFILE(PNUM,DNUM,COUNT,GORE,CHR,SHOW);          06982000
      VALUE PNUM,DNUM,COUNT,GORE,SHOW;                                  06984000
      INTEGER PNUM,DNUM,COUNT;                                          06986000
      BYTE ARRAY CHR;                                                   06988000
      LOGICAL GORE,SHOW;                                                06990000
      OPTION PRIVILEGED,UNCALLABLE;                                     06992000
                                                                        06994000
<<*******************************************************************>> 06996000
<<                                                                      06998000
      PRINTDFILE PRINTS A LIST OF ALL FILE NAMES CONTAINED IN THE       07000000
     DNUM FILE.                                                         07002000
                                                                        07004000
     PRINTDFILE PARAMETERS:                                             07006000
                                                                        07008000
           PNUM  - FILE NUMBER OF AN OPENED LIST FILE.                  07010000
                   (RECSIZE=70.    VARIABLE LENGTH RECORDS)             07012000
                   PNUM MUST BE OPENED WITH THE CARRIAGE CONTROL        07014000
                   OPTION.  PRINTDFILE ASSUMES POST SPACING.            07016000
                                                                        07018000
           DNUM  - FILE NUMBER OF AN OPENED DISK WORK FILE WHICH        07020000
                   CONTAINS FILE NAMES.                                 07022000
                                                                        07024000
           COUNT - THE NUMBER OF FILES NAMED IN DNUM.                   07026000
                                                                        07028000
           GORE  - 1=GNUM.  0=ENUM.                                     07030000
                                                                        07032000
           CHR   - AN INTEGER CONTAINING TWO ASCII GRAPHICS.            07034000
                   CXSTORE CALLS IT WITH "  ".                          07036000
                   CXRESTORE CALLS IT WITH "RE".                        07038000
                                                                        07040000
           SHOW  - IF TRUE THEN PRINT LIST OF GOOD FILES                07042000
                                                                     >> 07044000
<<*******************************************************************>> 07046000
   BEGIN                                                                07048000
      EQUATE LINECONTROL=1;   << CONTROLCODE FOR FCONTROL >>            07050000
      EQUATE DS=%60,          <<DOUBLE SPACE - 60 LINES>>               07052000
             SS=%40;          <<SINGLE SPACE - 60 LINES>>               07054000
      INTEGER M;                                                        07056000
      LOGICAL STORE;                                           <<RV.RS>>07058000
      INTEGER BRET=PRINTDFILE, ARET=PRINTDFILE+1;                       07060000
      INTEGER ARRAY LINE(0:35);                                <<00.06>>07062000
      INTEGER ARRAY GBUF (0:14);                               <<RV.RS>>07064000
      BYTE ARRAY ADR(0:10);                                             07066000
      BYTE ARRAY LINEX(*)=LINE;                                         07068000
      DOUBLE ARRAY GBUFD(*)=GBUF;                                       07070000
      BYTE ARRAY GBUFX(*)=GBUF;                                         07072000
      INTEGER ARRAY DLS(1:9)=PB:=[8/5,8/0],[8/6,8/5],[8/8,8/11],        07074000
          [8/8,8/19],[8/5,8/27],[8/5,8/32],[8/5,8/37],[8/6,8/42],       07076000
          [8/5,8/48];                                                   07078000
      BYTE ARRAY DETAILS(0:52)=PB:="FILE GROUP ACCOUNT CREATOR DISC ",  07080000
          "TAPE SAVE WRITE READ ";                                      07082000
      INTEGER ARRAY ELS (*) = PB :=                            <<04305>>07084000
          [8/14,8/0],[8/16,8/14],[8/20,8/30],                  <<C+.05>>07086000
          [8/19,8/50],[8/4,8/69],[8/28,8/73],[8/17,8/101],[8/13,8/118], 07088000
          [8/18,8/131],[8/19,8/149],[8/14,8/168],[8/11,8/182]  <<C+.05>>07090000
          ,[8/10,8/193]                                        <<C+.05>>07092000
          ,[8/15,8/203]                                        <<C+.09>>07094000
          ,[8/27,8/218]                                        <<28.PV>>07096000
          ,[8/10,8/245]                                                 07098000
          ,[8/27,8/255]                                                 07100000
          ;                                                    <<C+.05>>07102000
      BYTE ARRAY ERRORS (*) = PB :=                            <<04305>>07104000
          "ALREADY EXISTSNOT IN DIRECTORY",                    <<C+.05>>07106000
          "DIFFERENT FROM LOGONFILE LOCKWORD WRONGBUSYFILE CODE<0 AND", 07108000
          " NO PRIV MODEOUT OF DISC SPACEERROR ON DISCCATASTROPHIC ",   07110000
          "ERRORDISC SPACE EXCEEDEDACCESS FAILURENOT ON TAPE"  <<C+.05>>07112000
          ,"READ ERROR"                                        <<C+.05>>07114000
          ,"LABEL DEFECTIVE"                                   <<C+.09>>07116000
          ,"HOME VOLUME SET NOT MOUNTED"                       <<28.PV>>07118000
          ,"SHORT FILE"                                                 07120000
          ,"RIO FILE STORED INCORRECTLY"                       <<04305>>07122000
          ;                                                    <<C+.05>>07124000
                                                                        07126000
          FCONTROL(DNUM,REWIND,M);                                      07128000
          IF <> THEN                                                    07130000
            BEGIN   <<FILE ERROR ON DATA FILE>>                         07132000
  DERR:       TOS := DNUM;                                              07134000
  FERR:       BRET := TOS;                                              07136000
              ARET := 1;                                                07138000
              RETURN;                                                   07140000
            END;                                                        07142000
          TOS := PNUM;   <<FOR FWRITE>>                                 07144000
      STORE := IF CHR = "STORE" THEN TRUE ELSE FALSE;          <<RV.RS>>07146000
          TOS := @LINE;                                                 07148000
          TOS := 0;    <<FOR ASCII>>                                    07150000
          TOS := COUNT;                                                 07152000
          TOS := 10;                                                    07154000
          TOS := @LINEX;                                                07156000
          TOS := S0;                                                    07158000
          MOVE * := "  FILES ",2;                                       07160000
          IF NOT GORE THEN MOVE * := "NOT ",2;                          07162000
          MOVE * := CHR WHILE AN,1;                                     07164000
          MOVE * := " = ",2;                                            07166000
          ASSEMBLE(DUP,CAB; SUB,NEG);  <<BYTE COUNT>>                   07168000
          M := TOS;                                                     07170000
          TOS := ASCII(*,*,*);                                          07172000
          TOS := -TOS+M;                                                07174000
          FWRITE(*,*,*,DS);   <<PRINT FILE COUNT>>                      07176000
          IF <> THEN                                                    07178000
            BEGIN   <<ERROR ON PRINT FILE>>                             07180000
  PERR:       TOS := PNUM;                                              07182000
              GOTO FERR;                                                07184000
            END;                                                        07186000
          IF COUNT=0 THEN RETURN;   <<NO FILES TO LIST>>                07188000
          TOS := PNUM;   <<FOR FWRITE>>                                 07190000
          TOS := @LINE;                                                 07192000
          MOVE LINEX := "    FILE    .GROUP   .ACCOUNT ",2;             07194000
          IF GORE THEN                                                  07196000
            BEGIN   <<GNUM>>                                            07198000
              IF NOT SHOW THEN RETURN;   <<DON'T LIST 'EM>>             07200000
              MOVE * := "  LDN  ADDRESS  VOLUME";              <<RV.RS>>07202000
              TOS := IF STORE THEN -52 ELSE -44; <<HEADING>>   <<RV.RS>>07204000
            END                                                         07206000
          ELSE                                                          07208000
            BEGIN   <<ENUM>>                                            07210000
              MOVE * := "FILESET     REASON";                           07212000
              TOS := -48;                                               07214000
            END;                                                        07216000
          FWRITE(*,*,*,DS);                                             07218000
          IF <> THEN GOTO PERR;                                         07220000
  NEXT:   FREAD(DNUM,GBUF,IF STORE THEN 15 ELSE 14);           <<RV.RS>>07222000
          IF > THEN                                                     07224000
            BEGIN   <<FINISHED>>                                        07226000
              FWRITE(PNUM,LINE,0,DS);<<DOUBLE SPACE>>                   07228000
              IF <> THEN GOTO PERR;                                     07230000
              RETURN;                                                   07232000
            END;                                                        07234000
          IF < THEN GOTO DERR;   <<FILE SYSTEM ERROR>>                  07236000
          IF REQUESTSERVICE THEN    <<BREAK>>                           07238000
            BEGIN                                                       07240000
               ARET := 12;                                              07242000
               RETURN;                                                  07244000
            END;                                                        07246000
          LINE(15) := "  ";   <<BLANK LINE>>                            07248000
          MOVE LINE(16) := LINE(15),(19);                               07250000
          IF GORE THEN                                                  07252000
            BEGIN  <<GNUM>>                                             07254000
              ASCII(GBUF(12).(0:8),10,LINEX(32));    <<LDN>>            07256000
              LINEX(37) := "%";                                         07258000
              GBUF(12).(0:8) := 0;                                      07260000
              DASCII(GBUFD(6),8,ADR);     <<DISC ADDRESS>>              07262000
              TOS := @LINEX(38);                                        07264000
              TOS := @ADR;                                              07266000
              TOS := 11;                                                07268000
              WHILE BPS1="0" DO ASSEMBLE(INCB,DECA);   <<LEADING ZERO>> 07270000
              M := -S0-38;                                              07272000
              ASSEMBLE (MVB 3);                                <<RV.RS>>07274000
              IF STORE THEN ASCII (GBUF (14),10,LINEX (49));   <<RV.RS>>07276000
              IF GBUF < 0 THEN <<CHECKSUM ERR>>                         07278000
              BEGIN                                                     07280000
                  MOVE LINEX (53) := " CHKSUM ERR";            <<RV.RS>>07282000
              END;                                             <<RV.RS>>07284000
              M := -62;                                        <<RV.RS>>07286000
            END                                                         07288000
          ELSE                                                          07290000
            BEGIN  <<ENUM>>                                             07292000
              ASCII(GBUF(12),10,LINEX(33));  <<FILESET>>                07294000
              M := -38;                                                 07296000
              TOS := @LINEX(38);                                        07298000
              X := GBUF(13).(8:8);                                      07300000
              IF <> THEN                                                07302000
                BEGIN   <<PRINT MESSAGE FOR DETAIL>>                    07304000
                  TOS := DLS(X);    <<LENGTH AND STARTING BYTE>>        07306000
                  TOS := 0;                                             07308000
                  ASSEMBLE(DLSR 8; LSR 8; STAX,DUP);                    07310000
                  M := -TOS+M;    <<LINE COUNT>>                        07312000
                  TOS := @DETAILS(X);  <<ADDRESS OF STRING>>            07314000
                  ASSEMBLE(XCH; MVB PB,2);                              07316000
                END;                                                    07318000
              X := GBUF(13).(0:8);   <<ERROR #>>                        07320000
              TOS := ELS(X);   <<LENGTH AND STARTING BYTE>>             07322000
              TOS := 0;                                                 07324000
              ASSEMBLE(DLSR 8; LSR 8; STAX,DUP);                        07326000
              M := -TOS+M;                                              07328000
              TOS := @ERRORS(X);                                        07330000
              ASSEMBLE(XCH; MVB PB,3);                                  07332000
            END;                                                        07334000
          <<MOVE FILE NAME INTO BUFFER;MASK OUT BIT ZERO OF EACH BYTE>> 07336000
          LINE(2) := LOGICAL (GBUF   ) LAND %77577;                     07338000
          LINE(3) := LOGICAL (GBUF(1)) LAND %77577;                     07340000
          LINE(4) := LOGICAL (GBUF(2)) LAND %77577;                     07342000
          LINE(5) := LOGICAL (GBUF(3)) LAND %77577;                     07344000
          MOVE LINEX(13) := GBUFX(8),(8);  <<GROUP NAME>>               07346000
          MOVE LINE(11) := GBUF(8),(4);   <<ACCOUNT NAME>>              07348000
          FWRITE(PNUM,LINE,M,SS);                                       07350000
          IF <> THEN GOTO PERR;                                         07352000
          GOTO NEXT;                                                    07354000
      END <<PRINTDFILE>> ;                                              07356000
$PAGE "CXRESTORE  --  RESTORE COMMAND EXECUTOR"                         07358000
 << ****************************************************************>>  07360000
 PROCEDURE CXRESTORE(P,ENUMBER,PNUMBER);                                07362000
      BYTE ARRAY P;                                                     07364000
      INTEGER ENUMBER,PNUMBER;                                          07366000
   OPTION PRIVILEGED,UNCALLABLE;                                        07368000
<<******************************************************************>>  07370000
<<                                                                      07372000
      THE SYNTAX OF THE RESTORE COMMAND IS AS FOLLOWS:                  07374000
                                                                        07376000
                                      [;FILES= max no. files]        RAO07378000
                                      [;KEEP]...]                       07380000
        :RESTORE DESIG [;[FILESETLIST][;DEV=DEVICE]...]                 07382000
                                      [;SHOW]...]                       07384000
                                                                     >> 07386000
<<*******************************************************************>> 07388000
<<                                                                      07390000
    SOFT ERRORS RECORDED ON ENUM:                                       07392000
                                                                        07394000
          ERROR   DETAIL      MEANING                                   07396000
          -----   ------      -------                                   07398000
                                                                        07400000
            0       0         FILE ALREADY EXISTS AND KEEP SPECIFIED    07402000
                                                                        07404000
            1     2=GROUP     DOES NOT EXIST IN DIRECTORY               07406000
                  3=ACCOUNT                                             07408000
                  4=CREATOR                                             07410000
                                                                        07412000
            2     3=ACCOUNT   DIFFERENT FROM LOGON ACCOUNT              07414000
                                                                        07416000
            3     5=DISC      FILE LOCKWORD DOES NOT MATCH              07418000
                  6=TAPE                                                07420000
                                                                        07422000
            4       0         FILE IS BUSY                              07424000
                                                                        07426000
            5     5=DISC      FILE HAS NEGATIVE FILECODE AND USER DOES  07428000
                              NOT HAVE PRIVILEGED MODE CAPABILITY       07430000
                                                                        07432000
            6       0         NOT ENUF DISC SPACE FOR THIS FILE         07434000
                                                                        07436000
            7     8=WRITE     ERROR ON DISC FOR THIS FILE               07438000
                  9=READ                                                07440000
                                                                        07442000
            8       0         CATASTROPHIC ERROR                        07444000
                                                                        07446000
            9     2=GROUP     FILE SPACE LIMIT EXCEEDED                 07448000
                  3=ACCOUNT                                             07450000
                                                                        07452000
           10     7=SAVE      ACCESS FAILURE (WRITE ACCESS NEEDED TO    07454000
                  8=WRITE     PURGE OLD COPY OF A FILE)                 07456000
                                                                        07458000
           11       0         FILE NOT ON TAPE                          07460000
                                                                        07462000
           12     6=TAPE      READ ERROR                                07464000
                                                                        07466000
           13     1=FILE      LABEL ERROR                               07468000
                                                                      >>07470000
<<*******************************************************************>> 07472000
<<                                                                      07474000
      CXRESTORE INVOKES ONE OF TWO COMMAND INTERPRETER ERROR ROUTINES   07476000
      WHEN AN ERROR IS DETECTED: FERROR FOR FILE SYSTEM ERRORS AND      07478000
      CZERROR FOR ALL OTHERS.  THE FOLLOWING ERRORS ARE RETURNED FROM   07480000
      FRESTORE, IRESTORE AND PRINTDFILE:                                07482000
                                                                        07484000
          S-0         S-1         ERROR                                 07486000
          ---         ---         -----                                 07488000
                                                                        07490000
           0           -          NONE                                  07492000
           1     FILE NUMBER      FILE SYSTEM                           07494000
           2           -          SYNTAX                             RAO07496000
                                      CIERR ALREADY CALLED           RAO07498000
                                      RETVAL(1) = CI ERROR NO.       RAO07500000
                                      RETVAL(2) = PARM NO.           RAO07502000
           3           -          I/O                                   07504000
           4           -          DIRECTORY                             07506000
           5           -          DEVICE OF WRONG TYPE                  07508000
           6                      INVALID DEVICE SPECIFICATION       RAO07510000
                      -1             VIRTUAL DEVICE                  RAO07512000
                       1             INVALID DEVICE CLASS NAME       RAO07514000
                       2             UNKNOWN DEVICE CLASS            RAO07516000
                       3             UNKNOWN LOGICAL DEVICE NO.      RAO07518000
                      10             DEV PARM NOT A DISC.            RAO07520000
           7           -          NOT A RESTORE TAPE                    07522000
           8                      TOO MANY FILESETS  (TABLE OVERFLOW)RAO07524000
                       0             TOO MANY FULLY QUALIFIED        RAO07526000
                       1             TOO MANY PARTIALLY QUALIFIED    RAO07528000
                       2             TOO MANY QUALIFIED BY ACCT.     RAO07530000
                                         CIERR ALREADY CALLED.       RAO07532000
                                         RETVAL(1)=ERROR NO.         RAO07534000
                                         RETVAL(2)=PARM NO.          RAO07536000
           9           -          OPERATOR CAN'T FIND RIGHT TAPE        07538000
          10    LDEV OF DEVICE    DEVICE UNAVAILABLE                 RAO07540000
          11           -          BAD TAPE FORMAT                       07542000
          12           -          BREAK SENSED                          07544000
          13           -          ZSIZE FAILED WHEN XEQTD VIA COMMAND   07546000
                                                                     >> 07548000
<<*******************************************************************>> 07550000
BEGIN                                                          <<U.RAO>>07552000
EQUATE MAXPARMS=50;            <<MAX # OF PARAMETERS TO COMMAND<<U.RAO>>07554000
EQUATE T1=MAXPARMS-1;                                          <<U.RAO>>07558000
DEFINE                                                         <<U.RAO>>07560000
   GETNEXT= PRAM := PARMS(PNUMBER);                            <<U.RAO>>07562000
            PNUMBER := PNUMBER+1#,                             <<U.RAO>>07564000
   NEXTDELIM = PTYPE.(11:5)#;                                  <<U.RAO>>07566000
EQUATE COMMA = 0,                                              <<U.RAO>>07568000
       EQSIGN = 1,                                             <<U.RAO>>07570000
       SEMI   = 2,                                             <<U.RAO>>07572000
       CR     = 3;                                             <<U.RAO>>07574000
DEFINE KEEPFLAG=FLAGS.(13:1)#;                                 <<U.RAO>>07576000
DEFINE BACKUP=FLAGS.(12:1)#; <<REPOSITION TAPE AFTER ERROR>>   <<00425>>07578000
DEFINE OLDDATE=FLAGS.(11:1)#;<<USE OLD MODIFY AND ACCESS DATE>><<00425>>07580000
DOUBLE ARRAY PARMS(0:T1);      <<FOR PARAMETERS FROM MYCOMMAND><<U.RAO>>07582000
DOUBLE PRAM;                   <<FOR ONE PARAMETER>>           <<U.RAO>>07584000
LOGICAL PTYPE=PRAM+1;          <<PARAMETER INFO>>              <<U.RAO>>07586000
BYTE PL=PRAM+1;                <<PARAMETER LENGTH>>            <<U.RAO>>07588000
BYTE POINTER PR=PRAM;          <<PTR TO PARAMETER>>            <<U.RAO>>07590000
INTEGER NUMPARMS;              <<# OF PARAMETER>>              <<U.RAO>>07592000
BYTE ARRAY DELIM(0:1);                                         <<U.RAO>>07594000
BYTE ARRAY DEVP(0:8),          <<DEVICE PARAMETER>>            <<U.RAO>>07596000
           DESIG(0:9),         <<TAPE FILE DESIGNATOR>>        <<U.RAO>>07598000
           LIST(0:7),          <<LIST FILE DESIGNATOR>>        <<U.RAO>>07600000
           CANDIDATE(0:8),     <<CANDIDATE FILE DESIGNATOR>>   <<U.RAO>>07602000
           GOOD(0:4),          <<GOOD FILE DESIGNATOR>>        <<U.RAO>>07604000
           ERROR(0:5);         <<ERROR FILE DESIGNATOR>>       <<U.RAO>>07606000
INTEGER K;                                                     <<02546>>07608000
INTEGER ARRAY TRAILBL (0:49);                                  <<RV.RS>>07610000
BYTE POINTER DEVPTR;  <<POINTS TO DEV PARM FOR ERROR CARET>>   <<U.RAO>>07612000
DOUBLE RET := 0D;              <<RETURN FROM FRESTORE>>        <<U.RAO>>07614000
INTEGER ARET=RET+1, BRET=RET;                                  <<U.RAO>>07616000
INTEGER DEVTYPE;                                               <<02546>>07618000
BYTE POINTER FILESETLIST:=@DELIM;   <<PTR TO LIST OF FILES>>   <<U.RAO>>07624000
INTEGER CFRCOUNT:=0,           <<CANDIDATE FILE COUNT>>        <<U.RAO>>07626000
        EFRCOUNT:=0,           <<ERROR FILE COUNT>>            <<U.RAO>>07628000
        GFRCOUNT:=0;           <<GOOD FILE COUNT>>             <<U.RAO>>07630000
INTEGER ARRAY RETVAL(*)=CFRCOUNT;                              <<U.RAO>>07632000
INTEGER TNUM:=0,PNUM:=0,CNUM:=0,ENUM:=0,GNUM:=0;               <<U.RAO>>07634000
LOGICAL SHOWFLAG := 0;         <<SHOW ALL FILES>>              <<U.RAO>>07636000
LOGICAL FLAGS := 0;            <<FLAGS TO FRESTORE>>           <<U.RAO>>07638000
LOGICAL DEVFLAG := FALSE;                                      <<U.RAO>>07640000
LOGICAL FILESFLAG := FALSE;                                    <<U.RAO>>07642000
LOGICAL SPEC'ENTRY := FALSE;                                   <<02871>>07644000
DOUBLE GNUMFSIZE := 4000D;                                     <<U.RAO>>07646000
DOUBLE ENUMFSIZE = GNUMFSIZE;                                  <<U.RAO>>07648000
DOUBLE CNUMFSIZE = GNUMFSIZE;                                  <<U.RAO>>07650000
INTEGER OLDSIZE:=0;            <<OLD STACK SIZE>>              <<U.RAO>>07652000
LOGICAL                                                        <<02558>>07656000
   LDEV,           << Tape Logical Device >>                   <<02562>>07658000
   FOPTIONS,        << From FOPEN of tape file >>              <<02558>>07660000
   AOPTIONS,                                                   <<02558>>07662000
   IRESTORE'FLAG;   << Flag for 6250 BPI default case >>       <<02558>>07664000
INTEGER                                                        <<02558>>07666000
   RECSIZE,        << Max. recsize expected by user >>         <<02558>>07668000
   MAX'RECSIZE,    << Maximum record size for device >>        <<02558>>07670000
   DENSITY,        << Mag tape density >>                      <<02558>>07672000
   ERRNUM,                                                     <<02558>>07674000
   STACK'INC;      << Max. stack space needed for buffer >>    <<02558>>07676000
                                                                        07678000
          <<-------------                                               07680000
            CLOSE FILES                                                 07682000
          ------------->>                                               07684000
        SUBROUTINE SHUTFILES(NOSHUT);                                   07686000
        VALUE NOSHUT; INTEGER NOSHUT;                                   07688000
        COMMENT                                                         07690000
          CLOSE ALL FILES IF THEY ARE OPEN EXCEPT FOR THE ONE           07692000
        SPECIFIED BY NOSHUT (IT WILL BE CLOSED BY FERROR);              07694000
        BEGIN                                                           07696000
          IF CNUM<>0 AND CNUM<>NOSHUT THEN FCLOSE(CNUM,0,0);            07698000
          IF ENUM<>0 AND ENUM<>NOSHUT THEN FCLOSE(ENUM,0,0);            07700000
          IF GNUM<>0 AND GNUM<>NOSHUT THEN FCLOSE(GNUM,0,0);            07702000
          IF TNUM<>0 AND TNUM<>NOSHUT THEN FCLOSE(TNUM,0,0);            07704000
          IF PNUM<>0 AND PNUM<>NOSHUT THEN FCLOSE(PNUM,0,0);            07706000
                                                                        07708000
         IF OLDSIZE<>0 THEN ZSIZE(OLDSIZE);                    <<00425>>07710000
        END <<SHUTFILES>> ;                                             07712000
<<============================================================><<U.RAO>>07714000
<< This subroutine prints out file errors. It never returns   ><<U.RAO>>07716000
<<============================================================><<U.RAO>>07718000
SUBROUTINE FILEERROR(FILENUM);                                 <<U.RAO>>07720000
VALUE FILENUM;   <<THE MPE FILENUMBER OF THE OFFENDING FILE>>  <<U.RAO>>07722000
INTEGER FILENUM;                                               <<U.RAO>>07724000
BEGIN                                                          <<U.RAO>>07726000
FERROR'(FILENUM, PNUMBER);  <<IDENTIFIES FSYS ERROR>>          <<U.RAO>>07728000
IF FILENUM=CNUM OR FILENUM=ENUM OR FILENUM=GNUM THEN           <<U.RAO>>07730000
   CIERR(ENUMBER := RSTORSCRFLFSERR)  <<SCRATCH FILE ERROR>>   <<U.RAO>>07732000
ELSE IF FILENUM=TNUM THEN   <<TAPE FILE ERROR>>                <<U.RAO>>07734000
   CIERR(ENUMBER := RSTOR'TFL'FSERR)                           <<U.RAO>>07736000
ELSE  <<MUST BE PRINT FILE ERROR>>                             <<U.RAO>>07738000
   CIERR(ENUMBER := RSTORPRTFLFSERR);                          <<U.RAO>>07740000
SHUTFILES(FILENUM);                                            <<U.RAO>>07742000
ASSEMBLE(EXIT 3);  <<EXIT PROCEDURE>>                          <<U.RAO>>07744000
END;                                                           <<U.RAO>>07746000
<<&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&><<U.RAO>>07748000
<< This subroutine evaluates the double returned by IRESTORE, ><<U.RAO>>07750000
<< FRESTORE or PRINTDFILE.  It also does not return except if ><<U.RAO>>07752000
<< no error was detected.  Note that some errors are reported ><<U.RAO>>07754000
<< here and some at the point where they were detected.  This ><<U.RAO>>07756000
<< was done for one of two reasons:  1)  It was possible to   ><<U.RAO>>07758000
<< put out a caret indicating the error at the point in the   ><<U.RAO>>07760000
<< input string where it occurred since we were parsing at    ><<U.RAO>>07762000
<< that particular moment or 2) since CIERR is fatal for JOBs ><<U.RAO>>07764000
<< we wanted to avoid leaving the directory or disc in a      ><<U.RAO>>07766000
<< dirty state, so the subordinate procedure unwound itself   ><<U.RAO>>07768000
<< and left it to the caller to put out any error message.    ><<U.RAO>>07770000
<<&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&><<U.RAO>>07772000
SUBROUTINE EVALRETURN(B,A);                                    <<U.RAO>>07774000
VALUE B,A;                                                     <<U.RAO>>07776000
INTEGER B,A;                                                   <<U.RAO>>07778000
BEGIN                                                          <<U.RAO>>07780000
<<FIRST REPORT THE ERROR>>                                     <<U.RAO>>07782000
PNUMBER := 0;                                                  <<U.RAO>>07784000
CASE A OF                                                      <<U.RAO>>07786000
   BEGIN                                                       <<U.RAO>>07788000
                                                               <<U.RAO>>07790000
      << 0>> RETURN;   <<NO ERROR >>                           <<U.RAO>>07792000
                                                               <<U.RAO>>07794000
      << 1>> FILEERROR(B);   <<ERROR ON ONE OF THE FILES>>     <<U.RAO>>07796000
                                                               <<U.RAO>>07798000
      << 2>> BEGIN     <<SYNTAX ERROR, MESSAGE ALREADY SENT>>  <<U.RAO>>07800000
             ENUMBER := RETVAL(1);   <<CIERROR NUMBER>>        <<U.RAO>>07802000
             PNUMBER := RETVAL(2);   <<PARAMETER NUMBER>>      <<U.RAO>>07804000
             END;                                              <<U.RAO>>07806000
                                                               <<U.RAO>>07808000
      << 3>> CIERR(ENUMBER := RSTORDISCIO);  <<DISC IO ERROR>> <<U.RAO>>07810000
                                                               <<U.RAO>>07812000
      << 4>> CIERR(ENUMBER := RSTORDIRERR);  <<DIRECTORY ERR>> <<U.RAO>>07814000
                                                               <<U.RAO>>07816000
      << 5>> ;   <<TAPE DEVICE PROBLEM ALREADY REPORTED>>      <<U.RAO>>07818000
                                                               <<U.RAO>>07820000
      << 6>> BEGIN  <<INVALID DEVICE SPECIFICATION>>           <<U.RAO>>07822000
             IF B=-1 THEN   <<VIRTUAL DEVICE>>                 <<U.RAO>>07824000
                CIERR(ENUMBER := RSTORNOVIRTDEV, DEVPTR)       <<U.RAO>>07826000
             ELSE IF B=1 THEN   <<INVALID DEVICE CLASS>>       <<U.RAO>>07828000
                CIERR(ENUMBER := RSTORINVDEVCLS, DEVPTR)       <<U.RAO>>07830000
             ELSE IF B=2 THEN   <<UNKNOWN DEVICE CLASS>>       <<U.RAO>>07832000
                CIERR(ENUMBER := RSTORUNKDEVCLS, DEVPTR)       <<U.RAO>>07834000
             ELSE IF B=3 THEN   <<UNKNOWN LOGICAL DEVICE NO.>> <<U.RAO>>07836000
                CIERR(ENUMBER := RSTORUNKLDEV,   DEVPTR)       <<U.RAO>>07838000
             ELSE IF B=10 THEN  <<NOT A DISC DEVICE>>          <<U.RAO>>07842000
                CIERR(ENUMBER := RSTORDEVNOTDISC,DEVPTR);      <<U.RAO>>07844000
             END;                                              <<U.RAO>>07846000
                                                               <<U.RAO>>07848000
      << 7>> CIERR(ENUMBER := RSTORNOTSTORTAP);  <<BAD TAPE>>  <<U.RAO>>07850000
                                                               <<U.RAO>>07852000
      << 8>> BEGIN  <<TOO MANY FILESETS.  MESSAGE SENT>>       <<U.RAO>>07854000
             ENUMBER := RETVAL(1);                             <<U.RAO>>07856000
             PNUMBER := RETVAL(2);                             <<U.RAO>>07858000
             END;                                              <<U.RAO>>07860000
                                                               <<U.RAO>>07862000
      << 9>> CIERR(ENUMBER:=RSTORNOTAPEOP);  <<CAN'T FIND TAPE><<U.RAO>>07864000
                                                               <<U.RAO>>07866000
      <<10>> CIERR(ENUMBER := RSTORDEVNOTAVAL,,%10000,B);      <<U.RAO>>07868000
                <<DEVICE NOT AVAILABLE>>                       <<U.RAO>>07870000
                                                               <<U.RAO>>07872000
      <<11>> CIERR(ENUMBER := RSTORIMPTAPEFMT);                <<U.RAO>>07874000
                <<IMPROPER TAPE FORMAT>>                       <<U.RAO>>07876000
                                                               <<U.RAO>>07878000
      <<12>> ;    <<BREAK SENSED, EXIT>>                       <<U.RAO>>07880000
                                                               <<U.RAO>>07882000
      <<13>> CIERR(ENUMBER := RSTORRECCONFLICT,,%10000,B);     <<02558>>07884000
             << Tape block size larger than user expected. >>  <<02558>>07886000
                                                               <<02558>>07888000
      <<14>> CIERR(ENUMBER := DATASEGERROR);  << XDS ERROR >>  <<02625>>07890000
                                                               <<02625>>07892000
   END;   <<OF CASE STATEMENT ON ERROR TYPE>>                  <<U.RAO>>07894000
<<NOW QUIT PROCESSING>>                                        <<U.RAO>>07896000
SHUTFILES(-1);  <<CLOSE ALL FILES, RESET Z>>                   <<U.RAO>>07898000
ASSEMBLE(EXIT 3);                                              <<U.RAO>>07900000
END;   <<SUBROUTINE EVALRETURN>>                               <<U.RAO>>07902000
<<%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%><<U.RAO>>07904000
<< This subroutine does a complete parse on the tape file     ><<U.RAO>>07906000
<< name as passed in the command.  It returns TRUE if any     ><<U.RAO>>07908000
<< problems were found.                                       ><<U.RAO>>07910000
<<%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%><<U.RAO>>07912000
LOGICAL SUBROUTINE INVALIDTAPENAME;                            <<U.RAO>>07914000
BEGIN                                                          <<U.RAO>>07916000
INVALIDTAPENAME := TRUE;   <<ASSUME ERROR WILL OCCUR>>         <<U.RAO>>07918000
IF NUMPARMS <= 0 THEN   << NO NAME SPECIFIED AT ALL>>          <<U.RAO>>07920000
   CIERR(ENUMBER := RSTORREQTAPEFILE, P)                       <<U.RAO>>07922000
ELSE                                                           <<U.RAO>>07924000
   BEGIN    <<A NAME WAS SPECIFIED, PARSE IT>>                 <<U.RAO>>07926000
   GETNEXT;   <<GET PARM EXPECTED TO BE TAPE NAME>>            <<U.RAO>>07928000
   IF PL<>0 THEN   <<NAME PRESENT>>                            <<U.RAO>>07930000
      IF PR="*" THEN  <<BACK REFERENCED>>                      <<U.RAO>>07932000
         IF PL<=9 THEN   <<NAME OF REASONABLE LENGTH>>         <<U.RAO>>07934000
            IF PR(1)=ALPHA THEN   <<NAME STARTS WITH ALPHA>>   <<U.RAO>>07936000
               BEGIN   <<CHECK FOR EMBEDDED SPECIALS>>         <<U.RAO>>07938000
               DESIG := "*";                                   <<U.RAO>>07940000
               MOVE DESIG(1) := PR(1) WHILE AN, 1;             <<U.RAO>>07942000
               IF S0-@DESIG <> INTEGER(PL) THEN                <<U.RAO>>07944000
                  BEGIN   <<EMBEDDED SPECIAL PRESENT>>         <<U.RAO>>07946000
                  CIERR(ENUMBER := STORTAPEMBEDSPC,            <<U.RAO>>07948000
                     PR(S0-@DESIG));                           <<U.RAO>>07950000
                  DEL;                                         <<U.RAO>>07952000
                  END                                          <<U.RAO>>07954000
               ELSE                                            <<U.RAO>>07956000
                  BEGIN                                        <<U.RAO>>07958000
                  BPS0 := " ";   <<PUT STOPPER ON NAME>>       <<U.RAO>>07960000
                  DEL;  <<POP POINTER>>                        <<U.RAO>>07962000
                  INVALIDTAPENAME := FALSE;  <<EVERYTHING OK>> <<U.RAO>>07964000
                  END                                          <<U.RAO>>07966000
               END                                             <<U.RAO>>07968000
            ELSE   <<FIRST CHAR NOT AN ALPHA>>                 <<U.RAO>>07970000
               CIERR(ENUMBER := STORTAPXPCTALPH, PR(1))        <<U.RAO>>07972000
         ELSE   <<NAME TOO LONG>>                              <<U.RAO>>07974000
            CIERR(ENUMBER := STORTAPNAME2LNG, PR)              <<U.RAO>>07976000
      ELSE   <<NAME NOT BACK REFERENCE>>                       <<U.RAO>>07978000
         CIERR(ENUMBER := STORXPCTBREFTAP, PR)                 <<U.RAO>>07980000
   ELSE   <<MISSING TAPE FILE NAME>>                           <<U.RAO>>07982000
      CIERR(ENUMBER := STORREQTAPEFILE, PR);                   <<U.RAO>>07984000
   END;                                                        <<U.RAO>>07986000
END;   <<SUBROUTINE INVALIDTAPENAME>>                          <<U.RAO>>07988000
<<---------------------------------------------->>             <<U.RAO>>07990000
<<   Parse SHOW, FILES, DEV and KEEP parameters.>>             <<U.RAO>>07992000
<<   Return of false indicates parse failed.    >>             <<U.RAO>>07994000
<<---------------------------------------------->>             <<U.RAO>>07996000
LOGICAL SUBROUTINE PARSEOTHERPARMS;                            <<U.RAO>>07998000
BEGIN                                                          <<U.RAO>>08000000
WHILE NEXTDELIM<>CR DO  <<LOOP OVER NEXT PARM>>                <<U.RAO>>08002000
   BEGIN                                                       <<U.RAO>>08004000
   IF NEXTDELIM <> SEMI THEN   <<ILLEGAL DELIMITER BETWEEN>>   <<U.RAO>>08006000
      CIERR(ENUMBER := RSTORXPCTSEMIC, PR(INTEGER(PL)))        <<U.RAO>>08008000
   ELSE   <<HAVE PROPER FORM, AT LEAST>>                       <<U.RAO>>08010000
      BEGIN                                                    <<U.RAO>>08012000
      GETNEXT;                                                 <<U.RAO>>08014000
      IF PL=4 AND PR="SHOW" THEN   <<SHOW PARAMETER>>          <<U.RAO>>08016000
         SHOWFLAG := TRUE                                      <<U.RAO>>08018000
      ELSE IF PL=5 AND PR="FILES" THEN  <<FILES PARAMETER>>    <<U.RAO>>08020000
         BEGIN                                                 <<U.RAO>>08022000
         IF FILESFLAG THEN  <<REDUNDANT SPECIFICATION>>        <<U.RAO>>08024000
            CIERR(-STORREDUNDFILES, PR);                       <<U.RAO>>08026000
         FILESFLAG := TRUE;                                    <<U.RAO>>08028000
         IF NEXTDELIM <> EQSIGN THEN  <<MISSING COUNT>>        <<U.RAO>>08030000
            CIERR(ENUMBER := STORXPCTEQFILES, PR(INTEGER(PL))) <<U.RAO>>08032000
         ELSE   <<FILES COUNT IS THERE>>                       <<U.RAO>>08034000
            BEGIN                                              <<U.RAO>>08036000
            GETNEXT;                                           <<U.RAO>>08038000
            CNUMFSIZE := DBINARY(PR, PL);                      <<U.RAO>>08040000
            IF <> OR CNUMFSIZE <= 0D THEN                      <<U.RAO>>08042000
               CIERR(ENUMBER := STORXPCTFILECNT, PR);          <<U.RAO>>08044000
            END;                                               <<U.RAO>>08046000
         END                                                   <<U.RAO>>08048000
   ELSE IF PL=7 AND PR="OLDDATE" THEN OLDDATE:=TRUE            <<00425>>08050000
      ELSE IF PL=4 AND PR="KEEP" THEN                          <<U.RAO>>08052000
         KEEPFLAG := TRUE                                      <<U.RAO>>08054000
      ELSE IF PL=3 AND PR="DEV" THEN                           <<U.RAO>>08056000
         BEGIN                                                 <<U.RAO>>08058000
         IF DEVFLAG THEN                                       <<U.RAO>>08060000
            CIERR(-RSTORREDUNDDEV, PR);                        <<U.RAO>>08062000
         DEVFLAG := TRUE;                                      <<U.RAO>>08064000
         IF NEXTDELIM <> EQSIGN THEN                           <<U.RAO>>08066000
            CIERR(ENUMBER := RSTORXPCTEQDEV, PR(INTEGER(PL)))  <<U.RAO>>08068000
         ELSE                                                  <<U.RAO>>08070000
            BEGIN   <<PARSE DEVICE ID>>                        <<U.RAO>>08072000
            GETNEXT;                                           <<U.RAO>>08074000
            IF PL=0 THEN   <<NO DEVICE SPECIFIED, DEFAULT>>    <<U.RAO>>08076000
               BEGIN                                           <<U.RAO>>08078000
               CIERR(-RSTORNODEV, PR);                         <<U.RAO>>08080000
               DEVFLAG := FALSE;                               <<U.RAO>>08082000
               DEVP :=" ";                                     <<U.RAO>>08084000
               END                                             <<U.RAO>>08086000
            ELSE IF PL>8 THEN                                  <<U.RAO>>08088000
               CIERR(ENUMBER := RSTORDEV2LNG, PR(8))           <<U.RAO>>08090000
            ELSE IF LOGICAL(PTYPE.(10:1)) THEN                 <<U.RAO>>08092000
               CIERR(ENUMBER := RSTORDEVSPECIAL, PR)           <<U.RAO>>08094000
            ELSE   <<APPARENTLY VALID DEVICE ID>>              <<U.RAO>>08096000
               BEGIN                                           <<U.RAO>>08098000
               MOVE DEVP := PR,(PL),2;                         <<U.RAO>>08100000
               BPS0 := " ";                                    <<U.RAO>>08102000
               DEL;                                            <<U.RAO>>08104000
               @DEVPTR := @PR;                                 <<U.RAO>>08106000
               END                                             <<U.RAO>>08108000
            END                                                <<U.RAO>>08110000
         END                                                   <<U.RAO>>08112000
      ELSE IF PL <> 0 THEN  << UNKNOWN PARM>>                  <<U.RAO>>08114000
         CIERR(ENUMBER := RSTORUKNOPTION,PR);                  <<00530>>08116000
      END;                                                     <<U.RAO>>08118000
   IF ENUMBER<>0 THEN   <<ERROR OCCURRED SOMEWHERE>>         <<U.RAO>>08120000
      RETURN                                                   <<U.RAO>>08122000
   END;                                                        <<U.RAO>>08124000
PARSEOTHERPARMS := TRUE;                                       <<U.RAO>>08126000
END;   <<SUBROUTINE PARSEOTHERPARMS>>                          <<U.RAO>>08128000
<<************************************************************><<U.RAO>>08130000
<< This subroutine is pretty much the counterpart of the      ><<U.RAO>>08132000
<< subroutine SHUTFILES.  It fixes up Z, opens the scratch    ><<U.RAO>>08134000
<< files and opens the tape file.  A return of FALSE indicates><<U.RAO>>08136000
<< that the subroutine failed.                                ><<U.RAO>>08138000
<<************************************************************><<U.RAO>>08140000
LOGICAL SUBROUTINE OPENFILES;                                  <<U.RAO>>08142000
BEGIN                                                          <<U.RAO>>08144000
   <<First open CANDIDATE file.  This file holds info on all>> <<U.RAO>>08146000
   <<the files in the intersection of the user's request and>> <<U.RAO>>08148000
   <<the tape directory.  It is created in IRESTORE and used>> <<U.RAO>>08150000
   <<in FRESTORE.  CFRCOUNT (a.k.a. RETVAL) is the number of>> <<U.RAO>>08152000
   <<records in the CANDIDATE file.>>                          <<U.RAO>>08154000
   MOVE CANDIDATE := "CANDIDAT ";                              <<U.RAO>>08156000
   CNUM := FOPEN(CANDIDATE, %2000, %104 <<EXCL, READ/WRITE>>,  <<U.RAO>>08158000
               17 <<RECSIZE>>, <<DISC>>, <<NO FORMS>>,         <<U.RAO>>08160000
               <<NO USERLABELS>>, 7 <<BLOCKFACTOR>>, 1 <<BUF>>,<<U.RAO>>08162000
               CNUMFSIZE <<FILE SIZE>>, 16 <<EXTENTS>>,        <<U.RAO>>08164000
               (IF FILESFLAG THEN 16 ELSE 1));                 <<U.RAO>>08166000
   IF <> THEN   <<OPEN OF CANDIDATE FILE FAILED>>              <<U.RAO>>08168000
      FILEERROR(CNUM);   <<NEVER RETURNS>>                     <<U.RAO>>08170000
   <<Now try ERROR file.  This file holds info on all files>>  <<U.RAO>>08172000
   <<on which the RESTORE failed.  See the comment at the>>    <<U.RAO>>08174000
   <<beginning of this procedure for the details on the info>> <<U.RAO>>08176000
   <<contained therein.  EFRCOUNT (aka RETVAL(1)) is the number<<U.RAO>>08178000
   MOVE ERROR := "ERROR ";                                     <<U.RAO>>08180000
   ENUM := FOPEN(ERROR, %2000, %104, 14 <<RECSIZE>>,,,,        <<U.RAO>>08182000
               9 <<BLOCKFACTOR>>, 1, ENUMFSIZE, 16,            <<U.RAO>>08184000
               (IF FILESFLAG THEN 16 ELSE 1));                 <<U.RAO>>08186000
   IF <> THEN   <<OPEN OF ERROR FILE FAILED>>                  <<U.RAO>>08188000
      FILEERROR(ENUM);   <<NEVER RETURNS>>                     <<U.RAO>>08190000
   <<Now open GOOD file.  This has a list of all the files on>><<U.RAO>>08192000
   <<which the RESTORE succeeded.  This is used whenever the >><<U.RAO>>08194000
   <<SHOW option is requested.  The open parms are as for ERROR<<U.RAO>>08196000
   <<GFRCOUNT (aka RETVAL(2) is the number of good files>>     <<U.RAO>>08198000
   MOVE GOOD := "GOOD ";                                       <<U.RAO>>08200000
   GNUM := FOPEN(GOOD, %2000, %104, 14,,,,9,1,GNUMFSIZE,16,    <<U.RAO>>08202000
               (IF FILESFLAG THEN 16 ELSE 1));                 <<U.RAO>>08204000
   IF <> THEN                                                  <<U.RAO>>08206000
      FILEERROR(GNUM);   <<NEVER RETURNS>>                     <<U.RAO>>08208000
   <<This concludes the opening of the scratch files.>>        <<U.RAO>>08210000
   <<Now open and validate the tape file.  The only problem >> <<U.RAO>>08212000
   <<here is to make sure that the user hasn't tried to do  >> <<U.RAO>>08214000
   <<something unpleasant in his file equate.  Accordingly, >> <<U.RAO>>08216000
   <<we must check the actual characteristics of the tape.  >> <<U.RAO>>08218000
   TNUM := FOPEN(DESIG, %201 <<NOCCTL, UNDEF, BINARY>>,        <<U.RAO>>08220000
                 %100<<EXCL,BUF,NOMR,READ>>,4096);             <<02558>>08222000
   IF <> THEN                                                  <<U.RAO>>08224000
      FILEERROR(TNUM);   <<NEVER RETURNS>>                     <<U.RAO>>08226000
   FGETINFO(TNUM, <<FILENAME>>, FOPTIONS, AOPTIONS, RECSIZE,   <<U.RAO>>08228000
            DEVTYPE, LDEV);                                    <<02562>>08230000
   IF <> THEN FILEERROR(TNUM);                                 <<02518>>08232000
   IF (FOPTIONS LAND %176777 ) <> %201 THEN                    <<02546>>08236000
      CIERR(ENUMBER := RSTORTAPFOPTION)                        <<U.RAO>>08238000
   ELSE IF (AOPTIONS LAND %177377) <> %100 THEN                <<02546>>08240000
      CIERR(ENUMBER := RSTORTAPAOPTION)                        <<U.RAO>>08242000
   ELSE IF DEVTYPE.(8:8)<>24 AND DEVTYPE.(8:8)<>SDISC THEN     <<SD.00>>08246000
      CIERR(ENUMBER := RSTORNOTTAPEDEV)                        <<02558>>08248000
   ELSE IF DEVTYPE.DTYPE = MAGTAPE AND LABELED AND VIRTDEV THEN<<02649>>08250000
      CIERR(ENUMBER := REMOTELBLINVAL)                         <<02649>>08252000
   ELSE                                                        <<02558>>08254000
      BEGIN                                                    <<02558>>08256000
      << Determine the restore device characteristics. >>      <<02558>>08258000
      IF DEVTYPE.DTYPE = SDISC THEN                            <<02558>>08260000
         MAX'RECSIZE := 8192                                   <<02558>>08262000
      ELSE                                                     <<02558>>08264000
         << Get the max. record size and density for tapes. >> <<02558>>08266000
         IF NOT GET'TAPE'INFO(TNUM,MAX'RECSIZE,DENSITY)        <<02558>>08268000
            THEN FILEERROR(TNUM);  << Error on file. Exits!! >><<02558>>08270000
                                                               <<02558>>08272000
      IF NOT (256 <= RECSIZE <= MAX'RECSIZE) OR                <<02558>>08274000
         (RECSIZE MOD 256) <> 0 THEN                           <<02558>>08276000
         << RECSIZE must be multiple of 256 and <= max >>      <<02558>>08278000
         CIERR(ENUMBER := RSTORTAPRECLEN,,%10000,MAX'RECSIZE); <<02558>>08280000
      END;                                                     <<02558>>08282000
                                                               <<02558>>08284000
   IF ENUMBER <> 0 THEN   <<ERROR OCCURRED>>                   <<U.RAO>>08286000
      BEGIN                                                    <<U.RAO>>08288000
      SHUTFILES(-1);                                           <<U.RAO>>08290000
      RETURN                                                   <<U.RAO>>08292000
      END                                                      <<U.RAO>>08294000
   ELSE                                                        <<U.RAO>>08296000
      OPENFILES := TRUE;                                       <<U.RAO>>08298000
END;   <<SUBROUTINE OPENFILES>>                                <<U.RAO>>08300000
<<]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]><<U.RAO>>08302000
<<                     OUTER BLOCK                            ><<U.RAO>>08304000
<<                                                            ><<U.RAO>>08306000
<< There are three parts to the outer block.                  ><<U.RAO>>08308000
<< First, the initialization section, where we check most of  ><<U.RAO>>08310000
<< the syntax.  Next we actually do the RESTORE.  Finally we  ><<U.RAO>>08312000
<< report the results, clean up and leave.                    ><<U.RAO>>08314000
<<[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[><<U.RAO>>08316000
DEVP := " ";  <<IN CASE NO DEV SUPPLIED>>                      <<U.RAO>>08318000
DELIM := ";";  <<IN CASE NO FILESETS SPECIFIED>>               <<U.RAO>>08320000
MYCOMMAND(P,,MAXPARMS,NUMPARMS,PARMS);                         <<U.RAO>>08322000
IF <> THEN   <<TOO MANY PARAMETERS>>                           <<U.RAO>>08324000
   BEGIN                                                       <<U.RAO>>08326000
   TOS := ENUMBER := RSTOR2MP;                                 <<U.RAO>>08328000
   TOS := PARMS(T1);  <<LAST PARM>>                            <<U.RAO>>08330000
   TOS := TOS&LSR(8); <<LENGTH FIELD>>                         <<U.RAO>>08332000
   TOS := TOS+TOS;   <<ADDRESS OF BAD PARM, PROBABLY>>         <<U.RAO>>08334000
   CIERR(*, *, %10000, MAXPARMS);                              <<U.RAO>>08336000
   PNUMBER := MAXPARMS;                                        <<U.RAO>>08338000
   RETURN                                                      <<U.RAO>>08340000
   ;DEBUG;     << dummy call >>                                <<02546>>08342000
   END;                                                        <<U.RAO>>08344000
IF INVALIDTAPENAME THEN RETURN;  <<BAD TAPE NAME PARM>>        <<U.RAO>>08346000
IF NEXTDELIM=EQSIGN OR NEXTDELIM=COMMA THEN  <<STRANGE SYNTAX>><<U.RAO>>08348000
   CIERR(ENUMBER := RSTORXPCTSEMITF, PR(INTEGER(PL)))          <<U.RAO>>08350000
ELSE                                                           <<U.RAO>>08352000
   BEGIN                                                       <<U.RAO>>08354000
   IF NEXTDELIM=SEMI THEN   <<FILESET SPECIFIED>>              <<U.RAO>>08356000
      BEGIN                                                    <<U.RAO>>08358000
      TOS := PARMS(PNUMBER);                                   <<U.RAO>>08360000
      DEL;   <<JUST LEAVE POINTER TO FIRST FILESET>>           <<U.RAO>>08362000
      @FILESETLIST := TOS;                                     <<U.RAO>>08364000
      DO    <<SCAN THROUGH FILESETS>>                          <<U.RAO>>08366000
         BEGIN                                                 <<U.RAO>>08368000
         GETNEXT;                                              <<U.RAO>>08370000
         END UNTIL NEXTDELIM <> COMMA;                         <<U.RAO>>08372000
      IF NEXTDELIM=EQSIGN THEN   <<MORE STRANGE SYNTAX>>       <<U.RAO>>08374000
         BEGIN                                                 <<U.RAO>>08376000
         CIERR(ENUMBER := STORUNXPCTEQFST, PR(INTEGER(PL)));   <<U.RAO>>08378000
         RETURN                                                <<U.RAO>>08380000
         END;                                                  <<U.RAO>>08382000
      IF NOT PARSEOTHERPARMS THEN RETURN;  <<PARSE PROBLEMS>>  <<U.RAO>>08384000
      END;   <<PARSE OF PARAMETERS>>                           <<U.RAO>>08386000
   PNUMBER := 0;                                               <<U.RAO>>08388000
   <<NOW WE ENTER THE EXECUTION PHASE OF THE COMMAND.>>        <<U.RAO>>08390000
   IF REQUESTSERVICE THEN RETURN;   <<BREAK>>                  <<U.RAO>>08392000
   IF NOT OPENFILES THEN RETURN;  <<OPEN OF FILES FAILED>>     <<U.RAO>>08394000
                                                               <<02546>>08398000
   << Next, examine the tape.  Position it to header label >>  <<02546>>08400000
                                                               <<02546>>08402000
   IF LABELED THEN GO BIPAS2;   << At hdr label, via FOPEN. >>          08404000
   FREAD(TNUM,HDRLBL,50);                                               08406000
   IF <> THEN                                                           08408000
    IF < THEN FILEERROR(TNUM)                                           08410000
    ELSE                                                                08412000
      BEGIN    << EOF sensed - could be old format. >>                  08414000
      FCONTROL(TNUM,FSF,K);    << Skip 2d EOF >>                        08416000
      IF <> THEN FILEERROR(TNUM);                                       08418000
      END                                                               08420000
   ELSE                                                                 08422000
      BEGIN    << Read OK: could be new format. >>                      08424000
      TOS := @IIBID & LSL(1);                                           08426000
      IF * = "VIIB" THEN                                                08428000
         BEGIN       << Looks like a new STORE tape. >>                 08430000
         FSPACE(TNUM,-1);     << Backspace to re-read header >>         08432000
         IF <> THEN FILEERROR(TNUM);                                    08434000
         END                                                            08436000
      ELSE                                                              08438000
         BEGIN      << Assume it's an old one. >>                       08440000
         FCONTROL(TNUM,FSF,K);                                          08444000
         IF <> THEN FILEERROR(TNUM);                                    08446000
         FCONTROL(TNUM,FSF,K);                                          08448000
         IF <> THEN FILEERROR(TNUM);                                    08450000
         END;                                                           08452000
      END;                                                              08454000
BIPAS2:                                                                 08456000
   << Do KLUDGE for 6250 BPI default case >>                   <<02558>>08458000
   SETUP'FLAGS(TNUM,DENSITY,DESIG,IRESTORE'FLAG,ERRNUM);       <<02558>>08460000
   IF ERRNUM <> 0 THEN                                         <<02558>>08462000
      BEGIN    << Some sort of error >>                        <<02558>>08464000
      IF ERRNUM < 0 THEN                                       <<02558>>08466000
         FILEERROR(TNUM)   << File error on TNUM.  No return >><<02558>>08468000
      ELSE                                                     <<02558>>08470000
         BEGIN           << XRETPMASK failed >>                <<02558>>08472000
         CIERR(ENUMBER := XRETPMASKFAIL);                      <<02558>>08474000
         SHUTFILES(-1);                                        <<02558>>08476000
         RETURN;                                               <<02558>>08478000
         END;                                                  <<02558>>08480000
      END;                                                     <<02558>>08482000
                                                               <<02558>>08484000
   << Increase stack Z to make room for largest tape  >>       <<02558>>08486000
   << block that user expects.  If FRESTORE will be   >>       <<02558>>08488000
   << using ATTACHIO, then stack buffer needs to be   >>       <<02558>>08490000
   << at most 4096 words. >>                                   <<02558>>08492000
   STACK'INC := RECSIZE;                                       <<02558>>08494000
   IF (STACK'INC > 4096) AND USING'ATTIO THEN                  <<02617>>08496000
      STACK'INC := 4096;                                       <<02617>>08498000
                                                               <<02558>>08500000
   PUSH(Z);                                                    <<02546>>08502000
   OLDSIZE := TOS;   << Save state of Z before RESTORE >>      <<02546>>08504000
   PUSH(S);                                                    <<02546>>08506000
   ZSIZE (S0 + STACK'INC + %4000);                             <<03508>>08508000
   DEL;                                                        <<02546>>08510000
   IF <> THEN                                                  <<03508>>08512000
      BEGIN       << Complain about insufficient stack space. ><<02546>>08514000
      ENUMBER := RSTORINSUFSTACK;                              <<02546>>08516000
      SHUTFILES(-1);                                           <<02558>>08518000
      RETURN;                                                  <<02546>>08520000
      END;                                                     <<02546>>08522000
  << Next, develop a list of candidate files to Restore. >>    <<02546>>08524000
   TOS := IRESTORE(FILESETLIST,                                <<02558>>08526000
                   IF IRESTORE'FLAG THEN -TNUM                 <<02558>>08528000
                                    ELSE  TNUM,                <<02558>>08530000
                   CNUM, ENUM, RETVAL);                        <<02558>>08532000
   EVALRETURN(*,*);                                            <<U.RAO>>08534000
   IF CFRCOUNT <> 0 THEN   <<SOMETHING TO RESTORE>>            <<U.RAO>>08536000
      BEGIN                                                    <<U.RAO>>08538000
      TOS := SETCRITICAL;  <<HOLD OFF =ABORTJOB>>              <<U.RAO>>08540000
      RET := FRESTORE(TNUM, CNUM, ENUM, GNUM, DEVP, RETVAL,    <<U.RAO>>08542000
                   -32768,32767,FLAGS);                        <<00425>>08544000
      RESETCRITICAL(*);                                        <<U.RAO>>08546000
      <<NOTE:  WE HOLD OFF EVALUATING FRESTORE RETURN UNTIL>>  <<U.RAO>>08548000
      <<AFTER PRINTING RESULTS FROM RESTORE. THIS IS BECAUSE>> <<U.RAO>>08550000
      <<WE WANT USER TO KNOW STATUS OF HIS FILES>>             <<U.RAO>>08552000
      IF CFRCOUNT=0 THEN   <<SPECIAL PROBLEM IN RESTORE>>      <<U.RAO>>08554000
         EVALRETURN(BRET, ARET);                               <<U.RAO>>08556000
      END;                                                     <<U.RAO>>08558000
   <<RESTORE DONE. >>                                          <<U.RAO>>08560000
   IF ARET <> 1 OR BRET <> TNUM THEN                           <<02546>>08562000
      FCLOSE(TNUM,0,0);    << Rewind tape unless tape error >> <<02546>>08564000
                                                                        08566000
<< Now list the results.  First open the List file  >>                  08568000
                                                                        08570000
   MOVE LIST := "SYSLIST ";                                    <<U.RAO>>08572000
   PNUM := FOPEN(LIST, %514 <<CCTL,VAR,$STDLIST,ASCII,NEW>>,   <<U.RAO>>08574000
             2 <<WRITE ONLY (SAVE)>>, -72);                    <<U.RAO>>08576000
   IF <> THEN   <<OPEN FAILED ON LIST FILE>>                   <<U.RAO>>08578000
      BEGIN                                                    <<U.RAO>>08580000
      IF JOBSESSIONMAIN THEN   <<FORCE TO $STDLIST>>           <<U.RAO>>08582000
         BEGIN                                                 <<U.RAO>>08584000
         FERROR'(PNUM, K);                                     <<U.RAO>>08586000
         CIERR(-RSTORBADSYSLIST);                              <<U.RAO>>08588000
         PNUM := 2;  <<FORCE TO $STDLIST>>                     <<U.RAO>>08590000
         END                                                   <<U.RAO>>08592000
      ELSE   <<A USER PROCESS>>                                <<U.RAO>>08594000
         IF ARET <> 0 THEN  <<PENDING ERROR>>                  <<U.RAO>>08596000
            EVALRETURN(BRET, ARET)  <<DO OLD ERROR>>           <<U.RAO>>08598000
      ELSE  <<NO OTHER ERROR PENDING, DO THIS ONE.>>           <<U.RAO>>08600000
         BEGIN                                                 <<U.RAO>>08602000
         FERROR'(PNUM, PNUMBER);                               <<U.RAO>>08604000
         ENUMBER := RSTORBADSYSLIST;                           <<U.RAO>>08606000
         SHUTFILES(PNUM);                                      <<U.RAO>>08608000
         RETURN                                                <<U.RAO>>08610000
         END;                                                  <<U.RAO>>08612000
      END;                                                     <<U.RAO>>08614000
   <<IF WE MADE IT THIS FAR, WE ARE READY TO LIST>>            <<U.RAO>>08616000
   IF SHOWFLAG THEN                                            <<04.RO>>08618000
      BEGIN                                                    <<04.RO>>08620000
      FGETINFO(PNUM,,,,,DEVTYPE);                              <<04.RO>>08622000
      IF DEVTYPE.(8:8) >= 8 THEN  <<NOT DISC DEVICE>>          <<04.RO>>08624000
         BEGIN                                                 <<04.RO>>08626000
         DATE'LINE(PARMS);                                     <<04.RO>>08628000
         FWRITE(PNUM, PARMS, -27, %60);                        <<04.RO>>08630000
         END                                                   <<04.RO>>08632000
      END;                                                     <<04.RO>>08634000
   MOVE DESIG := "RESTORED ";                                  <<U.RAO>>08636000
   TOS := PRINTDFILE(PNUM, GNUM, GFRCOUNT, 1, DESIG, SHOWFLAG);<<U.RAO>>08638000
   IF ARET=0 THEN                                              <<U.RAO>>08640000
      EVALRETURN(*,*)                                          <<U.RAO>>08642000
   ELSE                                                        <<U.RAO>>08644000
      DDEL;                                                    <<U.RAO>>08646000
   TOS := PRINTDFILE(PNUM, ENUM, EFRCOUNT, 0, DESIG, SHOWFLAG);<<U.RAO>>08648000
   IF ARET=0 THEN                                              <<U.RAO>>08650000
      EVALRETURN(*,*)                                          <<U.RAO>>08652000
   ELSE                                                        <<U.RAO>>08654000
      DDEL;                                                    <<U.RAO>>08656000
   <<FINALLY, IF THERE IS A PENDING ERROR, PRINT IT>>          <<U.RAO>>08658000
   EVALRETURN(BRET, ARET);                                     <<U.RAO>>08660000
   SHUTFILES(-1);                                              <<U.RAO>>08662000
   END;                                                        <<U.RAO>>08664000
END;  <<CXRESTORE>>                                            <<U.RAO>>08666000
$PAGE "IRESTORE  --  PRODUCE LIST OF FILES TO BE RESTORED"              08668000
$CONTROL SEGMENT=STORE                                                  08670000
   DOUBLE PROCEDURE IRESTORE(FILESETS,TNUM,CNUM,ENUM,RETVAL);           08672000
      VALUE TNUM,CNUM,ENUM;                                             08674000
      INTEGER TNUM,CNUM,ENUM;                                           08676000
      BYTE ARRAY FILESETS;                                              08678000
      INTEGER ARRAY RETVAL;                                             08680000
      OPTION PRIVILEGED,UNCALLABLE;                                     08682000
                                                                        08684000
<<*******************************************************************>> 08686000
<<                                                                      08688000
   PARAMETERS:                                                          08690000
                                                                        08692000
      FILESETS    BYTE POINTER TO FILESETS TO BE RESTORED               08694000
                                                                        08696000
      TNUM        FILE NUMBER OF TAPE FILE                              08698000
                                                                        08700000
      CNUM        FILE NUMBER OF DISC FILE FOR CANDIDATES TO BE         08702000
                  RESTORED                                              08704000
                                                                        08706000
      ENUM        FILE NUMBER OF DISC FILE FOR LIST OF FILES NOT        08708000
                  RESTORED                                              08710000
                                                                        08712000
      RETVAL      (0)--# OF RECORDS IN CNUM                             08714000
                  (1)--# OF RECORDS IN ENUM                             08716000
                                                                        08718000
   SEE CXRESTORE FOR IRESTORE RETURNS.                                  08720000
                                                                     >> 08722000
<<*******************************************************************>> 08724000
<<                                                                      08726000
      FILESET         FILESET          FILESET          FILESET    SPEC 08728000
                                                                        08730000
      @.@.@            @.@.A            @.G.A            F.G.A      0   08732000
                       @.@              @.G              F.G        1   08734000
                                        @                F          2   08736000
                                                                        08738000
  ROOT= %12             %11               %10               0    05.PV  08740000
                                                                        08742000
      ALLTAB           ATAB()          AGTAB()           AGFTAB()       08744000
                                                                        08746000
               ROOT = TYPE.(9:4)   FROM PRODUCEPARMS           00.GEN   08748000
               SPEC = TYPE.(13:3)  FROM PRODUCEPARMS                    08750000
                                                                        08752000
                                                                        08754000
        ALLTAB           ATAB              AGTAB            AGFTAB      08756000
                                                                        08758000
      **********       **********        **********       **********    08760000
      *FILESET#*     0 *        *     0  *        *     0 *        *    08762000
      **********     1 *  ACCT  *     1  * GROUP  *     1 *  FILE  *    08764000
                     2 *        *     2  *        *     2 *        *    08766000
                     3 *        *     3  *        *     3 *        *    08768000
                       **********        **********       **********    08770000
                     4 *FILESET#*     4  *        *     4 *        *    08772000
                       **********     5  *  ACCT  *     5 * GROUP  *    08774000
                                      6  *        *     6 *        *    08776000
                                      7  *        *     7 *        *    08778000
                                         **********       **********    08780000
                                      8  *FILESET#*     8 *        *    08782000
                                         **********     9 *  ACCT  *    08784000
                                                       10 *        *    08786000
                                                       11 *        *    08788000
                                                          **********    08790000
                                                       12 *        *    08792000
                                                       13 *  LOCK  *    08794000
                                                       14 *  WORD  *    08796000
                                                       15 *        *    08798000
                                                          **********    08800000
                                                       16 *FILESET#*    08802000
                                                          **********    08804000
                                                                        08806000
          AROOT =          2                 1                 0        08808000
                                                                     >> 08810000
<<*******************************************************************>> 08812000
BEGIN                                                                   08814000
                                                              <<00.GEN>>08816000
   DEFINE ADJUSTEDROOT=                                       <<00.GEN>>08818000
            (IF G'FNAME<>"@ " THEN 0                          <<00.GEN>>08820000
             ELSE IF G'GNAME<>"@ " THEN 1                     <<00.GEN>>08822000
             ELSE IF G'ANAME<>"@ " THEN 2                     <<00.GEN>>08824000
             ELSE 3) #;                                       <<00.GEN>>08826000
   DEFINE ROOT = D'TYPE.(ENDLEVELFX) #,                       <<00.GEN>>08828000
          SPEC = D'TYPE.(STARTLEVELF) #;                      <<00.GEN>>08830000
   BYTE ARRAY WHOUSER(0:7),WHOGROUP(0:7);                     <<00.GEN>>08832000
   ARRAY WWHOACCT(0:3);                                       <<00.GEN>>08834000
   BYTE ARRAY WHOACCT(*)= WWHOACCT;                           <<00.GEN>>08836000
   DOUBLE CAPABILITY;                                                   08840000
   INTEGER CAP=CAPABILITY;                                              08842000
   EQUATE CR=%015;            << CARRIAGE RETURN >>                     08844000
   INTEGER ALLTAB:=0;                                                   08846000
   EQUATE ATABESIZE=5,                                                  08848000
          ATABCSIZE=4,                                                  08850000
          ATABENTRIES=10,                                               08852000
          ATABDIM = ATABESIZE*ATABENTRIES - 1 ;                         08854000
   INTEGER ARRAY ATAB(0:ATABDIM);      << ACCT NAMES >>                 08856000
   EQUATE AGTABESIZE=9,                                                 08858000
          AGTABCSIZE=8,                                                 08860000
          AGTABENTRIES=15,                                              08862000
          AGTABDIM = AGTABESIZE*AGTABENTRIES - 1;                       08864000
   INTEGER ARRAY AGTAB(0:AGTABDIM);    << ACCT, GROUP NAMES >>          08866000
   EQUATE AGFTABESIZE=17,                                               08868000
          AGFTABCSIZE=12,                                               08870000
          AGFTABENTRIES=20,                                             08872000
          AGFTABDIM = AGFTABESIZE*AGFTABENTRIES - 1;                    08874000
   INTEGER ARRAY AGFTAB(0:AGFTABDIM);  << ACCT,GROUP,FILE NAMES >>      08876000
   INTEGER  NA := 0,       << # ENTRIES IN ATAB    >>                   08878000
            NAG :=0,       << # ENTRIES IN AGTAB   >>                   08880000
            NAGF:=0;       << # ENTRIES IN AGFTAB  >>                   08882000
   INTEGER BRET=IRESTORE, ARET=IRESTORE+1;                              08884000
   INTEGER ENUMREC := 0;                                                08886000
   INTEGER NCFILE := 0;                                                 08888000
   INTEGER RECSIZE;                                            <<00425>>08892000
   INTEGER SAVX;                                                        08894000
   INTEGER ARRAY BLANKS(0:3);                                           08896000
   INTEGER ARRAY PPRESULT(0:PPR'LEN-1);                       <<00.GEN>>08898000
   BYTE ARRAY BPPRESULT(*)=PPRESULT;                          <<00.GEN>>08900000
   INTEGER ARRAY R(0:20);                                      <<38.PV>>08902000
   BYTE POINTER FILESETX;                                               08904000
   BYTE POINTER DELIM;                                        <<00.GEN>>08906000
   INTEGER K, T;                                               <<02546>>08908000
   LOGICAL SMORSS;                                                      08910000
   INTEGER LEN,ML;                                                      08912000
INTEGER POINTER TDBUF;                                         <<00425>>08914000
   INTEGER ARRAY TRAILBL (0:49);                               <<PV.RS>>08916000
   BYTE ARRAY ZLBL (*) = HDRLBL;                               <<RV.RS>>08918000
   INTEGER AROOT,M;                                            <<U.RAO>>08920000
   BYTE POINTER BTEMP,BTMP1;                                            08922000
   INTEGER POINTER IPTR;                                       <<U.RAO>>08926000
   INTEGER ARRAY FBUF(0:13);                                            08928000
   INTEGER LL;                                                          08930000
   INTEGER                                                     <<RV.RS>>08932000
       DIR'BLOCKSIZE,   << Size of directory reads >>          <<02558>>08934000
       FIRST'FILE'ON'VOL := 0,                                 <<RV.RS>>08936000
       FIRSTCAND := 0,                                         <<RV.RS>>08938000
       DIRELMNO := 0;                                          <<RV.RS>>08940000
   LOGICAL                                                     <<02558>>08942000
      FOPTIONS,                                                <<02558>>08944000
      DEVTYPE,                                                 <<02558>>08946000
      DEFAULT'6250;                                            <<02558>>08948000
      << TRUE when user takes defaults for 6250 BPI tape >>    <<02558>>08950000
                                                              <<00.GEN>>08954000
<<***********************>>                                   <<00.GEN>>08956000
<<  SUBROUTINE WORDADDR  >>                                   <<00.GEN>>08958000
<<***********************>>                                   <<00.GEN>>08960000
                                                              <<00.GEN>>08962000
INTEGER SUBROUTINE WORDADDR(BYTEADDR);                        <<00.GEN>>08964000
                           VALUE BYTEADDR;                    <<00.GEN>>08966000
                           BYTE POINTER BYTEADDR;             <<00.GEN>>08968000
BEGIN                                                         <<00.GEN>>08970000
  TOS:=WORDADDR:=@BYTEADDR&LSR(1);                            <<00.GEN>>08972000
  PUSH(Z);                                                    <<00.GEN>>08974000
  IF TOS>TOS THEN WORDADDR.(0:1):=1;                          <<00.GEN>>08976000
END <<SUBROUTINE WORDADDR>>;                                  <<00.GEN>>08978000
<<*******************************************************************>> 08980000
<< SUBROUTINE TO SEARCH A TABLE (TABL) FOR A GIVEN ENTRY (NEWE) AND  >> 08982000
<<  ADD THE ENTRY IF IT ISN'T ALREADY IN THE TABLE.                  >> 08984000
<<                                                                   >> 08986000
<<       RETURNS:  TRUE   -  IF NEWE IS NOT IN TABLE AND THERE ISN'T >> 08988000
<<                           ENUF ROOM TO ADD IT.                    >> 08990000
<<                                                                   >> 08992000
<<                 FALSE  -  IF NEWE IS NOW IN TABLE  (EITHER BEFORE >> 08994000
<<                           OR AFTER THE CALL OF ADDENTRY.)         >> 08996000
<<*******************************************************************>> 08998000
 LOGICAL SUBROUTINE ADDENTRY(TABL,ELEN,NUME,MAXE,NEWE,CMPL);            09000000
      VALUE ELEN,MAXE,CMPL;                                             09002000
      INTEGER ELEN,NUME,MAXE,CMPL;                                      09004000
      INTEGER ARRAY  TABL,NEWE;                                         09006000
 BEGIN                                                                  09008000
      @BTEMP := @TABL&LSL(1);                                           09010000
      @BTMP1 := @NEWE&LSL(1);                                           09012000
      T := CMPL&LSL(1);                                                 09014000
      LL:=ELEN&LSL(1);                                                  09016000
      M := -1;                                                          09018000
      WHILE (M:=M+1) < NUME                                             09020000
      DO BEGIN                                                          09022000
            IF BTEMP = BTMP1,(T) THEN RETURN;                           09024000
            @BTEMP := @BTEMP + LL;                                      09026000
         END;                                                           09028000
   <<                                                       >>          09030000
   <<  NEWE NOT IN TABLE. ADD IT IF THERE IS ROOM.          >>          09032000
   <<                                                       >>          09034000
      IF M = MAXE THEN                                                  09036000
         BEGIN                                                          09038000
            ADDENTRY := TRUE;         << WON'T FIT >>                   09040000
            RETURN;                                                     09042000
         END;                                                           09044000
      MOVE BTEMP := BTMP1,(T);                                          09046000
      NUME := NUME +1;                                                  09048000
      @IPTR := WORDADDR(BTEMP);                               <<00.GEN>>09050000
      IPTR(ELEN-1) := K ;      << FILESET NUMBER >>                     09052000
 END << ADDENTRY >> ;                                                   09054000
<<*******************************************************************>> 09056000
<<   SUBROUTINE TO WRITE RECORDS ON ERROR FILE (ENUM).   THE FIRST   >> 09058000
<<   13 WORDS OF FBUF ARE ASSUMED TO CONTAIN F.G.A & FILESET NUMBER. >> 09060000
<<                                                                   >> 09062000
<<       RETURNS:     FALSE  -  OK.                                  >> 09064000
<<                    TRUE   -  ERROR WRITING ON ENUM.               >> 09066000
<<*******************************************************************>> 09068000
 SUBROUTINE WRITEENUM(ECODE,DETAIL);                                    09070000
      VALUE ECODE,DETAIL;                                               09072000
      INTEGER ECODE,DETAIL;                                             09074000
 BEGIN                                                                  09076000
      FBUF(13) := DETAIL CAT ECODE (0:8:8);                             09078000
      FWRITE(ENUM,FBUF,14,0);                                           09080000
      IF <> THEN                                                        09082000
        BEGIN                                                           09084000
          ARET := 1;    <<FILE ERROR>>                                  09086000
          BRET := ENUM;                                                 09088000
          ASSEMBLE(EXIT 5);                                             09090000
        END;                                                            09092000
      ENUMREC := ENUMREC + 1;                                           09094000
 END << WRITEENUM >>;                                                   09096000
<<*******************************************************************>> 09098000
<<   SUBROUTINE TO SCAN A TABLE (ATAB, AGTAB, OR AGFTAB) .  IF H/O   >> 09100000
<<   BIT OF FILESET WORD IS ZERO, THEN THE TABLE ENTRY WAS NOT       >> 09102000
<<    REFERENCED, WHICH MEANS THAT THE RESTORE COMMAND SPECIFIED A   >> 09104000
<<    FILESET WHICH WAS NOT ON TAPE.  FOR EACH SUCH TABLE ENTRY, A   >> 09106000
<<   RECORD IS WRITTEN ON ENUM.                                      >> 09108000
<<                                                                   >> 09110000
<<       RETURNS:    FALSE  -  NORMAL.                               >> 09112000
<<                   TRUE   -  WRITE ERROR ON ENUM.                  >> 09114000
<<*******************************************************************>> 09116000
 SUBROUTINE SCANERR(TABL,ELEN,NUME,CMPL);                               09118000
      VALUE ELEN,NUME,CMPL;                                             09120000
      INTEGER ELEN,NUME,CMPL;                                           09122000
      INTEGER ARRAY TABL;                                               09124000
 BEGIN                                                                  09126000
      @IPTR := @TABL;                                                   09128000
      M := -1;                                                          09130000
      WHILE (M:=M+1) < NUME                                             09132000
        DO BEGIN                                                        09134000
               IF IPTR(ELEN-1).(0:1) = 0 THEN                           09136000
                  BEGIN           << UNREF TABLE ENTRY >>               09138000
                     FBUF := "  ";                                      09140000
                     MOVE FBUF(1) := FBUF,(11);                         09142000
                     MOVE FBUF(12-CMPL) := IPTR,(CMPL+1);               09144000
                     IF @TABL=@AGFTAB THEN FBUF(12) := IPTR(16);        09146000
                     WRITEENUM(11,0);  <<NOT ON TAPE>>                  09148000
                  END;                                                  09150000
               @IPTR := @IPTR + ELEN;                                   09152000
           END << WHILE >>;                                             09154000
 END << SCANERR>>;                                                      09156000
                                                              <<00.GEN>>09158000
<<***********************>>                                   <<00.GEN>>09160000
<<  SUBROUTINE FINDFILE  >>                                   <<00.GEN>>09162000
<<***********************>>                                   <<00.GEN>>09164000
                                                              <<00.GEN>>09166000
LOGICAL SUBROUTINE FINDFILE(AGFNAME,IPTR);                    <<00.GEN>>09168000
                           ARRAY AGFNAME;                     <<00.GEN>>09170000
                           INTEGER POINTER IPTR;              <<00.GEN>>09172000
BEGIN                                                         <<00.GEN>>09174000
  @IPTR:=@AGFTAB;                                             <<00.GEN>>09176000
  M:=0;                                                       <<00.GEN>>09178000
  WHILE (M:=M+1)<=NAGF DO                                     <<00.GEN>>09180000
  BEGIN                                                       <<00.GEN>>09182000
    IF DIRMATCH(IPTR(8),AGFNAME(8))=0 AND                     <<00.GEN>>09184000
       DIRMATCH(IPTR(4),AGFNAME(4))=0 AND                     <<00.GEN>>09186000
       DIRMATCH(IPTR,AGFNAME)=0 THEN                          <<00.GEN>>09188000
    BEGIN                                                     <<00.GEN>>09190000
      FINDFILE:=TRUE;                                         <<00.GEN>>09192000
      RETURN;                                                 <<00.GEN>>09194000
    END;                                                      <<00.GEN>>09196000
    @IPTR:=@IPTR+AGFTABESIZE;                                 <<00.GEN>>09198000
  END <<UNTIL END OF TABLE>>;                                 <<00.GEN>>09200000
  FINDFILE:=FALSE;                                            <<00.GEN>>09202000
END <<SUBROUTINE FINDFILE>>;                                  <<00.GEN>>09204000
                                                              <<00.GEN>>09206000
<<************************>>                                  <<00.GEN>>09208000
<<  SUBROUTINE FINDGROUP  >>                                  <<00.GEN>>09210000
<<************************>>                                  <<00.GEN>>09212000
                                                              <<00.GEN>>09214000
LOGICAL SUBROUTINE FINDGROUP(AGNAME,IPTR);                    <<00.GEN>>09216000
                            ARRAY AGNAME;                     <<00.GEN>>09218000
                            INTEGER POINTER IPTR;             <<00.GEN>>09220000
BEGIN                                                         <<00.GEN>>09222000
  @IPTR:=@AGTAB;                                              <<00.GEN>>09224000
  M:=0;                                                       <<00.GEN>>09226000
  WHILE (M:=M+1)<=NAG DO                                      <<00.GEN>>09228000
  BEGIN                                                       <<00.GEN>>09230000
    IF DIRMATCH(IPTR(4),AGNAME(4))=0 AND                      <<00.GEN>>09232000
       DIRMATCH(IPTR,AGNAME)=0 THEN                           <<00.GEN>>09234000
    BEGIN                                                     <<00.GEN>>09236000
      FINDGROUP:=TRUE;                                        <<00.GEN>>09238000
      RETURN;                                                 <<00.GEN>>09240000
    END;                                                      <<00.GEN>>09242000
    @IPTR:=@IPTR+AGTABESIZE;                                  <<00.GEN>>09244000
  END <<UNTIL END OF TABLE>>;                                 <<00.GEN>>09246000
  FINDGROUP:=FALSE;                                           <<00.GEN>>09248000
END <<SUBROUTINE FINDGROUP>>;                                 <<00.GEN>>09250000
                                                              <<00.GEN>>09252000
<<***********************>>                                   <<00.GEN>>09254000
<<  SUBROUTINE FINDACCT  >>                                   <<00.GEN>>09256000
<<***********************>>                                   <<00.GEN>>09258000
                                                              <<00.GEN>>09260000
LOGICAL SUBROUTINE FINDACCT(ANAME,IPTR);                      <<00.GEN>>09262000
                           ARRAY ANAME;                       <<00.GEN>>09264000
                           INTEGER POINTER IPTR;              <<00.GEN>>09266000
BEGIN                                                         <<00.GEN>>09268000
  @IPTR:=@ATAB;                                               <<00.GEN>>09270000
  M:=0;                                                       <<00.GEN>>09272000
  WHILE (M:=M+1)<=NA DO                                       <<00.GEN>>09274000
  BEGIN                                                       <<00.GEN>>09276000
    IF DIRMATCH(IPTR,ANAME)=0 THEN                            <<00.GEN>>09278000
    BEGIN                                                     <<00.GEN>>09280000
      FINDACCT:=TRUE;                                         <<00.GEN>>09282000
      RETURN;                                                 <<00.GEN>>09284000
    END;                                                      <<00.GEN>>09286000
    @IPTR:=@IPTR+ATABESIZE;                                   <<00.GEN>>09288000
  END <<UNTIL END OF TABLE>>;                                 <<00.GEN>>09290000
  FINDACCT:=FALSE;                                            <<00.GEN>>09292000
END <<SUBROUTINE FINDACCT>>;                                  <<00.GEN>>09294000
                                                                        09296000
          <<---------------------                                       09298000
     IRESTORE - main procedure                                          09300000
  Tape has been positioned to header label; verify it.                  09302000
          --------------------->>                                       09304000
                                                               <<02558>>09308000
   << When TNUM is negative, the user did not specify a >>     <<02558>>09310000
   << record size for a 6250 BPI unlabelled tape.  FGETINFO >> <<02558>>09312000
   << will return a record size of 4096 words, but the >>      <<02558>>09314000
   << default expectation for block size is 8192 words. >>     <<02558>>09316000
   IF TNUM < 0 THEN                                            <<02558>>09318000
      BEGIN    << Special case >>                              <<02558>>09320000
      TNUM := -TNUM;                                           <<02558>>09322000
      DEFAULT'6250 := TRUE;                                    <<02558>>09324000
      END                                                      <<02558>>09326000
   ELSE        << Normal processing >>                         <<02558>>09328000
      DEFAULT'6250 := FALSE;                                   <<02558>>09330000
                                                               <<02558>>09332000
   FGETINFO(TNUM,,FOPTIONS,,RECSIZE,DEVTYPE);                  <<02546>>09334000
   IF <> THEN                                                  <<02546>>09336000
      BEGIN     << error >>                                    <<02546>>09338000
      BRET := TNUM;                                            <<02546>>09340000
      ARET := 1;                                               <<02546>>09342000
      RETURN;                                                  <<02546>>09344000
      END;                                                     <<02546>>09346000
   IF DEFAULT'6250 THEN                                        <<02558>>09348000
      RECSIZE := 8192;  << User expectation >>                 <<02558>>09350000
                                                               <<02558>>09352000
   BLANKS := "  ";                                             <<02546>>09354000
   MOVE BLANKS(1) := BLANKS,(3);                               <<02546>>09356000
   IF LABELED THEN                                             <<02546>>09358000
      BEGIN          << Read header label >>                   <<02546>>09360000
      LRELSW(TNUM);    << Turn on Store tape flag >>           <<02546>>09362000
      LEN := 40;                                               <<02546>>09364000
      FREADLABEL(TNUM,HDRLBL,40);                              <<02546>>09366000
      END                                                      <<02546>>09368000
   ELSE                                                        <<02546>>09370000
      LEN := FREAD(TNUM,HDRLBL,50);                            <<02546>>09372000
   IF < THEN                                                   <<02546>>09374000
      BEGIN      << I/O error on tape -- fatal. >>             <<02546>>09376000
TERR: BRET := TNUM;                                            <<02546>>09378000
      ARET := 1;                                               <<02546>>09380000
      RETURN                                                   <<02546>>09382000
      END;                                                     <<02546>>09384000
   IF > OR LEN <> 40 OR ZLBL <> LABELTEXT THEN                 <<02546>>09386000
      BEGIN   << Not a STORE tape >>                           <<02546>>09388000
TER1:                                                          <<02546>>09390000
      ARET := 7;                                               <<02546>>09392000
      RETURN;                                                  <<02546>>09394000
      END;                                                     <<02546>>09396000
   TOS := @IIBID & LSL(1);                                     <<02546>>09398000
   IF * = "VIIB" THEN FIRST'FILE'ON'VOL :=                     <<02546>>09400000
      FFILEINX + SPANTOG                                       <<02546>>09402000
   ELSE TAPEBLOCKSIZE := 1024;     << for pre-MPE2B >>         <<02546>>09404000
   IF LABELED THEN                                             <<02546>>09406000
      BEGIN    << Advance to directory file >>                 <<02546>>09408000
      IF REELNUM <> 1 THEN                                     <<02546>>09410000
         BEGIN    << Skip over file continuation >>            <<02546>>09412000
         NEXTTAPEFILE(TNUM);                                   <<02546>>09414000
         IF < THEN GO TERR;                                    <<02649>>09416000
         IF > THEN GO BADTAPE;  << Should have directory. >>   <<02649>>09418000
         END;                                                  <<02546>>09420000
      END                                                      <<02546>>09422000
   ELSE IF REELNUM = 1 THEN                                    <<02546>>09424000
      BEGIN      << Skip tape mark following header. >>        <<02546>>09426000
      FCONTROL(TNUM,FSF,K);                                    <<02546>>09428000
      IF <> THEN GOTO TERR;                                    <<02546>>09430000
      END;    << Now positioned at directory file. >>          <<02546>>09432000
   IF TAPEBLOCKSIZE = 0 THEN TAPEBLOCKSIZE := 1024;            <<02546>>09434000
   IF TAPEBLOCKSIZE > RECSIZE THEN                             <<02546>>09436000
      BEGIN      << Tape blocksize larger than expected. >>    <<02558>>09438000
      ARET := 13;                                              <<02558>>09440000
      BRET := TAPEBLOCKSIZE;                                   <<02558>>09442000
      RETURN;                                                  <<02546>>09444000
      END;                                                     <<02546>>09446000
                                                               <<02558>>09448000
   << Allocate buffer space for directory block transfers. >>  <<02558>>09450000
   DIR'BLOCKSIZE := TAPEBLOCKSIZE;   << From header label. >>  <<02558>>09452000
                                                               <<02558>>09454000
   << For magtapes, directory blocks never exceed 4096 W. >>   <<02558>>09456000
   IF (DIR'BLOCKSIZE > 4096) AND (DEVTYPE.DTYPE = MAGTAPE) THEN<<02558>>09458000
      DIR'BLOCKSIZE := 4096;                                   <<02558>>09460000
                                                               <<02558>>09462000
   PUSH(S);                                                    <<02546>>09464000
   @TDBUF := TOS+1;    << Tape buffer word address >>          <<02546>>09466000
   TOS := DIR'BLOCKSIZE;                                       <<02558>>09468000
   ASSEMBLE(ADDS 0);     << Allocate tape buffer >>            <<02546>>09470000
                                                               <<02558>>09472000
   R := TAPEBLOCKSIZE;    << save block size in candidate      <<02546>>09474000
   FWRITE(CNUM,R,17,0);    << file for FRESTORE. >>            <<02546>>09478000
   IF <> THEN GO TO CERREXIT;                                  <<02546>>09480000
          WHO(,CAPABILITY,,WHOUSER,WHOGROUP,WHOACCT);                   09482000
          TOS := CAP;                                                   09484000
          X := 0;                                                       09486000
          ASSEMBLE(TBC 0);   <<SM>>                                     09488000
          IF <> THEN X := 1;                                            09490000
          ASSEMBLE(TBC 5);  <<SS>>                                      09492000
          IF <> THEN X := 1;                                            09494000
          SMORSS := X;                                                  09496000
                                                                        09498000
          <<--------------------------------------------                09500000
            PRODUCE TABLES FOR FILESETS TO BE RESTORED                  09502000
          -------------------------------------------->>                09504000
          K := 0;                                                       09506000
          @FILESETX := @FILESETS;                                       09508000
          IF FILESETX = ";" OR FILESETX = "," THEN                      09510000
            BEGIN   <<NULL FILESET>>                                    09512000
              K := K+1;                                                 09514000
              @DELIM := @FILESETX;                            <<00.GEN>>09516000
              GOTO ROOT6;                                               09518000
            END;                                                        09520000
  NXTF:   K := K+1;                                                     09522000
          IF NOT PRODUCEPARMS(0,FILESETX,PPRESULT,DELIM,ARET) <<00.GEN>>09524000
             THEN                                             <<00.GEN>>09526000
             BEGIN   <<PARSE FAILED ON FILESET NAME>>          <<U.RAO>>09528000
             RETVAL(1) := ARET;  <<ERROR NUMBER>>              <<U.RAO>>09530000
             RETVAL(2) := K+1;  <<PARM NUMBER>>                <<U.RAO>>09532000
             ARET := 2;   <<NOTE SYNTAX ERROR FOR RETURN>>     <<U.RAO>>09534000
             RETURN                                            <<U.RAO>>09536000
             END;                                              <<U.RAO>>09538000
          AROOT:=ADJUSTEDROOT;                                <<00.GEN>>09540000
          IF AROOT=3 THEN                                     <<00.GEN>>09542000
             BEGIN                                            <<00.GEN>>09544000
  ROOT6:     IF SMORSS THEN                                    <<U.RAO>>09546000
                BEGIN                                          <<U.RAO>>09548000
                IF ALLTAB=0 THEN ALLTAB := K;  <<@.@.@>>       <<U.RAO>>09550000
                END                                            <<U.RAO>>09552000
             ELSE IF ADDENTRY(ATAB,ATABESIZE,NA,ATABENTRIES,   <<U.RAO>>09554000
                          WWHOACCT,ATABCSIZE) THEN            <<00.GEN>>09556000
                BEGIN   <<ATAB FULL>>                          <<U.RAO>>09558000
                CIERR(RETVAL(1) := RSTOR2MAFSETS, FILESETX,    <<U.RAO>>09560000
                   %10000, ATABENTRIES);                       <<U.RAO>>09562000
                RETVAL(2) := K+1;                              <<U.RAO>>09564000
                ARET := 8;   <<TABLE FULL>>                    <<U.RAO>>09566000
                BRET := 2;   <<WHICH TABLE IS FULL>>           <<U.RAO>>09568000
                RETURN;                                        <<U.RAO>>09570000
                END;                                          <<00.GEN>>09572000
             GO ENDPARM;                                      <<00.GEN>>09574000
             END;                                             <<00.GEN>>09576000
          IF NOT SMORSS AND                                   <<00.GEN>>09578000
             SPEC=0 AND D'BANAME<>WHOACCT,(8) THEN            <<00.GEN>>09580000
            BEGIN                                             <<00.GEN>>09582000
              MOVE FBUF := G'FNAME,(4),2;                     <<00.GEN>>09584000
              MOVE * := G'GNAME,(4),2;                        <<00.GEN>>09586000
              MOVE * := G'ANAME,(4);                          <<00.GEN>>09588000
              FBUF(12) := K;    <<FILESET #>>                           09590000
              WRITEENUM(2,3);    <<ACCOUNTS DON'T MATCH>>               09592000
              GO ENDPARM;                                               09594000
            END;                                                        09596000
                                                              <<00.GEN>>09598000
          COMMENT:                                            <<00.GEN>>09600000
            WE ASSUME THAT G'FNAME, G'GNAME & G'ANAME ARE     <<00.GEN>>09602000
            CONTIGUOUS AND IN THE ORDER "F.G.A";              <<00.GEN>>09604000
                                                              <<00.GEN>>09606000
          CASE *AROOT OF BEGIN                                          09608000
            BEGIN                                                       09610000
              IF ADDENTRY(AGFTAB,AGFTABESIZE,NAGF,AGFTABENTRIES,        09612000
                    G'FNAME,AGFTABCSIZE) THEN                 <<00.GEN>>09614000
                 BEGIN   <<AGFTAB FULL>>                       <<U.RAO>>09616000
                 CIERR(RETVAL(1) := RSTOR2MAGFFSETS, FILESETX, <<U.RAO>>09618000
                    %10000, AGFTABENTRIES);                    <<U.RAO>>09620000
                 RETVAL(2) := K+1;                             <<U.RAO>>09622000
                 ARET := 8;   <<TABLE FULL>>                   <<U.RAO>>09624000
                 BRET := 0;   <<WHICH TABLE IS FULL>>          <<U.RAO>>09626000
                 RETURN;                                       <<U.RAO>>09628000
                 END;                                          <<U.RAO>>09630000
              MOVE IPTR(12) := D'LOCKWORD,(4);                <<00.GEN>>09632000
            END;                                                        09634000
              IF ADDENTRY(AGTAB,AGTABESIZE,NAG,AGTABENTRIES,  <<00.GEN>>09636000
                          G'GNAME,AGTABCSIZE) THEN            <<00.GEN>>09638000
                 BEGIN   <<AGTAB FULL>>                        <<U.RAO>>09640000
                 CIERR(RETVAL(1) := RSTOR2MAGFSETS, FILESETX,  <<U.RAO>>09642000
                    %10000, AGTABENTRIES);                     <<U.RAO>>09644000
                 RETVAL(2) := K+1;                             <<U.RAO>>09646000
                 ARET := 8;   <<TABLE FULL>>                   <<U.RAO>>09648000
                 BRET := 1;   <<WHICH TABLE IS FULL>>          <<U.RAO>>09650000
                 RETURN;                                       <<U.RAO>>09652000
                 END;                                          <<U.RAO>>09654000
              IF ADDENTRY(ATAB,ATABESIZE,NA,ATABENTRIES,      <<00.GEN>>09656000
                          G'ANAME,ATABCSIZE) THEN             <<00.GEN>>09658000
                 BEGIN   <<ATAB FULL>>                         <<U.RAO>>09660000
                 CIERR(RETVAL(1) := RSTOR2MAFSETS, FILESETX,   <<U.RAO>>09662000
                    %10000, ATABENTRIES);                      <<U.RAO>>09664000
                 RETVAL(2) := K+1;                             <<U.RAO>>09666000
                 ARET := 8;   <<TABLE FULL>>                   <<U.RAO>>09668000
                 BRET := 2;   <<WHICH TABLE IS FULL>>          <<U.RAO>>09670000
                 RETURN;                                       <<U.RAO>>09672000
                END;                                                    09674000
          END <<CASE AROOT>> ;                                          09676000
  ENDPARM:                                                              09678000
          IF DELIM = "," THEN                                 <<00.GEN>>09680000
            BEGIN  <<ANOTHER FILESET>>                                  09682000
              @FILESETX := @DELIM(1);                         <<00.GEN>>09684000
              GO NXTF;                                                  09686000
            END;                                                        09688000
          IF DELIM<>";" AND DELIM<>CR THEN                    <<00.GEN>>09690000
             BEGIN                                             <<U.RAO>>09692000
             TOS := RETVAL(1) := RSTORFSETUNKDEL;              <<U.RAO>>09694000
             TOS := @DELIM;                                   <<00.GEN>>09696000
             CIERR(*,*);                                       <<U.RAO>>09698000
             RETVAL(2) := K+1;                                 <<U.RAO>>09700000
             ARET := 2;                                        <<U.RAO>>09702000
             RETURN;                                           <<U.RAO>>09704000
             END;    <<SYNTAX ERROR>>                          <<U.RAO>>09706000
                                                                        09708000
          <<---------------------------------------                     09710000
         Match tape directory to specified filesets                     09712000
          --------------------------------------->>                     09714000
RDNXTDIREC:                                                             09718000
   IF REQUESTSERVICE THEN                                               09720000
      BEGIN      << BREAK hit >>                                        09722000
      ARET := 12;                                                       09724000
      RETURN;                                                           09726000
      END;                                                              09728000
   LEN := FREAD(TNUM,TDBUF,DIR'BLOCKSIZE);                     <<02558>>09730000
   IF < THEN GO TERR;                                                   09732000
   IF = THEN GO OK1A;    << Directory block was read. >>                09734000
                                                                        09736000
<< EOF encountered reading directory.  If not a labeled tape,           09738000
we might be at end of volume with more directory on next volume.  >>    09740000
                                                                        09742000
   IF LABELED THEN                                                      09744000
      BEGIN       << Close directory, open next file >>                 09746000
      NEXTTAPEFILE(TNUM);                                               09748000
      IF < THEN GO TERR;                                       <<02649>>09750000
      << If this is the last reel of the volume set, there >>  <<02649>>09752000
      << may be no file after the directory.  However, the >>  <<02649>>09754000
      << first reel should have at least one data file.    >>  <<02649>>09756000
      IF > AND REELNUM = 1 THEN GO BADTAPE;                    <<02649>>09758000
      GO EOFTAPDIR;    << data file follows. >>                         09760000
      END;                                                              09762000
                                                                        09764000
   LEN := FREAD(TNUM,TDBUF,DIR'BLOCKSIZE);                     <<02558>>09766000
   IF < THEN GO TERR;                                          <<02558>>09768000
   IF > THEN IF REELNUM <> 1 THEN GO TO EOFTAPDIR ELSE         <<02546>>09770000
      BEGIN        << Got 2 EOF's in a row. >>                          09772000
BADTAPE:                                                                09774000
      ARET := 11;   << report Improper Tape Format. >>                  09776000
      RETURN;                                                           09778000
      END;                                                              09780000
                                                                        09782000
   IF LEN <> 40 THEN     << End of directory; -- >>                     09784000
      BEGIN         << -- re-position tape for FRESTORE. >>             09786000
      FCONTROL(TNUM,BSF,K);                                             09788000
      IF <> THEN GO TERR;                                               09790000
      FCONTROL(TNUM,FSF,K);    << leave positioned at first data. >>    09792000
      IF <> THEN GO TERR;                                               09794000
      GO EOFTAPDIR;                                                     09796000
      END;                                                              09798000
                                                                        09800000
   IF ZFIELD = 1 THEN       << *** Real EOT >>                          09802000
     IF NCFILE <> 0 THEN GO BADTAPE   << screwed up >>                  09804000
      ELSE GO EOFTAPDIR;                                                09806000
   SAVX := XFIELD;                                                      09808000
   TAPESWITCH(TNUM,TDBUF);     << Get next reel >>                      09810000
   IF < THEN                                                            09812000
      BEGIN   << Opr can't or won't mount right tape. >>                09814000
WRONGTAPE:                                                              09816000
      ARET := 9;                                                        09818000
      RETURN;                                                           09820000
      END;                                                              09822000
   IF > THEN GO TERR;    << error on tape file >>                       09824000
   IF SAVX = 0 THEN GO RDNXTDIREC;  << get the record >>                09826000
   GO EOFTAPDIR;      << really end of directory >>                     09828000
                                                                        09830000
OK1A:    IF (LEN MOD LRECLTD) <> 0 THEN GO WRONGTAPE;          <<02558>>09832000
          ML := -LRECLTD;                                               09834000
          WHILE (ML:=ML+LRECLTD) < LEN DO                               09836000
            BEGIN   <<PROCESS DIRECTORY RECORD>>                        09838000
              R(16) := 0;                                               09840000
              IF ALLTAB<>0 THEN                                         09842000
                BEGIN                                                   09844000
                  R(16) := ALLTAB;                                      09846000
                  MOVE R(12) := BLANKS,(4);                             09848000
                END                                           <<00.GEN>>09850000
              ELSE IF FINDACCT(TDBUF(ML+8),IPTR) THEN         <<00.GEN>>09852000
                BEGIN   <<FOUND ACCOUNT IN ATAB>>                       09854000
                  IF R(16)=0 THEN R(16) := IPTR(ATABESIZE-1);           09856000
                  MOVE R(12) := BLANKS,(4);                             09858000
                  IPTR(ATABESIZE-1).(0:1) := 1;  <<MARK REFERENCED>>    09860000
                END                                           <<00.GEN>>09862000
              ELSE IF FINDGROUP(TDBUF(ML+4),IPTR) THEN        <<00.GEN>>09864000
                BEGIN  <<FOUND ENTRY IN ACCOUNT-GROUP TABLE>>           09866000
                  IF R(16)=0 THEN R(16) := IPTR(AGTABESIZE-1);          09868000
                  MOVE R(12) := BLANKS,(4);                             09870000
                  IPTR(AGTABESIZE-1).(0:1) := 1;  <<MARK REFERENCED>>   09872000
                END                                           <<00.GEN>>09874000
              ELSE IF FINDFILE(TDBUF(ML),IPTR) THEN           <<00.GEN>>09876000
                BEGIN                                                   09878000
                  IF R(16)=0 THEN R(16) := IPTR(AGFTABESIZE-1);         09880000
                  MOVE R(12) := IPTR(AGFTABCSIZE),(4);  <<LOCKWORD>>    09882000
                  IPTR(AGFTABESIZE-1).(0:1) := 1;  <<MARK REFERENCED>>  09884000
                END;                                                    09886000
              IF R(16)<>0 THEN                                          09888000
                BEGIN   <<FILE IS A CANDIDATE>>                         09890000
                  MOVE R := TDBUF(ML),(12);  <<NAMES>>                  09892000
                  R(16).(0:1) := 0;  <<CLEAR REFERENCE BIT>>            09894000
                  FWRITE(CNUM,R,17,0);                                  09896000
                  IF <> THEN                                            09898000
                    BEGIN                                               09900000
CERREXIT:                                                      <<00425>>09902000
                      ARET := 1;                                        09904000
                      BRET := CNUM;                                     09906000
                      RETURN;                                           09908000
                    END;                                                09910000
                  NCFILE := NCFILE+1;  <<# OF CANDIDATES>>              09912000
                          IF NCFILE = 1 THEN                   <<RV.RS>>09914000
                           FIRSTCAND := DIRELMNO;              <<RV.RS>>09916000
                END;                                                    09918000
                DIRELMNO := DIRELMNO + 1;                      <<RV.RS>>09920000
            END;                                                        09922000
          GO RDNXTDIREC;                                                09924000
                                                                        09926000
  EOFTAPDIR:                                                            09928000
          SCANERR(ATAB,ATABESIZE,NA,ATABCSIZE);                         09930000
          SCANERR(AGTAB,AGTABESIZE,NAG,AGTABCSIZE);                     09932000
          SCANERR(AGFTAB,AGFTABESIZE,NAGF,AGFTABCSIZE);                 09934000
          IF NCFILE > 0 THEN                                   <<RV.RS>>09936000
           IF FIRSTCAND < FIRST'FILE'ON'VOL THEN               <<RV.RS>>09938000
            DO BEGIN                                           <<RV.RS>>09940000
                   FIRST'FILE'ON'VOL :=                        <<RV.RS>>09942000
                      STARTVOLUME(TNUM,HDRLBL);                <<02546>>09944000
                   IF <> THEN                                  <<RV.RS>>09946000
                    IF < THEN GO TO WRONGTAPE                  <<RV.RS>>09948000
                    ELSE                                       <<RV.RS>>09950000
                     GO TO TERR;                               <<RV.RS>>09952000
               END UNTIL FIRSTCAND >= FIRST'FILE'ON'VOL;       <<RV.RS>>09954000
          RETVAL := NCFILE;                                             09956000
          RETVAL(1) := ENUMREC;                                         09958000
      END <<IRESTORE>> ;                                                09960000
$PAGE "FRESTORE  --  RESTORE FILES FROM TAPE TO DISC"                   09962000
$CONTROL SEGMENT=RESTORE                                                09964000
   DOUBLE PROCEDURE FRESTORE(TNUM,CNUM,ENUM,GNUM,DEVPARM,               09966000
                             RETVAL,FCLLIM,FCULIM,FLAGS);               09968000
      VALUE TNUM,CNUM,ENUM,GNUM,FCLLIM,FCULIM,FLAGS;                    09970000
      INTEGER TNUM,CNUM,ENUM,GNUM,FCLLIM,FCULIM;                        09972000
      BYTE ARRAY DEVPARM;                                               09974000
      INTEGER ARRAY RETVAL;                                             09976000
      LOGICAL FLAGS;                                                    09978000
      OPTION PRIVILEGED, UNCALLABLE;                                    09980000
                                                                        09982000
<<*******************************************************************>> 09984000
<<                                                                      09986000
      PARAMETERS TO FRESTORE:                                           09988000
                                                                        09990000
          TNUM        FILE NUMBER OF TAPE FILE                          09992000
                                                                        09994000
          CNUM        FILE NUMBER OF CANDIDATE FILE                     09996000
                                                                        09998000
          ENUM        FILE NUMBER OF ERROR FILE                         10000000
                                                                        10002000
          GNUM        FILE NUMBER OF GOOD FILE                          10004000
          DEVPARM     DEVICE CLASS NAME OF WHERE TO PUT THE FILES       10006000
                                                                        10008000
          RETVAL      (0)--NUMBER OF RECORDS ON CNUM                    10010000
                      (1)--NUMBER OF RECORDS ON ENUM                    10012000
                      (2)--NUMBER OF RECORDS ON GNUM                    10014000
                                                                        10016000
          FCLLIM      LOWEST FILECODE TO BE RESTORED                    10018000
                                                                        10020000
          FCULIM      HIGHEST FILECODE TO BE RESTORED                   10022000
                                                                        10024000
          FLAGS       .(15:1)=1 SEZ IGNORE PRIV MODE CHECK FOR          10026000
                        NEGATIVE FILECODE                               10028000
                      .(14:1)=1 SEZ RETURN IMMEDIATELY ON SOFT ERROR    10030000
                      .(13:1)=1 SEZ KEEP OLD VERSION IF ON DISC         10032000
                      .(12:1)=1 SEZ REPOSITION RESTORE ON ERROR         10034000
                      .(11:1)=1 SEZ DON'T CHANGE MODIFY &ACCESS DATE    10036000
                                                                        10038000
                                                                     >> 10040000
<<*******************************************************************>> 10042000
    BEGIN                                                      <<02871>>10044000
      ENTRY DBFRESTORE;  <<Don't use queuing for 7976>>        <<02871>>10046000
      LOGICAL SPEC'ENTRY;                                      <<02871>>10048000
      DEFINE LPDT1= LPDT'(L&LSL(1)+1)#;                        <<DL.PV>>10050000
      DEFINE ENUMREC=RETVAL(1)#,     <<# OF RECORDS ON ENUM>>           10052000
             GNUMREC=RETVAL(2)#;     <<# OF RECORDS ON GNUM>>           10054000
      DEFINE NOSOFT=FLAGS.(14:1)#,   <<RETURN ON SOFT ERROR>>           10056000
            BACKUP=FLAGS.(12:1)#, <<REPOSITION TAPE ON ERROR>> <<00425>>10058000
            OLDDATE=FLAGS.(11:1)#,<<KEEP OLD MODIFY & ACCESS DA<<00425>>10060000
             KEEP=FLAGS.(13:1)#;     <<KEEP VERSION OF FILE ON DISC>>   10062000
LOGICAL FOPTIONS,LDEV,DEVTYPE,ECODE;                           <<02546>>10064000
      EQUATE                                                   <<03508>>10068000
             DIRSIR=8;             << Directory SIR >>         <<00482>>10072000
      EQUATE LDTDSTN = %16,          << LDT DST # >>                    10074000
             LDTSIZE = %5;           << SIZE OF LDT ENTRY>>             10076000
      DOUBLE ENTRE;                  << KEEP DISKADDR>>                 10078000
   DOUBLE  BLK'SIZE,REC'SIZE;  <<for RIO files only>>          <<04305>>10080000
   INTEGER BLK'FACT;           <<for RIO files only>>          <<04305>>10082000
      BYTE   BENTRE=ENTRE;           << TO ACCESS THE LDEV >>           10084000
      DOUBLE CAPABILITY,             <<CAPABILITY FROM WHO>>            10086000
             DR,                     <<RETURN FROM DIRECTORY ROUTINES>> 10088000
             OLDTOTAL,               <<TOTAL SECTORS FOR DISC FILE>>    10090000
             NEWTOTAL,               <<TOTAL SECTORS FOR TAPE FILE>>    10092000
             DISKADR,                <<DISC ADDRESS>>                   10094000
             SECTORS,                <<# OF SECTORS IN FILE>>           10096000
             IOB;                    <<RETURN FROM ATTIO>>              10098000
      INTEGER STATUS=IOB,                                      <<02518>>10100000
              ATT'LEN=IOB+1;                                   <<02518>>10102000
      INTEGER LDN,                   <<LOGICAL DEVICE #>>               10104000
            RECSIZE,                                           <<00425>>10106000
              STACK'INC,             <<STACK SPACE FOR BUFFER>><<02558>>10108000
              OLDLDN,                <<LDEV OF OLD FILE>>               10110000
              LSIRET,                <<LDN SIR RETURN>>                 10112000
              SSIRET,                <<DISC SPACE SIR RETURN>>          10114000
              DSIRET,                <<DIRECTORY SIR RETURN>>           10116000
              FSIRET,                <<FILE LABEL SIR RETURN>>          10118000
              OLDVTAB,               <<VTAB INDEX FOR OLD FILE>>        10120000
              OLDP1,                 <<DISC ADDRESS FOR OLD FILE>>      10122000
              OLDP2,                 <<DISC ADDRESS FOR OLD FILE>>      10124000
              NEWP1,                 <<DISC ADDRESS FOR NEW FILE>>      10126000
              NEWP2,                 <<DISC ADDRESS FOR NEW FILE>>      10128000
              LEN,                   <<LENGTH FROM FREAD>>              10130000
              SAVX,                  <<X VALUE FROM TAPE LABEL>>        10132000
              COLDLOADID,            <<COLD LOAD ID>>                   10134000
              TODAYSDATE,            <<DATE FROM CHRONOS>>              10136000
             ERR,                     << Converted FS error >> <<02708>>10138000
              P1=DISKADR,                                               10142000
              P2=DISKADR+1,                                             10144000
              JITDST,                <<DST FOR JIT>>                    10146000
              CAP=CAPABILITY+1,      <<CAPABILITY>>                     10148000
              DRA=DR+1,                                                 10150000
              DRB=DR,                                                   10152000
              BLOCKSWRITTEN,         <<# OF BLOCKS WRITTEN SO FAR>>     10154000
              NBLKS,                 <<# OF BLOCKS>>                    10156000
              CURBUFF,               <<CURRENT XDS BUFFER>>    <<02518>>10158000
              BUFFP,                                           <<02518>>10160000
              B,C,D,                 <<XDS VARIABLES>>         <<02518>>10162000
              N,I,K,M,T,IT,L,                                           10164000
              BRET=FRESTORE,ARET=FRESTORE+1;                            10166000
      LOGICAL BOOL,                  <<DONE WITH CURRENT CANDIDATE>>    10168000
              SMORSS,                <<SYSTEM MANAGER OR SYSTEM SUP>>   10170000
             DSTAT,                   << Dummy STATUS word >>  <<02708>>10172000
              ATTRIB=CAPABILITY,     <<USER ATTRIBUTES>>                10174000
              CNT,SECTORSLEFT,MM,NN,                                    10176000
              FLAG,                                                     10178000
             EXTSIZE,                << SIZE OF EXTENTS.>>              10180000
             LASTEXTSIZE,            << LAST EXTENT SIZE.>>             10182000
             XLDN,                   <<LDEV FOR ATTACHIO>>              10184000
              FOUND;                 <<OLD COPY EXISTS>>                10186000
      INTEGER POINTER FLAB;          <<FILE LABEL>>                     10188000
   INTEGER POINTER TDBUF;                                      <<00425>>10190000
BYTE POINTER BTDBUF;                                           <<00425>>10192000
      DOUBLE POINTER FLABDBL=FLAB;   <<FILE LABEL>>                     10194000
      DOUBLE ARRAY OLDEXTSIZES(0:31),<<SIZES OF EXTENTS FOR OLD FILE>>  10196000
                 DJIT(0:1),          <<CURRENT ACCOUNT IN JIT>>         10198000
                   DACCT(0:1),       <<ACCOUNT FROM WHO>>               10200000
                   NEWEXTSIZES(0:31);<<SIZES OF EXTENTS FOR NEW FILE>>  10202000
      INTEGER ARRAY NEWLABEL(0:128), <<LABEL FOR NEW FILE>>             10204000
                    OLDLABEL(0:128), <<LABEL FOR OLD FILE>>             10206000
                    LOGDEVTAB(*)=DB+0,       <<LDT>>                    10208000
                    FBUF(0:16),      <<CANDIDATE FILE RECORD>>          10210000
                   TRAILBL(*)=TDBUF,                                    10212000
                    R (0:GSIZE-1),   <<RETURNS FROM DIRECTORY R<<RV.PV>>10214000
                    DEVICEINFO(0:8), <<FROM GETDEVINFO>>                10216000
                    XDEVINFO (0:9),                            <<RV.PV>>10218000
                    PREV'FILE (0:11),                          <<02518>>10220000
                    BUFF'STAT(0:NUMBUFF), <<BUFFER STATUS>>    <<02645>>10222000
                    BUFF(0:NUMBUFF); << XDST NUMBERS >>        <<02518>>10224000
      DOUBLE ARRAY  IOQ (0:NUMBUFF); << IOQ STATUS >>          <<02518>>10226000
      INTEGER ARRAY IOQW(*)=IOQ;                               <<02518>>10228000
      DOUBLE ARRAY DTDBUF(*)=TDBUF,                                     10230000
                   RD(*)=R;                                             10232000
      BYTE ARRAY DISCLASS(0:4),      <<DEVICE CLASS "DISC">>            10234000
                 WHOACCT(*)=DACCT,                                      10236000
                 JITACCT(*)=DJIT,                                       10238000
                 BFBUF(*)=FBUF,                                         10240000
                 LMESS (*)=OLDLABEL,  <<LOCKWORD MESSAGE>>     <<RV.PV>>10242000
                 BCURR'GRP (*) = PREV'FILE (4);                <<RC.PV>>10244000
      LOGICAL BSENTRY:=FALSE,        <<BAD ENTRY IN DIRECTORY>>         10248000
              DALLOC:=FALSE,         <<DEVICE IS ALLOCATED>>            10250000
              DSIR:=FALSE,           <<DIRECTORY SIR HELD>>             10254000
              FSIR:=FALSE,           <<FILE LABEL SIR HELD>>            10256000
              ENDFLAG:=FALSE,        <<END OF ALL TAPE REELS>>          10258000
              DATAFLAG:=FALSE,       <<DATA IN TAPE BUFFER>>            10260000
              ATTACH'BUFF:=FALSE,    <<HAVE XDST ALLOC>>       <<02687>>10262000
              DISCP:=TRUE,           <<DISC DEV CLASS EXISTS>> <<28.PV>>10264000
              HVSIND := [8/"*", 8/" "],                        <<RC.PV>>10266000
              PVINFO,                                          <<28.PV>>10268000
              REQTYPE,                                         <<RV.PV>>10270000
              PVINFO' := 0,                                    <<SP.PV>>10274000
              MOUNTEDVS := FALSE;                              <<RV.PV>>10276000
                                                                        10278000
      DEFINE                                                   <<RV.PV>>10280000
          NONSYSVS = R (GLINKAGE).(PVF) = PV #,                <<RV.PV>>10282000
          CLASSFLG = PVINFO.(0:1) #,                           <<RV.PV>>10284000
          MVTABX   = PVINFO.(4:4) #,                           <<RV.PV>>10286000
          VMASK  = PVINFO.(8:8) #;                             <<RV.PV>>10288000
                                                               <<RV.PV>>10290000
      EQUATE                                                   <<RV.PV>>10292000
          CONDMOUNT'BIND = -3,                                 <<RC.PV>>10294000
          CONDDISMOUNT'BIND = -3;                              <<RC.PV>>10296000
                                                               <<02518>>10298000
<<******************************************************>>     <<02518>>10300000
<<               I/O WAIT FOR READ                      >>     <<02518>>10302000
<<******************************************************>>     <<02518>>10304000
   LOGICAL SUBROUTINE WAITFOR'READ(BPTR);                      <<02645>>10306000
           VALUE BPTR;    INTEGER BPTR;                        <<02645>>10308000
   BEGIN                                                       <<02518>>10310000
       IF IOQW(BPTR&LSL(1))=0 THEN RETURN;                     <<02518>>10312000
       IOB := WAITFORIO(IOQW(BPTR&LSL(1)));                    <<02518>>10314000
       IOQ (BPTR) := 0D;                                       <<02518>>10316000
       LEN := ATT'LEN;                                         <<02518>>10318000
   END;  << END WAITFOR'READ >>                                <<02518>>10320000
<<*******************************************************************>> 10324000
<<   SUBROUTINE TO RELEASE SIRS, DEALLOCATE DEVICE AND PURGE BAD     >> 10326000
<<   DIRECTORY ENTRY, IF NECESSARY.                                  >> 10328000
<<*******************************************************************>> 10330000
        SUBROUTINE CLEANUP(ERRORS);                                     10332000
        VALUE ERRORS;                                                   10334000
        LOGICAL ERRORS;                                                 10336000
        BEGIN                                                           10338000
          IF ATTACH'BUFF AND NOT(ERRORS) THEN                  <<02687>>10340000
             BEGIN  << RELEASE EXTRA DATA SEG BUFFERS >>       <<02687>>10342000
             ATTACH'BUFF := FALSE;                             <<02687>>10344000
             B:=0;  WHILE BUFF(B)<>CURBUFF DO B:=B+1;          <<02518>>10346000
             IF (B:=B+1)=NUMBUFF THEN B:=0;                    <<02658>>10348000
             CURBUFF:=BUFF(B);                                 <<02658>>10350000
             DO BEGIN << Clear remaining IO then free XDS >>   <<02658>>10352000
                IF IOQW(B&LSL(1))<>0                           <<03783>>10354000
                   THEN IOB:=WAITFORIO(IOQW(B&LSL(1)));        <<02658>>10356000
                IF BUFF'STAT(B)=2  THEN UNFREEZE (BUFF(B),1,0);<<02645>>10358000
                IF BUFF'STAT(B)>=1 THEN UNLOCKSEG(BUFF(B),1,0);<<02645>>10360000
                IF BUFF'STAT(B)<>0 THEN RELDATASEG(BUFF(B));   <<02687>>10362000
                BUFF'STAT(B):=0;                               <<02687>>10364000
                IOQ(B) := 0D;                                  <<02658>>10366000
                IF (B:=B+1)=NUMBUFF THEN B:=0;                 <<02518>>10368000
                END UNTIL (BUFF(B)=CURBUFF);                   <<02518>>10370000
             END;                                              <<02518>>10372000
          IF BSENTRY THEN                                               10374000
            BEGIN   <<BAD ENTRY IN DIRECTORY>>                          10376000
              BSENTRY := FALSE;                                         10378000
              DR := DIRECPURGEFILE (-NEWTOTAL,0,FLACCTNAME,    <<38.PV>>10380000
                                  FLGRPNAME,FLLOCNAME,MVTABX); <<38.PV>>10382000
              IF <> AND ERRORS THEN GOTO DERR;                          10384000
            END;                                                        10386000
          IF DALLOC THEN                                                10388000
            BEGIN   <<DEVICE STILL ALLOCATED>>                          10390000
              DALLOC := FALSE;                                          10392000
              DISKDEALLOC(0,0,-(FLNUMEXTS+1),NEWEXTSIZES);              10394000
               <<DEALLOC THE DEVICES, KEEP SPACE>>                      10396000
            END;                                                        10398000
          IF DSIR THEN                                                  10402000
            BEGIN  <<RELEASE DIRECTORY SIR>>                            10404000
              RELSIR(DIRSIR,DSIRET);                                    10406000
              DSIR := FALSE;                                            10408000
            END;                                                        10410000
          IF FSIR THEN                                                  10412000
            BEGIN   <<RELEASE FILE LABEL SIR>>                          10414000
              RELSIR(FISIR,FSIRET);                            <<00482>>10416000
              FSIR := FALSE;                                            10418000
            END;                                                        10420000
        END <<CLEANUP>> ;                                               10422000
<<***********************************************************>><<02518>>10424000
<<               NO BUF, NOWAIT TAPE READ                    >><<02518>>10426000
<<***********************************************************>><<02518>>10428000
   LOGICAL SUBROUTINE NOWAIT'READ(CNT);                        <<02518>>10430000
           VALUE CNT;  INTEGER CNT;                            <<02518>>10432000
   BEGIN                                                       <<02518>>10434000
       B:=0;                                                   <<02518>>10436000
       WHILE CURBUFF<>BUFF(B) DO B:=B+1;                       <<02518>>10438000
       IOQ(B) := ATTACHIO (LDEV,0,CURBUFF,0,TREAD,CNT,0,0,0);  <<02518>>10440000
       IF (B:=B+1)=NUMBUFF THEN B:=0;                          <<02518>>10442000
       CURBUFF := BUFF(B);                                     <<02518>>10444000
       IF IOQW(B&LSL(1)) <> 0 THEN WAITFOR'READ(B)             <<02645>>10446000
          ELSE LEN:=STATUS:=1;                                 <<02518>>10448000
   END;  <<END NOWAIT'READ>>                                   <<02518>>10452000
<<*******************************************************************>> 10454000
<<    SUBROUTINE TO UNLOCK A FILE LOCKED BY RESTORE.                 >> 10456000
<<*******************************************************************>> 10458000
        LOGICAL SUBROUTINE UNLOCKFILE;                                  10460000
        BEGIN                                                           10462000
          FSIRET := GETSIR(FISIR);                             <<00482>>10464000
          FLRESTORE := 0;  <<FILE LABEL IS STILL GOOD>>                 10466000
          CHECKSUM;          <<NEW CHECKSUM>>                           10468000
          FLCHECKSUM := TOS; <<UPDATE FLAB>>                            10470000
          IOB := ATTACHIO(LDN,0,0,@FLAB,1,128,NEWP1,NEWP2,1);           10472000
          IF STATUS.(13:3) <> 1 THEN UNLOCKFILE := TRUE                 10474000
          ELSE                                                          10476000
          BEGIN                                                         10478000
              DIRECRESETFLAG (0,0D,FLAB (8),FLAB (4),          <<38.PV>>10480000
                              FLAB,MVTABX);                    <<32.PV>>10482000
              IF <> THEN UNLOCKFILE := TRUE;                            10484000
          END;                                                          10486000
          RELSIR(FISIR,FSIRET);                                <<00482>>10488000
       END;                                                             10490000
                                                                        10492000
<<*******************************************************************>> 10494000
<<   SUBROUTINE TO WRITE A RECORD ON THEN ERROR FILE. IF NOSOFT IS   >> 10496000
<<   SET, FRESTORE IS EXITED AFTER THE APPROPRIATE CLEANUP.          >> 10498000
<<*******************************************************************>> 10500000
      SUBROUTINE WRITEENUM(ECODE,DETAIL);                               10502000
      VALUE ECODE,DETAIL;                                               10504000
        INTEGER ECODE,DETAIL;                                           10506000
        BEGIN                                                           10508000
          ENUMREC := ENUMREC+1;                                         10510000
          FBUF(12) := FBUF(16);  <<FILESET #>>                          10512000
          FBUF(13) := DETAIL CAT ECODE (0:8:8);                         10514000
          FWRITE(ENUM,FBUF,14,0);   <<WRITE TO ERROR FILE>>             10516000
          IF <> THEN                                                    10518000
            BEGIN   <<ERROR ON ERROR FILE>>                             10520000
              ARET := 1;                                                10522000
              BRET := ENUM;                                             10524000
              GOTO CLEAN;                                               10526000
            END;                                                        10528000
          IF NOSOFT THEN   <<RETURN ON SOFT ERROR>>                     10530000
            BEGIN                                                       10532000
  CLEAN:      CLEANUP(FALSE);   <<IGNORE SUBSEQUENT ERRORS>>            10534000
              IF FLAGS.(12:1) THEN FSPACE(TNUM,-1);                     10536000
              ASSEMBLE(EXIT 9);   <<RETURN TO CALLER>>                  10538000
            END;                                                        10540000
        END <<WRITEENUM>> ;                                             10542000
<<******************************************************************>>  10546000
<<   READTAPE: Read tape blocks and forward-space files.  Supports  >>  10548000
<<   multi-reel files.                                              >>  10550000
<<******************************************************************>>  10552000
 INTEGER SUBROUTINE READTAPE(WORDC);                           <<02546>>10554000
   VALUE WORDC;                                                         10556000
   INTEGER WORDC;                                                       10558000
      <<----------------------------------------------------->>         10560000
      <<    Returns:  0 - normal                             >>         10562000
      <<              1 - EOF (Normal from FSF)              >>         10564000
      <<              2 - I/O error                          >>         10566000
      <<              3 - Operator can't find right tape     >>         10568000
      <<              4 - Internal system error              >>         10570000
      <<----------------------------------------------------->>         10572000
   BEGIN                                                                10574000
   IF ENDFLAG THEN                                                      10576000
      BEGIN       << Should not occur. >>                               10578000
RET4: READTAPE := 4;      << Internal system error. >>                  10580000
      IF USING'ATTIO THEN                                      <<02708>>10582000
TOACB:   BEGIN << Post error to file ACB >>                    <<02708>>10584000
         ERR := IOSTAT(STATUS); <<Convert to FS error >>       <<02708>>10586000
         POST'ACB'ERROR(TNUM,DSTAT,ERR); <<To ACB >>           <<02708>>10588000
         END;                                                  <<02708>>10590000
      RETURN;                                                           10592000
      END;                                                              10594000
   IF LABELED THEN                                                      10596000
      BEGIN                                                             10598000
      IF DATAFLAG THEN                                                  10600000
         BEGIN          << Start new file. >>                           10602000
         DATAFLAG := FALSE;                                             10604000
REOPEN:  ECODE := NEXTTAPEFILE(TNUM);                          <<02649>>10606000
         IF <> THEN                                            <<02649>>10608000
            BEGIN       << Check for end of volume set. >>              10610000
            IF ECODE=LBTEOVSET THEN GO EOVSET;                          10614000
            IF ECODE=NAVAILDEV THEN GO RET3;                            10616000
            GO RET2;    << Some other error. >>                         10618000
            END;                                                        10620000
         IF LRELSW(TNUM) THEN GO REOPEN;  << skip directory >>          10622000
         END;                                                           10624000
      IF WORDC > 0 THEN                                                 10626000
         BEGIN          << Read requested >>                            10628000
         LEN := FREAD(TNUM,TDBUF,WORDC);                                10630000
         IF = THEN RETURN;     << OK >>                                 10632000
         IF < THEN                                             <<02649>>10634000
            BEGIN              << Read error. >>               <<02649>>10636000
            FCHECK(TNUM,ECODE);                                <<02649>>10638000
            IF = AND ECODE=NAVAILDEV                           <<02649>>10640000
               THEN GO RET3    << Operator reject. >>          <<02649>>10642000
               ELSE GO RET2;   << Other kind of error. >>      <<02649>>10644000
            END;                                               <<02649>>10646000
         END;             << EOF. >>                                    10648000
      DATAFLAG := TRUE;   << FSF: new file next time. >>                10650000
      GO RET1;            << report EOF. >>                             10652000
      END;         << labeled >>                                        10654000
                                                                        10656000
<< Unlabelled tapes here. >>                                            10658000
                                                                        10660000
AGN:                                                                    10662000
   IF WORDC > 0 THEN           << FREAD requested >>                    10664000
    IF DATAFLAG THEN                                                    10666000
      BEGIN        << Return existing data. >>                          10668000
      DATAFLAG := FALSE;                                                10670000
      RETURN;                                                           10672000
      END                                                               10674000
   ELSE                                                                 10676000
      BEGIN      << Need to read next block. >>                         10678000
      IF USING'ATTIO THEN                                      <<02558>>10680000
         BEGIN                                                          10682000
         NOWAIT'READ(WORDC);                                            10684000
         READTAPE := IF STATUS.(13:3) = 1 THEN 0 ELSE 2;                10686000
         IF STATUS.(8:8) = %12 THEN GO CHECKFOREOT;                     10688000
         RETURN;                                                        10690000
         END                                                            10692000
      ELSE                                                              10694000
         BEGIN                                                          10696000
         LEN := FREAD(TNUM,TDBUF,WORDC);                                10698000
         IF > THEN GO CHECKFOREOT;           << EOF >>                  10700000
         IF < THEN                                                      10702000
RET2:       READTAPE := 2;       << Read error >>                       10704000
         IF USING'ATTIO THEN GO TOACB;                         <<02708>>10706000
         RETURN;                                                        10708000
         END;                                                           10710000
      END;                                                              10712000
   DATAFLAG := FALSE;    << FSF requested. Discard buffer, if full >>   10714000
   IF USING'ATTIO THEN                                         <<02558>>10716000
      BEGIN                                                             10718000
      B:=0;  WHILE CURBUFF<>BUFF(B) DO B:=B+1;                 <<02645>>10720000
      IF (B:=B+1)=NUMBUFF THEN B:=0;                           <<02645>>10722000
      IF IOQW(B&LSL(1))<>0 THEN WAITFOR'READ(B)                <<02645>>10724000
         ELSE STATUS:=1;                                       <<02645>>10726000
      IF STATUS.(8:8)=%12 THEN GO FOUND'EOT;                   <<02645>>10728000
      END;                                                     <<02645>>10730000
   FCONTROL(TNUM,FSF,K);                                                10732000
   IF < THEN GO RET2;      << read error >>                             10734000
   IF > THEN SUDDENDEATH(523);                                          10736000
   IF USING'ATTIO THEN                                         <<02645>>10738000
      BEGIN                                                    <<02645>>10740000
FOUND'EOT:   NOWAIT'READ(RECSIZE);                             <<02645>>10742000
             NOWAIT'READ(RECSIZE);                             <<02645>>10744000
             IF STATUS.(8:8)=%43 THEN GO CHECKFOREOT;          <<02645>>10746000
             IF STATUS.(13:3)=1  THEN GO LOOK'FOR'TRAIL;       <<02645>>10748000
             GO RET2;  << ANYTHING ELSE IS AN ERROR >>         <<02645>>10750000
      END;                                                     <<02645>>10752000
                                                               <<02562>>10754000
   << During queuing of the HP7976 tape drive, when an EOF >>  <<02562>>10756000
   << is encountered, the next read will get an error from >>  <<02562>>10758000
   << the driver (%43 - prior error abort).  RESTORE will  >>  <<02562>>10760000
   << stop queuing the reads, issue another read request   >>  <<02562>>10762000
   << and begin queuing again.                             >>  <<02562>>10764000
CHECKFOREOT:                                                            10766000
   IF USING'ATTIO THEN                                         <<02558>>10768000
      BEGIN                                                             10770000
      B:=0;   WHILE CURBUFF<>BUFF(B) DO B:=B+1;                <<02562>>10772000
      IF (B:=B+1)=NUMBUFF THEN B:=0;                           <<02562>>10774000
      CURBUFF :=  BUFF(B);                                     <<02562>>10776000
      IF IOQW(B&LSL(1)) <> 0 THEN WAITFOR'READ(B);             <<02645>>10778000
      IF STATUS.(13:3) <> 1 THEN                                        10780000
         BEGIN                                                          10782000
      <<7976 driver will return read fail after EOF>>                   10784000
         IF STATUS.(8:8) <> %43 THEN GO RET2;                  <<02558>>10786000
      << CLEAR'IO; >>                                          <<02562>>10788000
         NOWAIT'READ (RECSIZE);                                <<02562>>10790000
         NOWAIT'READ (RECSIZE);                                <<02562>>10792000
         IF STATUS.(13:3) <> 1 THEN GO RET2;                   <<02562>>10794000
         END ELSE                                              <<02562>>10796000
         BEGIN                                                 <<02562>>10798000
         IF (B:=B-1)<0 THEN B:=NUMBUFF-1;                      <<02562>>10800000
         IOQ(B):=ATTACHIO(LDEV,0,BUFF(B),0,TREAD,RECSIZE,      <<02562>>10802000
                          0,0,0);                              <<02562>>10804000
         END                                                   <<02562>>10806000
      END                                                               10808000
   ELSE BEGIN                                                           10810000
      LEN := FREAD(TNUM,TDBUF,RECSIZE);  << Try for trailer >>          10812000
      IF < THEN GO RET2;                                                10814000
      IF > THEN GO RET4;        << 2 EOF's in a row >>                  10816000
      END;                                                              10818000
LOOK'FOR'TRAIL:  IF LEN<>40 THEN                               <<02645>>10820000
      BEGIN             << Not a trailer label. >>                      10822000
      DATAFLAG := TRUE;    << Report this on next call. >>              10824000
      GO RET1;                                                          10826000
      END;                                                              10828000
   IF USING'ATTIO THEN                                         <<02558>>10830000
      BEGIN  << Copy label to stack buffer after clearing IO >><<02645>>10832000
      D:=0;  WHILE CURBUFF<>BUFF(D) DO D:=D+1;                 <<02645>>10834000
      DO BEGIN                                                 <<02645>>10836000
         WAITFOR'READ (D);                                     <<02645>>10838000
         IF (D:=D+1)=NUMBUFF THEN D:=0;                        <<02645>>10840000
         END UNTIL (BUFF(D)=CURBUFF);                          <<02645>>10842000
      TOS := @TDBUF;                                                    10844000
      TOS := BUFF(D);                                                   10846000
      TOS := 0;                                                         10848000
      TOS := 40;                                                        10850000
      ASSEMBLE (MFDS 4);                                                10852000
      END;                                                              10854000
   IF ZFIELD = 1 THEN                                                   10856000
      BEGIN                   << End of logical reel. >>                10858000
EOVSET:                                                                 10860000
      ENDFLAG := TRUE;                                                  10862000
      GO RET1;                                                          10864000
      END;                                                              10866000
                                                                        10868000
   <<  Trailer label claims there's more; switch reels. >>              10870000
                                                                        10872000
   SAVX := XFIELD;                                                      10874000
   TAPESWITCH(TNUM,TDBUF);      << get next reel >>                     10876000
   IF < THEN                                                            10878000
      BEGIN         << Can't/won't mount right tape. >>                 10880000
RET3: READTAPE := 3;                                                    10882000
      IF USING'ATTIO THEN GO TOACB;                            <<02708>>10884000
      RETURN;                                                           10886000
      END;                                                              10888000
   IF > THEN GO RET2;      << Tape error >>                             10890000
   IF USING'ATTIO THEN                                         <<02558>>10892000
      BEGIN                                                             10894000
      CURBUFF := BUFF(0);                                               10896000
      IOQW := 0;                                                        10898000
      MOVE IOQW(1) := IOQW,(NUMBUFF*2+1);                               10900000
      NOWAIT'READ(RECSIZE);                                             10902000
      END;                                                              10904000
   IF SAVX = 0 THEN GO AGN;   << File continued, this reel >>           10906000
RET1:                                                                   10908000
   READTAPE := 1;             <<  EOF return >>                         10910000
   END;     << subroutine READTAPE >>                                   10912000
<<*******************************************************************>> 10914000
<<   SUBROUTINE TO LOCATE DEVICE OF A GIVEN TYPE AND (OPT) SUBTYPE.  >> 10916000
<<   RESULT OF PROCEDURE IS A LOGICAL UNIT NUMBER.  IF NONE IS FOUND,>> 10918000
<<   THE RESULT IS ZERO.                                             >> 10920000
<<*******************************************************************>> 10922000
  INTEGER SUBROUTINE FINDDEV(TYPE,STARTVALUE,CHECKSUBTYPE,SUBTYPE);     10924000
      VALUE TYPE,STARTVALUE,CHECKSUBTYPE,SUBTYPE;                       10926000
      INTEGER TYPE,STARTVALUE,SUBTYPE;                                  10928000
      LOGICAL CHECKSUBTYPE;                                             10930000
  BEGIN                                                                 10932000
      EXCHANGEDB(LDTDSTN);       << to LDT >>                  <<02546>>10934000
      M:=LOGDEVTAB.(0:8);        << HIGHEST ENTRY NUMBER >>             10936000
      T:=LOGDEVTAB.(8:8);        << ENTRY SIZE >>                       10938000
      L:=STARTVALUE;             << STARTING VALUE (LDN) MINUS ONE >>   10940000
      WHILE (L:=L+1) <= M DO                                            10942000
         BEGIN                                                          10944000
            IT := T * L ;                                               10946000
                IF LOGDEVTAB(IT+3).(2:1)=1 THEN  <<BELONGS TO FILE SYS>>10948000
               IF LOGDEVTAB(IT+2).(10:6) = TYPE THEN                    10950000
                  IF CHECKSUBTYPE  THEN                                 10952000
                     BEGIN                                              10954000
                        IF LPDT'(L&LSL(1)+1).(12:4)=SUBTYPE             10956000
                                         THEN GOTO OKZ;                 10958000
                     END ELSE                                           10960000
                     BEGIN                                              10962000
OKZ:                    IF TYPE=0 THEN                         <<DL.PV>>10964000
                           IF LPDT1.(4:3)=4 OR                 <<DL.PV>>10966000
                           PVINFO=0 AND LPDT1.(4:1)=1 OR       <<DL.PV>>10968000
<<DON'T RETURN LDEV>>      PVINFO<>0 AND LPDT1.(4:1)=0 THEN    <<DL.PV>>10970000
<<IF IT IS NOT IN>>           <<REJECT>>                       <<DL.PV>>10972000
<<THE PROPER DOMAIN>>      ELSE                                <<DL.PV>>10974000
                              BEGIN                            <<DL.PV>>10976000
                              FINDDEV:=L;                      <<DL.PV>>10978000
                              GO EXIT;                         <<DL.PV>>10980000
                              END;                             <<DL.PV>>10982000
                        GO EXIT;                                        10984000
                     END;                                               10986000
         END << WHILE >>;                                               10988000
  EXIT:                                                                 10990000
      EXCHANGEDB(0);             << BACK TO STACK >>                    10992000
  END << FINDDEV >>;                                                    10994000
<<*******************************************************************>> 10996000
<<       SUBROUTINE TO COMPUTE FILE SIZES                            >> 10998000
<<*******************************************************************>> 11000000
  DOUBLE SUBROUTINE FILESIZE(HILIM);                                    11002000
      VALUE HILIM;                                                      11004000
      DOUBLE HILIM;                                                     11006000
  BEGIN                                                                 11008000
   IF FLFOPTIONS.(2:3) = 2 THEN         <<RIO file>>           <<04305>>11010000
         << RIO files have a very special format.            >><<04305>>11012000
         << At the end of each block is a bit map which      >><<04305>>11014000
         << tells if each record in the block is allocated.  >><<04305>>11016000
         << The blocksize in words of a RIO file is          >><<04305>>11018000
         <<  (recsize in words)*(blockfactor) + blockfactor/8>><<04305>>11020000
         << So the blockfactor of a RIO file is              >><<04305>>11022000
         <<  (16*blksize in words)/((16*recsize in words)+1) >><<04305>>11024000
      BEGIN                                                    <<04305>>11026000
         BLK'SIZE := DOUBLE(FLBLKSIZE) & DASL(4);              <<04305>>11028000
         IF FLRECSIZE = 0 THEN REC'SIZE := 128D                <<04305>>11030000
         ELSE IF FLRECSIZE<0 THEN                              <<04305>>11032000
            REC'SIZE := DOUBLE ( (-FLRECSIZE+1) & LSR(1) )     <<04305>>11034000
         ELSE REC'SIZE := DOUBLE (FLRECSIZE);                  <<04305>>11036000
         REC'SIZE := (REC'SIZE & DASL(4)) + 1D;                <<04305>>11038000
         BLK'FACT := INTEGER(BLK'SIZE / REC'SIZE);             <<04305>>11040000
         X := BLK'FACT;                                        <<04305>>11042000
      END                                                      <<04305>>11044000
   ELSE                                                        <<04305>>11046000
                                                               <<04305>>11048000
   BEGIN                                                       <<04305>>11050000
      TOS := FLBLKSIZE;                                                 11052000
      TOS := FLRECSIZE;                                                 11054000
      IF = THEN TOS:=TOS+128 ELSE                                       11056000
         IF < THEN TOS:=(-TOS+1)&LSR(1);                                11058000
      ASSEMBLE(DIV,DEL);                                                11060000
      X:=TOS;                                                           11062000
   END;                                                        <<04305>>11064000
                                                               <<04305>>11066000
      TOS := HILIM;                                                     11068000
                     << HILIM / BLOCK FACTOR >>                         11070000
      ASSEMBLE(ZERO,CAB;LDXA,LDIV;CAB,LDXA;LDIV);                       11072000
            << IF HILIM MOD BLOCKFACTOR <> 0 THEN BUMP BLK COUNT  >>    11074000
      IF TOS <> 0 THEN TOS:=TOS+1D;    << HILIM IN BLOCKS >>            11076000
      X:=(FLBLKSIZE+127)&LSR(7);       << SECTORS PER BLOCK >>          11078000
                           << BLOCKS * SECTORS PER BLOCK >>             11080000
      ASSEMBLE(LDXA,LMPY;CAB,LDXA;MPY,ZERO;DADD);                       11082000
                     << TOS CONTAINS TOTAL SECTORS >>                   11084000
      IOB:=TOS+DOUBLE(FLSECTOFF);  << TEMP SO THAT SPL WON'T GOOF >>    11086000
      FILESIZE:=IOB;     << TOTAL SECTORS, INCL FILE LABEL >>           11088000
 END << FILESIZE>>;                                                     11090000
<<*******************************************************************>> 11092000
<<   SUBROUTINE TO CALCULATE TOTAL SIZE OF A FILE AND SIZE OF EACH   >> 11094000
<<   EXTENT.                                                         >> 11096000
<<*******************************************************************>> 11098000
        DOUBLE SUBROUTINE TOTALSPACE(EXTENTSIZES);                      11100000
        DOUBLE ARRAY EXTENTSIZES;                                       11102000
        BEGIN                                                           11104000
          M := FLNUMEXTS;                                               11106000
          I := -1;                                                      11108000
          WHILE (I:=I+1)<M DO                                           11110000
            BEGIN  <<CALCULATE NORMAL SIZED EXTENTS>>                   11112000
              IF FLABDBL(I+22) = 0D THEN TOS := 0D                      11114000
              ELSE TOS := DOUBLE (LOGICAL (FLEXTSIZE));        <<C0.05>>11116000
              ASSEMBLE(DDUP);                                           11118000
              DPS5(I) := TOS;  <<EXTENTSIZES>>                          11120000
              DS5 := TOS+DS5;  <<TOTALSPACE>>                           11122000
            END;                                                        11124000
          IF FLABDBL(I+22)<>0D THEN                                     11126000
            BEGIN  <<LAST EXTENT NON-ZERO>>                             11128000
              TOS := FILESIZE(FLFLIM);                                  11130000
              TOS := FLEXTSIZE;                                         11132000
              ASSEMBLE(LDIV,DELB; TEST);                                11134000
              IF = THEN                                                 11136000
                BEGIN  <<NORMAL SIZED>>                                 11138000
                  DEL;                                                  11140000
                  TOS := FLEXTSIZE;                                     11142000
                END;                                                    11144000
              ASSEMBLE(ZERO,XCH);                                       11146000
            END                                                         11148000
          ELSE TOS := 0D;  <<ZERO LAST EXTENT>>                         11150000
          ASSEMBLE(DDUP);                                               11152000
          DPS5(I) := TOS;  <<SIZE OF LAST EXTENT>>                      11154000
          DS5 := TOS+DS5; <<TOTALSPACE>>                                11156000
        END <<TOTALSPACE>> ;                                            11158000
<<*******************************************************************>> 11160000
<<       SUBROUTINE TO RELEASE PREVIOUSLY OBTAINED DISK SPACE        >> 11162000
<<       RETURNS:            FALSE  -  OK.                           >> 11164000
<<                           TRUE   -  I/O ERROR IN DISKSPACE.       >> 11166000
<<*******************************************************************>> 11168000
  LOGICAL SUBROUTINE RELEASESPACE(EXTENTSIZES);                         11170000
   DOUBLE ARRAY EXTENTSIZES;                                            11172000
  BEGIN                                                                 11174000
      K := FLNUMEXTS + 1 ;                                              11176000
      N := -1 ;                                                         11178000
      WHILE (N:= N+1) < K  DO                                           11180000
         IF EXTENTSIZES(N) <> 0D THEN                                   11182000
            BEGIN                                                       11184000
            ENTRE:=FLABDBL(N+22);<<ADDR WITH LDEV>>                     11186000
            XLDN:=BENTRE;                                               11188000
            BENTRE:=0;                                                  11190000
            <<DELETE LDEV - LEAVE VALID DISKADDR>>                      11192000
            Return'Disc'Space (xldn, entre,                    <<03508>>11194000
                  extentsizes(n));                             <<03508>>11196000
             END;                                                       11200000
 END << RELEASESPACE >>;                                                11202000
   <<**************************************************************>>   11204000
   <<      SIMILAR TO RELEASESPACE BUT BUMP USECOUNT ALSO        >>     11206000
   <<************************************************************>>     11208000
   SUBROUTINE CLEANFILE(RELEASESPC);                                    11210000
   VALUE RELEASESPC;                                                    11212000
   LOGICAL RELEASESPC;                                                  11214000
   BEGIN                                                                11216000
          DALLOC := FALSE;  <<DEVICE IS DEALLOCATED>>                   11218000
   CASE *DISKDEALLOC(EXTSIZE,LASTEXTSIZE,                               11220000
      (IF RELEASESPC THEN FLNUMEXTS+1 ELSE -(FLNUMEXTS+1))              11222000
      , NEWEXTSIZES).(8:8) OF                                           11224000
      BEGIN                                                             11226000
         <<NULL>>;                                                      11228000
         <<NULL>>;    <<DON'T CARE>>                                    11230000
   ERR524: SUDDENDEATH(524);                                            11232000
         GOTO ERR524;                                                   11234000
         GOTO ERR524;                                                   11236000
      END;                                                              11240000
      END;   <<CLEANFILE>>                                              11242000
<<***************************************************>>        <<RV.PV>>11244000
<<        RELEASES LOCK ON VOLUME SET VIA DISMOUNT   >>        <<RV.PV>>11246000
<<***************************************************>>        <<RV.PV>>11248000
INTEGER SUBROUTINE DISMOUNTVS;                                 <<RV.PV>>11250000
    BEGIN                                                      <<RV.PV>>11252000
        REQTYPE := CONDDISMOUNT'BIND;                          <<RC.PV>>11254000
        DISMOUNT (HVSIND,PREV'FILE (4),PREV'FILE (8),          <<RC.PV>>11256000
                  REQTYPE,PVINFO);                             <<RC.PV>>11258000
        MOUNTEDVS := FALSE;                                    <<01520>>11260000
    END;<<OF DISMOUNTVS>>                                      <<RV.PV>>11262000
                                                                        11264000
<<     FRESTORE - main procedure   >>                                   11266000
                                                                        11268000
      PREV'FILE := "  ";                                       <<RC.PV>>11270000
      MOVE PREV'FILE (1) := PREV'FILE , (11);                  <<RC.PV>>11272000
      NEWLABEL(128):=%20040; <<FOR GETDEVINFO>>                         11274000
<<*******************************************************************>> 11276000
<<                VALIDATE DEVPARM IF PRESENT                        >> 11278000
<<*******************************************************************>> 11280000
      IF DEVPARM <> " "  THEN                                  <<U.RAO>>11282000
         BEGIN                << DEV PARM WAS SPECIFIED >>     <<U.RAO>>11284000
         BRET := GETDEVINFO(DEVPARM,DEVICEINFO);               <<U.RAO>>11286000
         IF BRET<>0 THEN   <<ERROR IN DEV SPECIFICATION>>      <<U.RAO>>11288000
            BEGIN   <<UNABLE TO COMPLETE COMMAND>>             <<U.RAO>>11290000
            ARET := 6;   <<INVALID DEVICE SPECIFICATION>>      <<U.RAO>>11292000
            RETVAL := 0;  <<DON'T LIST FILES>>                 <<U.RAO>>11294000
            RETURN;                                            <<U.RAO>>11296000
            END;                                               <<U.RAO>>11298000
         IF DEVICEINFO(1).(10:3) <> 0 THEN  <<NOT DISK>>       <<U.RAO>>11300000
            BEGIN                                              <<U.RAO>>11302000
            BRET := 10;                                        <<U.RAO>>11304000
            ARET := 6;                                         <<U.RAO>>11306000
            RETVAL := 0;   <<DON'T LIST FILES>>                <<U.RAO>>11308000
            RETURN                                             <<U.RAO>>11310000
            END;                                               <<U.RAO>>11312000
         END                                                   <<U.RAO>>11314000
      ELSE                                                     <<U.RAO>>11316000
         BEGIN   << NO DEV PARM WAS SPECIFIED, SET DEFAULT>>   <<U.RAO>>11318000
         MOVE DISCLASS := "DISC.";      << DEFAULT DEVICE CLASS<<U.RAO>>11320000
         TOS := GETDEVINFO(DISCLASS,DEVICEINFO);               <<U.RAO>>11322000
         IF TOS<>0 THEN DISCP := FALSE;  <<DISC DOESN'T EXIST>><<U.RAO>>11324000
         END;                                                  <<U.RAO>>11326000
<<------------------------------------------------------------------->> 11328000
                                                               <<02871>>11330000
   IF (SPEC'ENTRY:=FALSE) THEN                                 <<02871>>11332000
      BEGIN << DON'T USE ATTACHIO TO TAPE >>                   <<02871>>11334000
DBFRESTORE:    SPEC'ENTRY:=TRUE;                               <<02871>>11336000
      END;                                                     <<02871>>11338000
                                                               <<02871>>11340000
   COLDLOADID := ABSOLUTE(COLDLOADIDN);                        <<02546>>11342000
   TODAYSDATE := CALENDAR;                                     <<02546>>11344000
   FGETINFO(TNUM,,FOPTIONS,,,DEVTYPE,LDEV);                    <<02546>>11346000
   FCONTROL(CNUM,REWIND,K);                                    <<02546>>11348000
   IF <> THEN                                                  <<02546>>11350000
      BEGIN      << Error reading candidate file >>            <<02546>>11352000
CERR: ARET := 1;                                               <<02546>>11354000
      BRET := CNUM;                                            <<02546>>11356000
      RETVAL := 0;     << Don't print lists >>                 <<02546>>11358000
      RETURN;                                                  <<02546>>11360000
      END;                                                     <<02546>>11362000
   FREAD(CNUM,RECSIZE,1); << get tape buf size from C-file >>  <<02546>>11364000
   IF <> THEN GO CERR;                                         <<02546>>11366000
   IF RECSIZE=0 THEN RECSIZE := 1024;  << for old Store tapes ><<02546>>11368000
                                                               <<02558>>11370000
   << Allocate tape block buffer.  When using ATTACHIO, >>     <<02558>>11372000
   << need at most 4096 words. >>                              <<02558>>11374000
   STACK'INC := RECSIZE;                                       <<02558>>11376000
   IF (STACK'INC > 4096) AND USING'ATTIO THEN                  <<02558>>11378000
      STACK'INC := 4096;                                       <<02558>>11380000
                                                               <<02558>>11382000
   PUSH(S);                                                    <<02558>>11384000
   TOS := TOS+1;                                               <<02546>>11386000
   @TDBUF := S0;                                               <<02546>>11388000
   @BTDBUF := TOS&LSL(1);   << byte addr of buffer >>          <<02546>>11392000
   TOS := STACK'INC;                                           <<02558>>11394000
   ASSEMBLE(ADDS 0);                                           <<02546>>11396000
   BUFF := 0;   MOVE BUFF(1) := BUFF,(NUMBUFF);                <<02546>>11398000
   IOQW := 0;   MOVE IOQW(1) := IOQW,(NUMBUFF*2+1);            <<02546>>11400000
   IF USING'ATTIO THEN                                         <<02558>>11402000
      BEGIN                                                    <<02546>>11404000
      B := 0;                                                  <<02546>>11406000
      WHILE B < NUMBUFF DO                                     <<02546>>11408000
         BEGIN                                                 <<02546>>11410000
         BUFF'STAT(B):=0;                                      <<02645>>11412000
         IF (BUFF(B) := GETDATASEG(RECSIZE+10,0)) = 0          <<02546>>11414000
         THEN BEGIN << Unable to get extra Data Seg >>         <<02562>>11416000
         BADXDS: ARET := 14;   << DATA SEGMENT BUFFERR ERROR >><<02625>>11418000
                 BRET := 0;                                    <<02625>>11420000
                 C:=0;                                         <<02645>>11422000
                 WHILE C<B DO                                  <<02645>>11424000
                    BEGIN << RELEASE ACQUIRED BUFFERS >>       <<02645>>11426000
                    IF BUFF'STAT(C) =2 THEN <<XDS IS FROZEN>>  <<02645>>11428000
                       UNFREEZE (BUFF(C),1,0);                 <<02645>>11430000
                    IF BUFF'STAT(C)>=1 THEN <<XDS IS LOCKED>>  <<02645>>11432000
                       UNLOCKSEG(BUFF(C),1,0);                 <<02645>>11434000
                    RELDATASEG(BUFF(C));                       <<02645>>11436000
                    C := C + 1;                                <<02645>>11438000
                    END;                                       <<02645>>11440000
                 RETVAL := 0;                                  <<02562>>11442000
                 RETURN;                                       <<02562>>11444000
              END;                                             <<02562>>11446000
         ATTACH'BUFF := TRUE;  << HAVE XDS ALLOCATED >>        <<02691>>11448000
         LOCKSEG(BUFF(B),1,0);                                 <<02645>>11450000
         IF <> THEN GO BADXDS;                                 <<02562>>11452000
         BUFF'STAT(B):=1;   << XDS ALLOCATED AND LOCKED >>     <<02645>>11454000
         FREEZE (BUFF(B),1,0);                                 <<02645>>11456000
         IF <> THEN GO BADXDS;                                 <<02645>>11458000
         BUFF'STAT(B):=2;   << XDS LOCKED AND FROZEN >>        <<02645>>11460000
         B := B+1;                                             <<02546>>11462000
         END;                                                  <<02546>>11464000
      CURBUFF := BUFF(0);                                      <<02546>>11466000
      NOWAIT'READ(RECSIZE);                                    <<02546>>11468000
      END;                                                     <<02546>>11470000
   WHO(,CAPABILITY,,,,WHOACCT);                                <<02546>>11472000
   PUSH(DL);                                                   <<02546>>11474000
   X := TOS-PS0(-1);      << point to PXGLOB >>                <<02546>>11476000
          IF ATTRIB.(5:1) THEN                                          11478000
            BEGIN  <<SYSTEM SUP>>                                       11480000
              DB2(X).(0:1) := 1;                                        11482000
              GOTO SM;                                                  11484000
            END                                                         11486000
          ELSE IF ATTRIB.(0:1) THEN                                     11488000
            BEGIN  <<SYSTEM MANAGER>>                                   11490000
  SM:         JITDST := DB6(X).(6:10);                                  11492000
              MOVE JITACCT := WHOACCT,(8);  <<CURRENT NAME IN JIT>>     11494000
              TOS := 1;                                                 11496000
            END                                                         11498000
          ELSE TOS := 0;                                                11500000
          SMORSS := TOS;  <<SYSTEM MANAGER OR SYSTEM SUP>>              11502000
  NXTCF:                                                                11504000
          IF REQUESTSERVICE THEN       <<BREAK>>                        11506000
            BEGIN                                                       11508000
  BREAK:       ARET := 12;                                              11510000
               RETVAL := 0;            <<DON'T LISTY FILES >>           11512000
               GOTO RESETJIT;                                           11514000
            END;                                                        11516000
          FREAD(CNUM,FBUF,17);                                          11518000
          IF > THEN                                                     11520000
            BEGIN    <<EOF>>                                            11522000
              IF FLAGS.(12:1) AND DATAFLAG THEN                         11524000
                BEGIN   <<POSITION TAPE FOR NEXT CALL>>                 11526000
                  FSPACE(TNUM,-1);                                      11528000
                  IF <> THEN GOTO TERR;                                 11530000
                END;                                                    11532000
              GOTO RESETJIT;                                            11534000
            END;                                                        11536000
          IF < THEN                                                     11538000
            BEGIN                                                       11540000
              ARET := 1;                                                11542000
              BRET := CNUM;                                             11544000
              GOTO ENDITALL;                                            11546000
            END;                                                        11548000
          BOOL := FALSE;  <<STILL USING THIS ENTRY>>                    11550000
  NXTTNUMFL:                                                            11552000
         CASE *READTAPE(RECSIZE) OF BEGIN                      <<00425>>11554000
            GO GOT1;   <<NORMAL>>                                       11556000
            GO BADTAPE;   <<EOF--EVIL>>                                 11558000
            BEGIN      <<TAPE ERROR>>                                   11560000
  TERR:       ARET := 1;                                                11562000
              BRET := TNUM;                                             11564000
              GOTO ENDITALL;                                            11566000
            END;                                                        11568000
            BEGIN    <<OPERATOR COULDN'T FIND TAPE>>                    11570000
  WRONGTAPE:  ARET := 9;                                                11572000
              GOTO ENDITALL;                                            11574000
            END;                                                        11576000
            GO BADTAPE;                                                 11578000
          END <<CASE>> ;                                                11580000
  GOT1:                                                                 11582000
          IF REQUESTSERVICE THEN GOTO BREAK;                            11584000
          IF USING'ATTIO THEN                                  <<02558>>11586000
             BEGIN  << MOVE ACCOUNT INFO FROM XDS >>           <<02518>>11588000
                TOS := @BTDBUF;                                <<02518>>11590000
                TOS := TOS&LSR(1);                             <<02518>>11592000
                TOS := CURBUFF;                                <<02518>>11594000
                TOS := 0;                                      <<02518>>11596000
                TOS := 128;                                    <<02518>>11598000
                ASSEMBLE (MFDS 4);                             <<02518>>11600000
             END;                                              <<02518>>11602000
          IF (LEN MOD 128) <> 0 THEN GO BADTAPE;               <<U.RAO>>11604000
          IF BFBUF <> BTDBUF,(24) THEN                                  11606000
            BEGIN  <<DON'T WANT THIS ONE>>                              11608000
              GOTO SKIP;                                                11610000
  XFSFT:      CLEANUP(TRUE);   <<RELEASE EVERYTHING>>                   11612000
  SKIP:       CASE *READTAPE(0) OF BEGIN  <<SKIP FILE>>                 11614000
                BEGIN                                                   11616000
  BADTAPE:        ARET := 11;                                           11618000
                  GO ENDITALL;                                          11620000
                END;                                                    11622000
                IF BOOL THEN GO NXTCF ELSE GO NXTTNUMFL;                11624000
                GO TERR;                                                11626000
                GO WRONGTAPE;                                           11628000
                GO BADTAPE;                                             11630000
              END;                                                      11632000
            END;                                                        11634000
          BOOL := TRUE;   <<DONE WITH THIS CANDIATE ON ERROR>>          11636000
          DR := DIRECFIND (%30<<USER>>,0D,TDBUF(8),TDBUF(12),  <<38.PV>>11638000
                           TDBUF,R);                           <<38.PV>>11640000
          IF < THEN                                                     11642000
            BEGIN                                                       11644000
  DERR:       ARET := 4;                                                11646000
              GOTO ENDITALL;                                            11648000
            END;                                                        11650000
          IF > THEN IF DRA<>2 OR NOT (2<=DRB<=3) THEN GO DERR           11652000
          ELSE                                                          11654000
            BEGIN   <<ACCOUNT OR USER DON'T EXIST>>                     11656000
              WRITEENUM(1,DRB+1);                                       11658000
              GOTO XFSFT;                                               11660000
            END;                                                        11662000
          IF NOT (FCLLIM<=TDBUF(26)<=FCULIM) THEN GOTO BADCODE;         11664000
          IF NOT SMORSS THEN                                            11666000
            BEGIN  <<CHECK FILECODE AND LOCKWORD>>                      11668000
              IF TDBUF(26)<0 THEN  <<NEGATIVE FILECODE>>                11670000
              IF NOT FLAGS.(15:1) THEN <<IGNORE IT>>                    11672000
              IF NOT LOGICAL(CAP.(9:1)) THEN <<NO PRIV MODE>>           11674000
                BEGIN                                                   11676000
  BADCODE:        WRITEENUM(5,6);                                       11678000
                  GOTO XFSFT;                                           11680000
                END;                                                    11682000
              IF ATTRIB.(1:1)=1 AND BFBUF(16)=WHOACCT,(8) THEN GO OK;   11684000
              IF BTDBUF(32)=BFBUF(24),(8) THEN GO OK;  <<MATCH>>        11686000
              IF BFBUF(24)=" " THEN                                     11688000
                BEGIN  <<GET LOCKWORD FROM USER>>                       11690000
                TOS := 0; << for value returned by FREPLY >>   <<01190>>11692000
                  TOS := @LMESS;                                        11694000
                  ASSEMBLE(DUP,DUP);                                    11696000
                  MOVE * := "LOCKWORD: ",2;                             11698000
                  MOVE * := BFBUF,(8),2;                                11700000
  BACKF:          TOS := TOS-1;                                         11702000
                  IF BPS0=" " THEN GO BACKF;                            11704000
                  TOS := TOS+1;                                         11706000
                  BPS0 := ".";                                          11708000
                  TOS := TOS+1;                                         11710000
                  MOVE * := BFBUF(8),(8),2;                             11712000
  BACKG:          TOS := TOS-1;                                         11714000
                  IF BPS0=" " THEN GO BACKG;                            11716000
                  TOS := TOS+1;                                         11718000
                  BPS0 := ".";                                          11720000
                  TOS := TOS+1;                                         11722000
                  MOVE * := BFBUF(16),(8),2;                            11724000
  BACKA:          TOS := TOS-1;                                         11726000
                  IF BPS0=" " THEN GO BACKA;                            11728000
                  TOS := TOS+1;                                         11730000
                  BPS0 := "?";                                          11732000
                  ASSEMBLE(SUB,NEG;INCA);   <<CHARACTER COUNT>>         11734000
                  TOS := FREPLY(*,*);                                   11736000
                  IF TOS=0 THEN GOTO LOCKERR;  <<REPLY NO GOOD>>        11738000
                  MOVE BFBUF(24) := LMESS,(8);                          11740000
                  IF LMESS <> BTDBUF(32),(8) THEN GOTO LOCKERR;         11742000
                END                                                     11744000
              ELSE                                                      11746000
                BEGIN   <<LOCKWORD SUPPLIED DIDN'T MATCH>>              11748000
  LOCKERR:        WRITEENUM(3,6);                                       11750000
                  GOTO XFSFT;                                           11752000
                END;                                                    11754000
            END                                                         11756000
          ELSE IF BTDBUF(16)<>JITACCT,(8) THEN                          11758000
                BEGIN  <<PUT FILE'S ACCOUNT IN JIT>>                    11760000
                  TOS := DTDBUF(4);                                     11762000
                  TOS := DTDBUF(5);                                     11764000
                  EXCHANGEDB(JITDST);                                   11766000
                  DBDARRAY(9) := TOS;                                   11768000
                  DBDARRAY(8) := TOS;                                   11770000
                  EXCHANGEDB(0);                                        11772000
                  MOVE JITACCT := BTDBUF,(8);                           11774000
                END;                                                    11776000
OK:                                                            <<04725>>11778000
         IF BFBUF(8) <> BCURR'GRP ,(16) THEN <<GRP.ACCT CHG>>  <<01188>>11782000
         BEGIN <<POSSIBLE DIFF HVS TO CONSIDER>>               <<RV.PV>>11784000
             IF MOUNTEDVS THEN DISMOUNTVS;                     <<RV.PV>>11786000
             PVINFO := 0;                                      <<RV.PV>>11788000
             MOVE PREV'FILE := FBUF, (12);                     <<RC.PV>>11790000
             DR := DIRECFIND (%10,0D,FBUF (8),                 <<38.PV>>11792000
                              FBUF (4),DB0,R);                 <<RV.PV>>11794000
             IF <> THEN                                        <<RV.PV>>11796000
              IF < THEN GO TO DERR                             <<RV.PV>>11798000
              ELSE                                             <<RV.PV>>11800000
               IF DRA = 2 AND 1<=DRB<=2 THEN                   <<RV.PV>>11802000
               BEGIN  <<ACCOUNT OR GROUP DOESN'T EXIST>>       <<RV.PV>>11804000
                   WRITEENUM (1,DRB+1);                        <<RV.PV>>11806000
                   GO TO XFSFT;                                <<RV.PV>>11808000
               END                                             <<RV.PV>>11810000
               ELSE GO TO DERR;                                <<RV.PV>>11812000
             IF PVINFO' <> 0 THEN PVINFO := PVINFO' ELSE       <<SP.PV>>11814000
             IF NONSYSVS THEN                                  <<RV.PV>>11816000
             BEGIN                                             <<RV.PV>>11818000
                 REQTYPE := CONDMOUNT'BIND;                    <<RC.PV>>11820000
                 MOUNT (HVSIND,FBUF (4),FBUF (8),              <<RV.PV>>11822000
                        REQTYPE,-1,PVINFO);                    <<38.PV>>11824000
                 IF < THEN                                     <<RV.PV>>11826000
                 BEGIN                                         <<RV.PV>>11828000
                     WRITEENUM (14,1);                         <<RV.PV>>11830000
                     PREV'FILE (4) := -1;  <<FORCE A MISMATCH>><<RV.PV>>11832000
                     GO TO XFSFT;                              <<RV.PV>>11834000
                 END;                                          <<RV.PV>>11836000
                 MOUNTEDVS := TRUE;                            <<RV.PV>>11838000
             END;                                              <<RV.PV>>11840000
         END;                                                  <<RV.PV>>11842000
          FSIRET := GETSIR(FISIR);    <<Get file label SIR>>   <<04725>>11844000
          FSIR := TRUE;                                        <<04725>>11846000
          DSIRET := GETSIR(DIRSIR);  <<GET DIRECTORY SIR>>     <<04725>>11848000
          DSIR := TRUE;                                        <<04725>>11850000
<<*******************************************************************>> 11852000
<<  FIND OUT IF OLD COPY OF FILE EXISTS                              >> 11854000
<<*******************************************************************>> 11856000
          DR := DIRECFINDFILE (0,0D,FBUF(8),FBUF(4),           <<38.PV>>11858000
                               FBUF,R,MVTABX);                 <<38.PV>>11860000
          IF < THEN GO DERR                                             11862000
          ELSE IF > THEN IF DRA<>2 OR NOT(0<=DRB<=2) THEN      <<RV.PV>>11864000
           GO TO DERR                                          <<RV.PV>>11866000
          ELSE                                                          11868000
            BEGIN                                                       11870000
              IF DRB<>0 THEN                                   <<RV.PV>>11872000
              BEGIN <<ACCOUNT OR GROUP DOESN'T EXIST>>         <<RV.PV>>11874000
                  WRITEENUM (1,DRB+1);                         <<RV.PV>>11876000
                  GO TO XFSFT;                                 <<RV.PV>>11878000
              END;                                             <<RV.PV>>11880000
              FOUND := FALSE;   <<FILE NOT ON DISC>>                    11882000
              GOTO RESTOREIT;                                           11884000
            END;                                                        11886000
          IF CARRY THEN                                                 11888000
          BEGIN  <<DEFECTIVE FILE LABEL>>                               11890000
              IF KEEP THEN WRITEENUM (0,0)                              11892000
                      ELSE WRITEENUM (13,1);                            11894000
              GO TO XFSFT;                                              11896000
          END;                                                          11898000
          FOUND := TRUE;  <<OLD COPY EXISTS>>                           11900000
          IF KEEP THEN                                                  11902000
            BEGIN  <<KEEP OLD COPY>>                                    11904000
              WRITEENUM(0,0);                                           11906000
              GOTO XFSFT;                                               11908000
            END;                                                        11910000
          OLDLDN := LUN(OLDVTAB:=R.(0:8),MVTABX);<<LOG DEV #>> <<28.PV>>11912000
          OLDP1 := R.(8:8);                                             11914000
          OLDP2 := R(1);                                                11916000
          @FLAB := @OLDLABEL;  <<POINT TO OLD LABEL>>                   11918000
          IOB := ATTACHIO(OLDLDN,0,0,@FLAB,0,128,OLDP1,OLDP2,1);        11920000
          IF STATUS.(13:3) <> 1 THEN                                    11922000
             BEGIN    << Disk read error. >>                   <<02546>>11924000
             WRITEENUM(7,9);                                   <<02546>>11926000
             GOTO XFSFT;                                       <<02546>>11928000
             END;                                              <<02546>>11930000
          TOS:=R;                                                       11932000
          TOS:=R(1);                                                    11934000
          IF TOS<>FLEXTMAPD THEN                                        11936000
             BEGIN   <<FILE LABEL OR DIRECTORY ERROR>>                  11938000
             @FLAB:=@TDBUF;  <<POINT BACK TO NEWLABEL>>                 11940000
             WRITEENUM(13,1);                                           11942000
             GO XFSFT;                                                  11944000
             END;                                                       11946000
          IF LOGICAL(FLSECURE) THEN                                     11948000
            BEGIN  <<CHECK SECURITY>>                                   11950000
              TOS := ACCCHECK(0,BFBUF(16),R(4),BFBUF(8),RD(1),FLUSERID, 11952000
                FLSECMX);                                               11954000
              IF NOT TOS.(12:1) THEN                                    11956000
                BEGIN  <<WRITE ACCESS FAILURE>>                         11958000
                  WRITEENUM(10,8);                                      11960000
                  GO XFSFT;                                             11962000
                END;                                                    11964000
            END;                                                        11966000
          IF NOT SMORSS THEN                                            11968000
            BEGIN  <<CHECK LOCKWORD AND FILECODE>>                      11970000
              IF FLFILECODE <0 THEN                                     11972000
              IF NOT FLAGS.(15:1) THEN                                  11974000
              IF NOT LOGICAL(CAP.(9:1)) THEN                            11976000
               BEGIN                                                    11978000
                  WRITEENUM(5,5);  <<NO PRIV MODE>>                     11980000
                  GOTO XFSFT;                                           11982000
                END;                                                    11984000
              IF ATTRIB.(1:1)=0 THEN                                    11986000
                BEGIN  <<CHECK LOCKWORD>>                               11988000
                  TOS := @FLLOCKWORD&LSL(1);                            11990000
                  IF *<>BFBUF(24),(8) THEN                              11992000
                    BEGIN   <<LOCKWORD ERROR>>                          11994000
                      WRITEENUM(3,5);                                   11996000
                      GOTO XFSFT;                                       11998000
                    END;                                                12000000
                END;                                                    12002000
            END;                                                        12004000
          IF FLCLID=COLDLOADID THEN                                     12006000
          IF FLRESTORE<>0 OR FLLOADED<>0 OR FLRW<>0 THEN                12008000
            BEGIN    <<BUSY>>                                           12010000
              WRITEENUM(4,0);                                           12012000
              GOTO XFSFT;                                               12014000
            END;                                                        12016000
          OLDTOTAL := TOTALSPACE(OLDEXTSIZES);  <<COMPUTE SIZE OF FILE>>12018000
          DR := DIRECPURGEFILE (-OLDTOTAL,0,FBUF(8),FBUF(4),   <<38.PV>>12020000
                                FBUF,MVTABX);                  <<RV.PV>>12022000
          IF <> THEN GOTO DERR;                                         12024000
  RESTOREIT:                                                            12026000
          MOVE NEWLABEL := TDBUF,(128);  <<WORK ON FILELABEL>>          12028000
          @FLAB := @NEWLABEL;                                           12030000
          NEWTOTAL := TOTALSPACE(NEWEXTSIZES);  <<CALCULATE TOTAL SIZE>>12032000
          IOB := %177777777D;                                           12034000
          <<INSURE THAT THERE IS ENOUGH SPACE>>                <<38.PV>>12036000
          DR := DIRECINSERTFILE (NEWTOTAL,0,FLACCTNAME,        <<38.PV>>12038000
                       FLGRPNAME,FLLOCNAME,IOB,MVTABX);        <<38.PV>>12040000
          IF < THEN GOTO DERR;                                          12042000
          IF > THEN IF DRA=3 THEN                                       12044000
            BEGIN   <<SAVE ACCESS FAILURE>>                             12046000
              WRITEENUM(10,7);                                          12048000
  INSERTOLD:  IF FOUND THEN                                             12050000
                BEGIN  <<PUT BACK OLD COPY>>                            12052000
                  TOS := OLDP1;                                         12054000
                  TOS.(0:8) := OLDVTAB;                                 12056000
                  TOS := OLDP2;                                         12058000
                  RD := TOS;                                            12060000
                  DR := DIRECINSERT (0,0D,FLACCTNAME,FLGRPNAME,<<38.PV>>12062000
                                     FLLOCNAME,R,MVTABX);      <<38.PV>>12064000
                  IF <> THEN GOTO DERR;                                 12066000
                  TOS := DIRECADJUST (OLDTOTAL,0,FLACCTNAME,   <<38.PV>>12068000
                                      FLGRPNAME,MVTABX);       <<39.PV>>12070000
                  IF <> THEN GOTO DERR;                                 12072000
                END;                                                    12074000
              GO XFSFT;                                                 12076000
            END                                                         12078000
          ELSE IF DRA=8 THEN                                            12080000
            BEGIN  <<SPACE EXCEEDED>>                                   12082000
              WRITEENUM(9,DRB+1);                                       12084000
              GO INSERTOLD;                                             12086000
            END                                                         12088000
          ELSE GOTO DERR;                                               12090000
          DIRECSETFLAG (0,0D,FLAB (8),FLAB (4),FLAB,MVTABX);   <<38.PV>>12092000
          IF <> THEN GO TO DERR;                                        12094000
          BSENTRY := TRUE;  <<B.S. ENTRY IN DIRECTORY>>                 12096000
          IF FOUND THEN                                                 12098000
            BEGIN  <<RETURN OLD DISC SPACE>>                            12100000
              LDN := OLDLDN;                                            12104000
              @FLAB := @OLDLABEL;                                       12106000
              VTABTOLDEV (FLEXTMAP,FLEXTMAP,                   <<28.PV>>12108000
                          FLNUMEXTS+1,MVTABX);                 <<28.PV>>12110000
              IF RELEASESPACE(OLDEXTSIZES) THEN                         12112000
                BEGIN  <<I/O ERROR IN DISCSPACE>>                       12114000
                  ARET := 3;                                            12116000
                  GOTO ENDITALL;                                        12118000
                END;                                                    12120000
              @FLAB := @NEWLABEL;                                       12122000
            END;                                                        12124000
<<*******************************************************************>> 12126000
<<       LOCATE A DEVICE ON WHICH TO RESTORE THE FILE.               >> 12128000
<<  IF NO DEVICE PARM WAS SPECIFIED IN THE RESTORE COMMAND, WE TRY TO>> 12130000
<<  PUT IT IN THE SAME DEVICE CLASS AS IT WAS CREATED IN. I.E.       >> 12132000
<<  THE CLASS IN THE FILE LABEL.   IF THIS CLASS DOES NOT EXIST, IS  >> 12134000
<<  UNAVAILABLE OR DOES NOT HAVE ENOUGH SPACE WE TRY TO              >> 12136000
<<  PUT IT BACK ON A DEVICE OF THE SAME TYPE & SUBTYPE FROM WHICH IT >> 12138000
<<  WAS ORIGINALLY STORED.  IF THIS CAN'T BE DONE, TRY A DEVICE OF   >> 12140000
<<  SAME TYPE, IGNORING SUBTYPE.  IF THIS FAILS, SIMPLY TRY TO       >> 12142000
<<  RESTORE IT ON DEVICE CLASS = "DISC."                             >> 12144000
<<  IF A DEVPARM WAS SPECIFIED THE FILE LABELS ARE MODIFIED SO THAT  >> 12146000
<<  THEY WIL ALWAYS GO INTO THAT CLASS IN FUTURE.                    >> 12148000
<<*******************************************************************>> 12150000
      MOVE FLEXTMAP := NEWEXTSIZES,((FLNUMEXTS+1)&LSL(1));              12152000
      IF DEVPARM = " " THEN                                             12154000
         BEGIN                << NO DEV PARM WAS SPECIFIED >>           12156000
            IF PVINFO <> 0 THEN CLASSFLG := TRUE;              <<RV.PV>>12158000
            TOS:=0;<<RETURN FROM THE PROCEDURE>>                        12160000
            TOS:=@FLCLASS&LSL(1);                                       12162000
            TOS:=GETDEVINFO(*,XDEVINFO);                                12164000
            IF (TOS=0)    <<GOOD DEVICE CLASS IN THIS CONFIGURATION>>   12166000
            AND (XDEVINFO(1).(10:3)=0)  <<IT IS A DISC>>                12168000
               THEN BEGIN                                               12170000
               IT:=DISKALLOC(XDEVINFO,FLNUMEXTS+1,FLEXTMAPD,   <<RH.PV>>12172000
                             PVINFO).(8:8);                    <<28.PV>>12174000
               CASE*IT OF                                               12176000
                  BEGIN                                                 12178000
                  GOTO GOTDEV; <<0 - OK>>                               12180000
                  ; << 1 - No space >>                         <<03508>>12182000
                  GOTO IOERR; << 2 - I/O error >>              <<03508>>12184000
                  ; << 3 - Allocation disabled >>              <<03508>>12186000
                  ; << 4 - Dev not available   >>              <<03508>>12188000
                  SUDDENDEATH(527);                                     12190000
                  END;                                                  12192000
               END;                                                     12194000
            FLAG:=TRUE;       << FIND DEVICE SAME TYPE & SUBTYPE >>     12196000
   NOVER:   LDN:=0;                                                     12198000
   NXTDEV:  LDN:=FINDDEV(FLDEVTYPE,LDN,FLAG,FLDEVSUBTYPE);              12200000
            IF LDN<>0 THEN                                              12202000
               BEGIN          << FOUND ONE. SEE IF IT WILL FIT.>>       12204000
                  IT:=DISKALLOC(LDN,FLNUMEXTS+1,FLEXTMAPD,     <<RH.PV>>12206000
                                PVINFO).(8:8);                 <<28.PV>>12208000
                  CASE * IT OF                                          12210000
                     BEGIN                                              12212000
                        GO GOTDEV;        << 0 - OK >>                  12214000
                        GO NXTDEV;  << 1 - No space >>         <<03508>>12216000
                        BEGIN  << 2 - I/O error >>             <<03508>>12218000
  IOERR:                   ARET := 3;                          <<03508>>12220000
                           GO ENDITALL;                        <<03508>>12222000
                        END;   << 2 - I/O error >>             <<03508>>12224000
                        GO NXTDEV; << 3 - disabled >>          <<03508>>12226000
                        GO NXTDEV; << 4 - device not avail >>  <<03508>>12228000
                        SUDDENDEATH(527);                               12230000
                     END << CASE >>;                                    12232000
               END ELSE                  << NOT FOUND >>                12234000
               IF FLAG THEN                                             12236000
                  BEGIN                                                 12238000
                     FLAG:=FALSE;   << IGNORE SUBTYPE. FIND SAME TYPE>> 12240000
                     GO NOVER;      << TRY AGAIN >>                     12242000
                   END ELSE IF DISCP THEN GO TRYDEFAULT ELSE GO NOSPACE 12244000
         END ELSE                                                       12246000
            BEGIN             << DEV PARM WAS SPECIFIED >>              12248000
               TOS:=@FLCLASS & LSL(1); <<BYTE ADDR>>                    12250000
               MOVE * := DEVPARM,(8);  <<PUT DEVCLASS IN THE LABEL>>    12252000
  TRYDEFAULT:  IT:=DISKALLOC(DEVICEINFO,FLNUMEXTS+1,FLEXTMAPD, <<RH.PV>>12254000
                             PVINFO);                          <<RV.PV>>12256000
               CASE *IT.(8:8) OF   <<RESULT FROM DISKALLOC>>   <<U.RAO>>12258000
                  BEGIN                                                 12260000
                     GO GOTDEV;        <<  0 - OK >>                    12262000
                     BEGIN  <<  1 - NOT ENUF DISC SPACE >>     <<03545>>12266000
  NOSPACE:            BSENTRY := FALSE;  <<REMOVING BAD ENTRY>>         12268000
                      DR := DIRECPURGEFILE (-NEWTOTAL,0,       <<38.PV>>12270000
                       FLACCTNAME,FLGRPNAME,FLLOCNAME,MVTABX); <<38.PV>>12272000
                      IF <> THEN GOTO DERR;                             12274000
                                                               <<03508>>12276000
                      << This procedure no longer tries >>     <<03508>>12278000
                      << to restore the old file if the >>     <<03508>>12280000
                      << restore of the new failed.     >>     <<03508>>12282000
                                                               <<03508>>12284000
                      WRITEENUM(6,0);  <<NO DISC SPACE>>                12288000
                      GO XFSFT;                                         12290000
                     END;                                               12292000
                     GOTO IOERR;   << 2 - I/O ERRROR >>        <<03545>>12294000
                     GOTO NOSPACE;  << 3 - DISABLED >>         <<03545>>12296000
                     BEGIN  << 4 - DEVICE UNAVAILABLE >>       <<03545>>12298000
                        ARET := 10;                            <<03545>>12300000
                        BRET := IT.(0:8);   << LDEV >>         <<03545>>12302000
                     END;   << 4 - DEVICE UNAVAILABLE >>       <<03545>>12304000
                     SUDDENDEATH(527);                                  12306000
                  END << CASE >>;                                       12308000
            END;                                                        12310000
<<*******************************************************************>> 12312000
<<    FOUND DEVICE.  NOW COPY THE FILE ONTO DISK.                    >> 12314000
<<*******************************************************************>> 12316000
 GOTDEV:                                                                12318000
          DALLOC := TRUE;   <<DEVICE NO ALLOCATED>>                     12320000
      LDN:=FLEXTMAP.(0:8);                                              12324000
      TOS:=@XDEVINFO;                                                   12326000
      TOS:=LDTDSTN;<<SEG #>>                                            12328000
      TOS:=LDN*LDTSIZE+2; <<OFFSET OF TYPE>>                            12330000
      TOS:=1 ; <<COUNT>>                                                12332000
      ASSEMBLE(MFDS 4); <<GET TYPE FROM LDT >>                          12334000
      <<NO SIR NEEDED - NO CHANGES>>                                    12336000
      FLDEVTYPE:=XDEVINFO.(10:6);                                       12338000
      FLDEVSUBTYPE:=LPDT'(LDN*2+1).(12:4); <<GET SUBTYPE FROM LPDT>>    12340000
          FLRESTORE:= %(2)11;  <<LOCK IT>>                              12342000
          FLRW := 0;                                                    12344000
          FLLOADED := 0;                                                12346000
          FLFCBVECT := 0;                                               12348000
         IF NOT OLDDATE THEN <<UPDATE FILE'S MODIFY & ACCESS DA<<00425>>12350000
         BEGIN                                                 <<00425>>12352000
          FLLASTACC := TODAYSDATE;                                      12354000
          FLLASTMOD := TODAYSDATE;                                      12356000
         END;                                                  <<00425>>12358000
          FLCLID := COLDLOADID;                                         12360000
      FLALLOCDATE:=CALENDAR;                                   <<00633>>12362000
      FLALLOCTIME:=CLOCK;   <<SET FILE ALLOCATE TIME>>         <<00633>>12364000
                                                               <<00633>>12366000
                                                               <<00633>>12368000
      NEWP1 := FLAB(44).(8:8);                                          12370000
      NEWP2 := FLAB(45);                                                12372000
      EXTSIZE:=LOGICAL(NEWEXTSIZES);                                    12374000
      LASTEXTSIZE:=LOGICAL(NEWEXTSIZES(FLNUMEXTS));                     12376000
   << IF TRUE THEN >>    <<catches bad FLLASTEXTSIZE>>         <<02334>>12378000
         BEGIN <<FILE FROM OLD MACHINE>>                                12380000
         TOS := FILESIZE(FLFLIM);                                       12382000
         TOS := FLEXTSIZE;                                              12384000
         ASSEMBLE(LDIV,DELB; TEST);                                     12386000
         IF = THEN                                                      12388000
           BEGIN  <<NORMAL SIZED>>                                      12390000
             DEL;                                                       12392000
             TOS := FLEXTSIZE;                                          12394000
           END;                                                         12396000
        FLLASTEXTSIZE:=TOS;                                             12398000
        END;                                                            12400000
      MOVE NEWEXTSIZES:=FLEXTMAP,((FLNUMEXTS+1)*2);                     12402000
           <<NEWEXTEXTSIZES FROM NOW ON HAS EXTMAP WITH LDEVS.>>        12404000
      LDEVTOVTAB (FLEXTMAPD,FLEXTMAPD,FLNUMEXTS+1,MVTABX<>0);  <<RV.PV>>12406000
           << SET UP FLAB >>                                            12408000
      MOVE TDBUF := FLAB,(128);   << MOVE MODIFIED FLAB BACK TO WRTBF>> 12410000
                                                                        12412000
      IOB := ATTACHIO(LDN,0,0,@FLAB,1,128,NEWP1,NEWP2,1);               12414000
      IF STATUS.(13:3) <> 1 THEN                                        12416000
        BEGIN  <<DISC WRITE ERROR>>                                     12418000
  DWERR:  UNLOCKFILE;  <<DON'T CARE IF IT FAILS AGAIN>>                 12420000
          WRITEENUM(7,8);                                               12422000
          GOTO XFSFT;                                                   12424000
        END;                                                            12426000
      TOS := NEWP1;  <<DISC ADDRESS>>                                   12428000
      TOS.(0:8) := VTABINX (LDN,MVTABX<>0);  <<VTABX>>         <<28.PV>>12430000
      R := TOS;                                                         12432000
      R(1) := NEWP2;                                                    12434000
      <<ADJUST FILE PTR IN DIRECTORY TO CORRECT VALUE>>                 12436000
      DIRECSCAN (0,0D,FLACCTNAME,FLGRPNAME,                    <<38.PV>>12438000
                 FLLOCNAME,ADJUSTFPTR,R,MVTABX);               <<39.PV>>12440000
      IF <> THEN GOTO DERR;                                             12442000
      RELSIR(DIRSIR,DSIRET);                                            12444000
      DSIR := FALSE;                                                    12446000
      RELSIR(FISIR,FSIRET);                                    <<00482>>12448000
      FSIR := FALSE;                                                    12450000
   IF FLFOPTIONS.(8:2)=1 THEN TOS := FILESIZE(FLFLIM)          <<04129>>12452000
      ELSE TOS := FILESIZE(FLEOF);                                      12454000
      SECTORS := TOS;                                                   12456000
      NBLKS := LEN&LSR(7);   << ALREADY KNOW THAT LEN MOD 128 = 0    >> 12458000
      BLOCKSWRITTEN:=0;                                                 12460000
      I:=0;                                                             12462000
      DO BEGIN     << PER EXTENT >>                                     12464000
         ENTRE:=NEWEXTSIZES(I);                                         12466000
                                                                        12468000
         TOS:=SECTORS;                                                  12470000
         TOS:=0;                                                        12472000
         TOS:=FLEXTSIZE;                                                12474000
         ASSEMBLE(DSUB);                                                12476000
         IF < THEN                                                      12478000
            BEGIN                                                       12480000
               CNT := INTEGER(SECTORS);                                 12482000
               SECTORS := 0D;                                           12484000
               DDEL;                                                    12486000
            END ELSE                                                    12488000
            BEGIN                                                       12490000
               CNT := FLEXTSIZE;                                        12492000
               SECTORS := TOS;                                          12494000
            END;                                                        12496000
         IF ENTRE=0D THEN GO NULLEXT;      << NULL EXTENT >>            12498000
         XLDN:=BENTRE;                                                  12500000
         BENTRE:=0;<<ENTRE NOW HAS VALID DISKADDR>>                     12502000
          NN := 0;                                                      12504000
          WHILE NN < CNT DO                                             12506000
            BEGIN          << SECTORS WITHIN EXTENT I >>                12508000
               IF BLOCKSWRITTEN = NBLKS THEN                            12510000
                  BEGIN                                                 12512000
                     CASE *READTAPE(RECSIZE) OF                <<00425>>12514000
                        BEGIN                                           12516000
                           GO OK4X;       << 0 - NORMAL >>              12518000
                           BEGIN                                        12520000
                              IF FLFOPTIONS.(2:3) = 2 THEN              12524000
                                 <<THIS IS FOR OLD TAPES AND>>          12526000
                                 <<RIO FILES                >>          12528000
                                 WRITEENUM (16,0)                       12530000
                              ELSE                                      12532000
                                 <<NOT ENOUGH INFO ON TAPE  >>          12534000
                                 WRITEENUM (15,0);                      12536000
                                                                        12538000
                              CLEANFILE (TRUE);                         12540000
                              CLEANUP (TRUE);                           12542000
                              GO NXTCF;                                 12544000
  RELBTAPE:                   CLEANFILE(TRUE <<RELEASE SPACE>>);        12546000
                              GO BADTAPE;                               12548000
                           END;                                         12550000
                           BEGIN    <<2-TAPE ERROR>>                    12552000
                              CLEANFILE(TRUE <<RELEASE SPACE>>);        12554000
                              IF NOSOFT THEN GO TO TERR;       <<C+.05>>12556000
                              WRITEENUM (12,6);                <<C+.05>>12558000
                              GO TO XFSFT;                     <<C+.05>>12560000
                           END;                                         12562000
                           BEGIN  <<WRONG TAPE>>                        12564000
   RELWTAPE:                  CLEANFILE(TRUE <<RELEASE SPACE>>);        12566000
                              GOTO WRONGTAPE;                           12568000
                           END;                                         12570000
                           GO RELBTAPE;                                 12572000
                        END << CASE >>;                                 12574000
   OK4X:             IF (LEN MOD 128) <> 0 THEN GO RELWTAPE;            12576000
                     NBLKS := LEN&LSR(7) ;    <<  LEN/128 >>            12578000
                     BLOCKSWRITTEN := 0;                                12580000
                  END;                                                  12582000
                  SECTORSLEFT := CNT - NN;                              12584000
                  MM := NBLKS - BLOCKSWRITTEN;                          12586000
                  IF SECTORSLEFT < MM THEN MM := SECTORSLEFT;           12588000
               TOS := 0;                                                12590000
                  TOS := NN;                                            12592000
               DISKADR := TOS + ENTRE;                                  12594000
               IF USING'ATTIO THEN                             <<02558>>12596000
               BEGIN                                           <<02518>>12598000
               IOB:=ATTACHIO(XLDN,0,CURBUFF,(BLOCKSWRITTEN &   <<02518>>12600000
                            LSL(7)),TWRITE,MM&LSL(7),P1,P2,1); <<02518>>12602000
               END                                             <<02518>>12604000
               ELSE BEGIN                                      <<02518>>12606000
               IOB := ATTACHIO(XLDN,0,0,@TDBUF(BLOCKSWRITTEN&LSL(7)),   12608000
                               1,MM&LSL(7),P1,P2,1);                    12610000
               END;                                            <<02518>>12612000
               IF STATUS.(13:3) <> 1 THEN GOTO DWERR;                   12614000
                  BLOCKSWRITTEN := BLOCKSWRITTEN+INTEGER(MM);           12616000
                  NN := NN+MM;                                          12618000
            END;                                                        12620000
NULLEXT: I:=I+1;                                                        12622000
         END UNTIL SECTORS=0D  OR  I>FLNUMEXTS;                         12624000
          IF SECTORS<>0D THEN GOTO RELBTAPE;                            12626000
                                                                        12628000
          IF UNLOCKFILE THEN GOTO DWERR;                                12630000
          BSENTRY := FALSE;  <<IT'S GOOD NOW>>                          12632000
          CLEANFILE(FALSE); <<KEEP SPACE JUST DEALLOCATE>>              12634000
          TOS := FLEXTMAPD;  <<FILE ADDRESS>>                           12636000
          FBUF(13) := TOS;                                              12638000
          TOS.(0:8) := LDN;                                             12640000
          FBUF(12) := TOS;                                              12642000
          FWRITE(GNUM,FBUF,14,0);   <<WRITE REC ON GOOD FILE>>          12644000
          IF <> THEN                                                    12646000
            BEGIN                                                       12648000
              ARET := 1;                                                12650000
              BRET := GNUM;                                             12652000
              GOTO ENDITALL;                                            12654000
            END;                                                        12656000
          GNUMREC := GNUMREC+1;                                         12658000
          GO SKIP;                                                      12660000
         DEBUG;      << dummy call >>                          <<02546>>12662000
                                                                        12664000
  ENDITALL:                                                             12666000
          CLEANUP(FALSE);   <<RELEASE SIRS, ETC.>>                      12668000
          IF MOUNTEDVS THEN DISMOUNTVS;                        <<RV.PV>>12670000
  CATE:   WRITEENUM(8,0);  <<CATASTROPHIC ERROR>>                       12672000
          FREAD(CNUM,FBUF,17);  <<READ NEXT REC>>                       12674000
          IF <> THEN                                                    12678000
  RESETJIT: BEGIN  <<SET JIT BACK TO CORRECT STATE>>                    12680000
              IF SMORSS THEN                                            12682000
                BEGIN                                                   12684000
                  IF ATTRIB.(5:1) AND NOT ATTRIB.(0:1) THEN             12686000
                    BEGIN                                               12688000
                      PUSH(DL);                                         12690000
                      X := TOS-PS0(-1).(4:12);                          12692000
                      DB2(X).(0:1) := 0;                                12694000
                    END;                                                12696000
                  TOS := DACCT;                                         12698000
                  TOS := DACCT(1);                                      12700000
                  EXCHANGEDB(JITDST);                                   12702000
                  DBDARRAY(9) := TOS;                                   12704000
                  DBDARRAY(8) := TOS;                                   12706000
                  EXCHANGEDB(0);                                        12708000
                END;                                                    12710000
              CLEANUP(FALSE);                                  <<02687>>12712000
              IF MOUNTEDVS THEN DISMOUNTVS;                    <<RV.PV>>12714000
              RETURN;                                                   12716000
            END;                                                        12718000
          GOTO CATE;                                                    12720000
      END <<FRESTORE>> ;                                                12722000
$PAGE "STARTVOLUME -- MOUNT APPROPRIATE BEGINNING VOL OF SET"  <<RV.RS>>12724000
INTEGER PROCEDURE STARTVOLUME(TNUM,HDRLBL);                    <<02546>>12726000
    VALUE   TNUM;                                              <<RV.RS>>12728000
    INTEGER TNUM;                                              <<02546>>12730000
    INTEGER ARRAY HDRLBL;                                      <<RV.RS>>12732000
    OPTION PRIVILEGED,UNCALLABLE;                              <<RV.RS>>12734000
                                                                        12736000
<< Called from IRESTORE if the first file to be restored is             12738000
on a volume preceding the one being examined.  Reports the              12740000
index of the first file which begins on the newly mounted               12742000
volume.  Returns:                                                       12744000
CCG if tape error - causes abort.                                       12746000
CCL if operator can't/won't mount a suitable tape.  >>                  12748000
                                                                        12750000
    BEGIN                                                      <<RV.RS>>12752000
        DEFINE                                                 <<RV.RS>>12754000
            PREVREEL = ITMP #;                                 <<00482>>12756000
        INTEGER ARRAY                                          <<RV.RS>>12758000
            ITMP (0:5);                                        <<RV.RS>>12760000
        BYTE ARRAY                                             <<RV.RS>>12762000
            ITMPB (*) = ITMP,                                  <<RV.RS>>12764000
            ZLBL (*) = HDRLBL;                                 <<RV.RS>>12766000
        INTEGER                                                <<RV.RS>>12768000
            LEN,                                               <<RV.RS>>12770000
            REPLY,                                             <<RV.RS>>12772000
            DUMMY;                                             <<RV.RS>>12774000
        LOGICAL LDEV;                                          <<00615>>12776000
        LOGICAL FOPTIONS;                                      <<02546>>12778000
                                                                        12782000
   PREVREEL := REELNUM-1;                                               12784000
   MOVE ITMP(1) := IIBID,(2);                                           12786000
   MOVE ITMP(3) := CHDATE,(3);                                          12788000
   FGETINFO(TNUM,,FOPTIONS,,,,LDEV);                                    12790000
   IF <> THEN GO TERR;                                                  12792000
   IF LABELED THEN                                                      12794000
      BEGIN     << Let REELSWITCH request suitable volume. >>           12796000
NXTLBL:                                                                 12798000
      REELSWITCH(LDEV,-PREVREEL);                                       12800000
      IF < THEN GO NAVAIL;    << Opr said Sorry. >>                     12802000
      LEN := 40;   << Positioned at header label by REELSWITCH. >>      12804000
      FREADLABEL(TNUM,HDRLBL,40);                                       12806000
      GO CKREAD;                                                        12808000
      END;                                                              12810000
                                                                        12812000
   FCONTROL(TNUM,REWUNLOAD,DUMMY);                                      12814000
   IF <> THEN GO TERR;                                                  12816000
   GENMSG(1,21,%11000,PREVREEL,LDEV,,,,0);  << Request prior reel >>    12818000
                                                                        12820000
<< Unlabeled STORE tape begins with 2 EOF's, if Vol 1 or                12822000
old format Vol >1, or with STORE label if new format Vol >1. >>         12824000
                                                                        12826000
NEXT:                                                                   12828000
   LEN := FREAD(TNUM,HDRLBL,50);   << try for header label >>           12830000
   IF < THEN GO TERR                                                    12832000
      ELSE IF = THEN GO CKLABEL;                                        12834000
   FCONTROL(TNUM,FSF,DUMMY);     << Found EOF; skip 2d EOF >>           12836000
   IF <> THEN GO TERR;                                                  12838000
   LEN := FREAD(TNUM,HDRLBL,50);    << Should get header. >>            12840000
CKREAD:                                                                 12842000
   IF < THEN GO TERR                                                    12844000
      ELSE IF > THEN GO WRONGTAPE;                                      12846000
CKLABEL:                                                                12848000
   IF LEN <> 40 OR ZLBL <> LABELTEXT THEN                               12850000
      BEGIN    << Wrong tape mounted. >>                                12852000
WRONGTAPE:                                                              12854000
      IF LABELED THEN GO NXTLBL;                                        12856000
      FCONTROL(TNUM,REWUNLOAD,DUMMY);                                   12858000
      IF <> THEN GO TERR;                                               12860000
      GENMSG(1,10,%10000,LDEV,,,,,0,1,@REPLY);                          12862000
      << Are previous reels available? >>                               12864000
      IF REPLY <> 0 THEN GO NEXT;     << try again. >>                  12866000
NAVAIL:                                                                 12868000
      TOS := CCL;                                                       12870000
      GO SETCC;                                                         12872000
      END;                                                              12874000
                                                                        12876000
   TOS := @IIBID & LSL(1);                                              12878000
   IF * <> ITMPB(2),(4) THEN GO TO WRONGTAPE;                           12880000
   TOS := @CHDATE & LSL(1);                                             12882000
   IF * <> ITMPB(6),(6) THEN GO TO WRONGTAPE;                           12884000
   IF REELNUM > PREVREEL THEN GO WRONGTAPE;                             12886000
                                                                        12888000
<< We have a suitable tape.  Position it to the first data              12890000
file past the directory.  >>                                            12892000
                                                                        12894000
   IF LABELED THEN                                                      12896000
      BEGIN                                                             12898000
      IF REELNUM <> 1 THEN                                              12900000
         BEGIN       << Skip over file continuation >>                  12902000
         NEXTTAPEFILE(TNUM);                                            12904000
         IF < THEN GO TERR;                                    <<02649>>12906000
         IF > THEN GO WRONGTAPE;  << Should be a directory. >> <<02649>>12908000
         END;                                                           12910000
      NEXTTAPEFILE(TNUM);                                               12912000
      IF < THEN GO TERR;                                       <<02649>>12914000
      IF > THEN GO WRONGTAPE;  << Not the last reel.  Tape >>  <<02649>>12916000
                               << should have a data file. >>  <<02649>>12918000
      END                                                               12920000
   ELSE                                                                 12922000
      BEGIN      << unlabelled >>                                       12924000
      IF REELNUM = 1 THEN                                               12926000
         BEGIN    << Skip tape mark following header label. >>          12928000
         FCONTROL(TNUM,FSF,DUMMY);                                      12930000
         IF <> THEN GO TERR;                                            12932000
         END;                                                           12934000
      FCONTROL(TNUM,FSF,DUMMY);   << to end of directory >>             12936000
      IF <> THEN                                               <<02649>>12940000
         BEGIN                                                 <<02649>>12942000
TERR:    TOS := CCG;          << Death. >>                     <<02649>>12944000
         GO SETCC;                                             <<02649>>12946000
         END;                                                  <<02649>>12948000
      END;                                                     <<02649>>12950000
   TOS := CCE;                                                          12952000
   STARTVOLUME := FFILEINX+SPANTOG;                                     12954000
SETCC:                                                                  12956000
   CC := TOS;                                                           12958000
   END;     << procedure STARTVOLUME >>                                 12960000
$PAGE "TAPESWITCH  --  GET CORRECT CONTINUATION TAPE MOUNTED"           12962000
   PROCEDURE TAPESWITCH(TNUM,TDBUF);                           <<02546>>12966000
      VALUE TNUM;                                                       12968000
      INTEGER TNUM;                                                     12970000
      INTEGER ARRAY TDBUF;                                              12972000
      OPTION PRIVILEGED,UNCALLABLE;                                     12974000
                                                                        12976000
<< Called from FRESTORE and IRESTORE to request mounting                12978000
the next sequential volume.  Unlabelled tape only.  Returns:            12980000
CCG - I/O error                                                         12982000
CCL - opr can't or won't mount tape                                     12984000
CCE - All OK.  Tape positioned at directory.    >>                      12986000
                                                                        12988000
   BEGIN                                                                12990000
   DEFINE NEWREEL=ITMP#;                                                12992000
   BYTE ARRAY ZLBL(*)=TDBUF;                                            12994000
   LOGICAL FOPTIONS;                                                    12996000
   INTEGER ARRAY TRAILBL(*)=TDBUF;                                      12998000
   INTEGER ARRAY ITMP(0:3);                                             13000000
   BYTE ARRAY ITMPB(*)=ITMP;                                            13002000
   INTEGER LEN;                                                         13004000
   INTEGER REPLY;                                                       13006000
   LOGICAL LDEV;                                               <<02562>>13008000
                                                                        13010000
   NEWREEL := REELNUM+1;                                                13012000
   MOVE ITMP(1) := CHDATE,(3);                                          13014000
   FCONTROL(TNUM,REWUNLOAD,LEN);    << rewind old tape >>               13016000
   IF <> THEN GO TERR;                                                  13018000
   FGETINFO(TNUM,,FOPTIONS,,,,LDEV);                                    13020000
   IF <> THEN GO TERR;                                                  13022000
   GENMSG(1,20,%11000,NEWREEL,LDEV,,,,0);  << Request next reel >>      13024000
NEXT:                                                                   13026000
   LEN := FREAD(TNUM,TDBUF,50);   << Try for header label. >>           13028000
   IF > THEN GO WRONGTAPE;                                              13030000
   IF < THEN GO TERR;                                                   13032000
   IF LEN <> 40 OR ZLBL <> LABELTEXT THEN                               13034000
      BEGIN     << Wrong tape mounted. >>                               13036000
WRONGTAPE:                                                              13038000
      FCONTROL(TNUM,REWUNLOAD,LEN);                                     13040000
      IF <> THEN GO TERR;                                               13042000
      GENMSG(1,10,%10000,LDEV,,,,,0,1,@REPLY);                          13044000
       << Is another reel available? >>                                 13046000
      IF REPLY = 0 THEN                                                 13048000
         BEGIN         << Operator says No. >>                          13050000
         TOS := CCL;                                                    13052000
         GO SETCC;                                                      13054000
         END;                                                           13056000
      GO NEXT;                                                          13058000
      END;                                                              13060000
   TOS := @REELNUM&LSL(1);                                              13062000
   IF * <> ITMPB,(8) THEN GO WRONGTAPE;                                 13064000
   FCONTROL(TNUM,FSF,LDEV);     << position to directory >>             13066000
   IF > THEN SUDDENDEATH(523);    << can't happen >>                    13068000
   IF < THEN                                                            13070000
      BEGIN                                                             13072000
TERR: TOS := CCG;                                                       13074000
      GO SETCC;                                                         13076000
      END;                                                              13078000
   TOS := CCE;                                                          13080000
SETCC:                                                                  13082000
   CC := TOS;                                                           13084000
   END;     << procedure TAPESWITCH >>                                  13086000
$PAGE "ADJUSTFPTR --  ADJUST FILE POINTER"                              13088000
   INTEGER PROCEDURE ADJUSTFPTR(ELEMENT,LEVEL,PARMS,SIR);               13090000
      VALUE LEVEL,PARMS,SIR;                                            13092000
      INTEGER LEVEL,PARMS;                                              13094000
      INTEGER ARRAY ELEMENT;                                            13096000
      DOUBLE SIR;                                                       13098000
      OPTION PRIVILEGED,UNCALLABLE;                                     13100000
      BEGIN                                                             13102000
        INTEGER ARRAY ARQ(*)=Q+0;                                       13104000
        LOGICAL ARRAY DSEG(*)=DB+0;                                     13106000
                                                                        13108000
          PARMS := PARMS-ARQ;                                           13110000
          IF LEVEL<>0  <<FILE>> THEN SUDDENDEATH(530);                  13112000
          ELEMENT(4) := ARQ(PARMS);                                     13114000
          ELEMENT(5) := ARQ(PARMS+1);                                   13116000
          DSEG (%221).(15:1) := 1;  <<DADIRTY>>                <<38.PV>>13118000
          ADJUSTFPTR := 1;                                              13120000
      END <<ADJUSTFPTR>> ;                                              13122000
$PAGE "CXSTORENEW"                                             <<04658>>13126000
$CONTROL SEGMENT=CXSTOREST                                     <<04658>>13128000
PROCEDURE CXSTORENEW EXECUTORHEAD;                             <<04658>>13130000
   OPTION PRIVILEGED, UNCALLABLE;                              <<04658>>13132000
                                                               <<04658>>13134000
<< This procedure creates the STORE "subsystem" and passes >>  <<04658>>13136000
<< any "INFO" specified with the STORE command with the    >>  <<04658>>13138000
<< INFO parameter in the CREATEPROCESS call.               >>  <<04658>>13140000
<<                                                         >>  <<04658>>13142000
<< It builds an INFO string within a local array, and then >>  <<04658>>13144000
<< passes it to STORE.PUB.SYS.   This string consists of   >>  <<04658>>13146000
<< "STORE " and then any leftover text from the user's     >>  <<04658>>13148000
<< input (e.g: whatever followed "STORE").                 >>  <<04658>>13150000
<<                                                         >>  <<04658>>13152000
<< STORE will, if all goes well, communicate via the MAIL  >>  <<04658>>13154000
<< intrinsics.  This feature is invoked by running STORE   >>  <<04658>>13156000
<< with a non-zero PARM.                                   >>  <<04658>>13158000
<<                                                         >>  <<04658>>13160000
<< Because STORE must be callable from the COMMAND intrin- >>  <<04658>>13162000
<< sic by even a non-PH user, we must disregard normal PH  >>  <<04658>>13164000
<< restrictions.  This opens a very small "security" hole; >>  <<04658>>13166000
<< if the non-PH user has created a temporary PROG file of >>  <<04658>>13168000
<< the name: STORE.PUB.SYS, we have no way of telling the  >>  <<04658>>13170000
<< CREATEPROCESS intrinsic to NOT run it and to run the    >>  <<04658>>13172000
<< "real" one (the permanent one) instead.  Hence, in such >>  <<04658>>13174000
<< a situation, the non-PH user could conceivably be able  >>  <<04658>>13176000
<< to run processes despite lacking PH!  To plug this small>>  <<04658>>13178000
<< hole, this code will either: (1) do nothing;  or        >>  <<04658>>13180000
<< (2) issue an implicit file equate of the form:          >>  <<04658>>13182000
<< FILE STORE = STORE.PUB.SYS, OLD                         >>  <<04658>>13184000
<< and then do a CREATEPROCESS of *STORE.                  >>  <<04658>>13186000
                                                               <<04658>>13188000
   BEGIN                                                       <<04658>>13190000
                                                               <<04658>>13192000
   EQUATE                                                      <<04658>>13194000
      INFO'OVERHEAD = 10;     <<number of chars in "STORE " +>><<04658>>13196000
                                                               <<04658>>13198000
   INTEGER ARRAY                                               <<04658>>13200000
      ITEMS       (0:10),     <<CREATEPROCESS items>>          <<04658>>13202000
      ITEMCODES   (0:10),     <<   "  "     item codes>>       <<04658>>13204000
      PROGNAME    (0:8);      <<name of STORE.PUB.SYS>>        <<04658>>13206000
                                                               <<04658>>13208000
   INTEGER                                                     <<04658>>13210000
      ERROR       := 0,       <<Error from CREATEPROCESS>>     <<04658>>13212000
      I           := 0,       <<scratch integer>>              <<04658>>13214000
      PIN         := 0;       <<Pin# of STORE.PUB.SYS>>        <<04658>>13216000
                                                               <<04658>>13218000
   LOGICAL                                                     <<04658>>13220000
      LEN         := 0;       <<length of text>>               <<04658>>13222000
                                                               <<04658>>13224000
   BYTE ARRAY                                                  <<04658>>13226000
      INFO'       (0:BCOMMANDBUFLEN+INFO'OVERHEAD),            <<04658>>13228000
      PROGNAME'   (*) = PROGNAME (0);                          <<04658>>13230000
                                                               <<04658>>13232000
   BYTE POINTER                                                <<04658>>13234000
      P';                     <<pointer along INFO'>>          <<04658>>13236000
                                                               <<04658>>13238000
   DEFINE                                                      <<04658>>13240000
      FAILED      = FALSE #,                                   <<04658>>13242000
      GOOD        = TRUE #,                                    <<04658>>13244000
      NO'MSG      = -1 #,     <<flag to FAIL>>                 <<04658>>13246000
      STORE'FORMAL'NAME'  = "STOREPRG" #,                      <<04658>>13248000
      STORE'JCW'          = "STOREJCW" #,                      <<04658>>13250000
      STORE'PROGRAM'NAME' = "STORE.PUB.SYS" #,                 <<04658>>13252000
      UNKNOWN'PROG'FILE   =  (ERROR = 6)#;                     <<04658>>13254000
                                                               <<04658>>13256000
   EQUATE                                                      <<04658>>13258000
                                                               <<04658>>13260000
         <<equates for STOREJCW value...>>                     <<04658>>13262000
                                                               <<04658>>13264000
      WHY'GOOD       = 0,     <<no error found>>               <<04658>>13266000
      WHY'SYNTAX     = 1,     <<parsing syntax>>               <<04658>>13268000
      WHY'OPENING'FILES=2,    <<opening utility files>>        <<04658>>13270000
      WHY'INDIRECT   = 3,     <<opening indirect file>>        <<04658>>13272000
      WHY'OPENING'TAPE=4,     <<opening tape file>>            <<04658>>13274000
      WHY'SCANNING  = 5,    <<scanning files to STORE/RESTORE>><<04658>>13276000
      WHY'DOING      = 6;     <<doing actual STORE/RESTORE>>   <<04658>>13278000
                                                               <<04658>>13280000
   INTRINSIC                                                   <<04658>>13282000
      ACTIVATE,                                                <<04658>>13284000
      CREATEPROCESS,                                           <<04658>>13286000
      FINDJCW,                                                 <<04658>>13288000
      PUTJCW;                                                  <<04658>>13290000
                                                               <<04658>>13292000
   LABEL                                                       <<04658>>13294000
      END'CXSTORENEW;                                          <<04658>>13296000
                                                               <<04658>>13298000
                                                               <<04658>>13300000
   <<-------->>                                                <<04658>>13302000
   <<  FAIL  >>                                                <<04658>>13304000
   <<-------->>                                                <<04658>>13306000
                                                               <<04658>>13308000
   SUBROUTINE FAIL (WHY, SUB'WHY);                             <<04658>>13310000
            VALUE   WHY, SUB'WHY;                              <<04658>>13312000
            INTEGER WHY, SUB'WHY;                              <<04658>>13314000
                                                               <<04658>>13316000
         <<setup ERRNUM and PARMNUM return values, call >>     <<04658>>13318000
         <<CIERR to print the error message, return from>>     <<04658>>13320000
         <<procedure...                                 >>     <<04658>>13322000
                                                               <<04658>>13324000
      BEGIN                                                    <<04658>>13326000
                                                               <<04658>>13328000
      IF WHY <> NO'MSG THEN                                    <<04658>>13330000
         BEGIN                                                 <<04658>>13332000
         ERRNUM:=WHY;                                          <<04658>>13334000
         PARMNUM:=SUB'WHY;                                     <<04658>>13336000
         CIERR (ERRNUM);                                       <<04658>>13338000
         END;                                                  <<04658>>13340000
                                                               <<04658>>13342000
      GO END'CXSTORENEW;                                       <<04658>>13344000
                                                               <<04658>>13346000
      END <<FAIL SUB>>;                                        <<04658>>13348000
                                                               <<04658>>13350000
   <<------------------>>                                      <<04658>>13352000
   <<  INITIALIZE'JCW  >>                                      <<04658>>13354000
   <<------------------>>                                      <<04658>>13356000
                                                               <<04658>>13358000
   SUBROUTINE INITIALIZE'JCW;                                  <<04658>>13360000
                                                               <<04658>>13362000
      <<Does a PUTJCW to setup the JCW called STOREJCW.>>      <<04658>>13364000
      <<The jcw is set to the value of WHY'GOOD.       >>      <<04658>>13366000
      <<This "initialization" is done prior to starting>>      <<04658>>13368000
      <<the STORE program, so that if we are unable to >>      <<04658>>13370000
      <<add a jcw to the current session's table, we   >>      <<04658>>13372000
      <<will find out now instead of later.            >>      <<04658>>13374000
                                                               <<04658>>13376000
      BEGIN                                                    <<04658>>13378000
                                                               <<04658>>13380000
      MOVE INFO':=(STORE'JCW', " ", %15);                      <<04658>>13382000
                                                               <<04658>>13384000
      I:=WHY'GOOD;                                             <<04658>>13386000
                                                               <<04658>>13388000
      PUTJCW (INFO', I, ERROR);                                <<04658>>13390000
                                                               <<04658>>13392000
      IF ERROR <> 0 THEN                                       <<04658>>13394000
         FAIL (STORE'JCW'FAILED, ERROR);                       <<04658>>13396000
                                                               <<04658>>13398000
      END <<INITIALIZE'JCW SUB>>;                              <<04658>>13400000
                                                               <<04658>>13402000
   <<--------------------->>                                   <<04658>>13404000
   <<  ISSUE'FILE'EQUATE  >>                                   <<04658>>13406000
   <<--------------------->>                                   <<04658>>13408000
                                                               <<04658>>13410000
   SUBROUTINE ISSUE'FILE'EQUATE;                               <<04658>>13412000
                                                               <<04658>>13414000
      <<Issues a file equate of the form: >>                   <<04658>>13416000
      <<  FILE STORE=STORE.PUB.SYS,OLD    >>                   <<04658>>13418000
                                                               <<04658>>13420000
      BEGIN                                                    <<04658>>13422000
                                                               <<04658>>13424000
      MOVE INFO':=(STORE'FORMAL'NAME', "=",                    <<04658>>13426000
                   STORE'PROGRAM'NAME',                        <<04658>>13428000
                   %15);                                       <<04658>>13430000
                                                               <<04658>>13432000
      CXFILE (INFO', ERRNUM, PARMNUM);                         <<04658>>13434000
                                                               <<04658>>13436000
      IF ERRNUM <> 0 THEN                                      <<04658>>13438000
         FAIL (STORE'FAILED, ERRNUM);                          <<04658>>13440000
                                                               <<04658>>13442000
      END <<ISSUE'FILE'EQUATE SUB>>;                           <<04658>>13444000
                                                               <<04658>>13446000
   <<-------------->>                                          <<04658>>13448000
   <<  BUILD'INFO  >>                                          <<04658>>13450000
   <<-------------->>                                          <<04658>>13452000
                                                               <<04658>>13454000
   SUBROUTINE BUILD'INFO;                                      <<04658>>13456000
                                                               <<04658>>13458000
      <<This routine builds the INFO string for STORE>>        <<04658>>13460000
                                                               <<04658>>13462000
      BEGIN                                                    <<04658>>13464000
                                                               <<04658>>13466000
            <<initialize the start of INFO'...>>               <<04658>>13468000
                                                               <<04658>>13470000
      MOVE INFO':="STORE ", 2;         <<leave dest pointer>>  <<04658>>13472000
      @P':=TOS;                        <<save it in P'>>       <<04658>>13474000
                                                               <<04658>>13476000
            <<copy PARMSP text into INFO...>>                  <<04658>>13478000
                                                               <<04658>>13480000
      SCAN PARMSP UNTIL %15, 1;        <<find CR>>             <<04658>>13482000
      LEN:=TOS - LOGICAL(@PARMSP);     <<text length>>         <<04658>>13484000
      IF LEN > BCOMMANDBUFLEN THEN     <<safety precaution>>   <<04658>>13486000
         LEN:=BCOMMANDBUFLEN;        <<just truncate for now>> <<04658>>13488000
      MOVE P':=PARMSP, (LEN), 2;       <<leave new P'>>        <<04658>>13490000
      @P':=TOS;                        <<pick it up, store it>><<04658>>13492000
                                                               <<04658>>13494000
      LEN:=LOGICAL(@P')-LOGICAL(@INFO');  <<overall length>>   <<04658>>13496000
                                                               <<04658>>13498000
      END <<BUILD'INFO SUB>>;                                  <<04658>>13500000
                                                               <<04658>>13502000
   <<--------------->>                                         <<04658>>13504000
   <<  START'STORE  >>                                         <<04658>>13506000
   <<--------------->>                                         <<04658>>13508000
                                                               <<04658>>13510000
   SUBROUTINE START'STORE;                                     <<04658>>13512000
                                                               <<04658>>13514000
      <<This routine starts the STORE process, but >>          <<04658>>13516000
      <<does not ACTIVATE it...if any errors occur >>          <<04658>>13518000
      <<FAIL is called.                            >>          <<04658>>13520000
                                                               <<04658>>13522000
      BEGIN                                                    <<04658>>13524000
                                                               <<04658>>13526000
                                                               <<04658>>13528000
            <<setup CREATEPROCESS parameters...>>              <<04658>>13530000
                                                               <<04658>>13532000
      MOVE PROGNAME' := ("*", STORE'FORMAL'NAME', " ");        <<04658>>13534000
                                                               <<04658>>13536000
      MOVE ITEMCODES := (  3, <<flags              >>          <<04658>>13538000
                          11, <<INFO string address>>          <<04658>>13540000
                          12, <<INFO string length >>          <<04658>>13542000
                           2, <<PARM>>                         <<04658>>13544000
                           0  <<item terminator    >>  );      <<04658>>13546000
                                                               <<04658>>13548000
      ITEMS(0) := 1;          <<reactivate when son done>>     <<04658>>13550000
      ITEMS(1) := @INFO';     <<INFO string address>>          <<04658>>13552000
      ITEMS(2) := LEN;        <<INFO string length>>           <<04658>>13554000
      ITEMS(3) := 1;          <<PARM=1 --> STORE>>             <<04658>>13556000
      ITEMS(4) := 0;          <<item terminator>>              <<04658>>13558000
                                                               <<04658>>13560000
            <<STORE is created with a PARM of 1, which >>      <<04658>>13562000
            <<tells STORE that it was called from the  >>      <<04658>>13564000
            <<CI, and therefore should communicate its >>      <<04658>>13566000
            <<results via the JCW called STOREJCW.     >>      <<04658>>13568000
                                                               <<04658>>13570000
            <<create the process (without activating it)...>>  <<04658>>13572000
                                                               <<04658>>13574000
      CREATEPROCESS (ERROR, PIN, PROGNAME', ITEMCODES, ITEMS); <<04658>>13576000
                                                               <<04658>>13578000
      IF ERROR > 0 THEN       <<CREATEPROCESS error>>          <<04658>>13580000
         BEGIN                                                 <<04658>>13582000
         MOVE PROGNAME':=(STORE'PROGRAM'NAME', 0);             <<04658>>13584000
               <<report the error...>>                         <<04658>>13586000
         IF UNKNOWN'PROG'FILE THEN                             <<04658>>13588000
            CIERR (ERRNUM:=SUBSNOTFOUND, , 0, @PROGNAME')      <<04658>>13590000
         ELSE                                                  <<04658>>13592000
            BEGIN                                              <<04658>>13594000
            CREATEPROC'ERR (ERROR, ERRNUM);                    <<04658>>13596000
            CIERR (ERRNUM:=SUBSNOTCREATE, , 0, @PROGNAME');    <<04658>>13598000
            END;                                               <<04658>>13600000
         FAIL (NO'MSG, 0);          <<Message already sent>>   <<04658>>13602000
         END;                                                  <<04658>>13604000
                                                               <<04658>>13606000
            <<If CREATEPROCESS returned a negative >>          <<04658>>13608000
            <<value in ERROR, then the process was >>          <<04658>>13610000
            <<created ok, but a warning was sent   >>          <<04658>>13612000
            <<back, which we want to print...      >>          <<04658>>13614000
                                                               <<04658>>13616000
      IF ERROR < 0 THEN                                        <<04658>>13618000
         CREATEPROC'ERR (-ERROR, ERRNUM);                      <<04658>>13620000
                                                               <<04658>>13622000
      ERRNUM:=PARMNUM:=0;     <<cleanup>>                      <<04658>>13624000
                                                               <<04658>>13626000
      END <<START'STORE SUB>>;                                 <<04658>>13628000
                                                               <<04658>>13630000
   <<------------------>>                                      <<04658>>13632000
   <<  WAIT'FOR'STORE  >>                                      <<04658>>13634000
   <<------------------>>                                      <<04658>>13636000
                                                               <<04658>>13638000
   SUBROUTINE WAIT'FOR'STORE;                                  <<04658>>13640000
                                                               <<04658>>13642000
      <<This routine activates STORE and then waits >>         <<04658>>13644000
      <<for it to finish.  It then examines the JCW >>         <<04658>>13646000
      <<called STOREJCW, which communicates error#s >>         <<04658>>13648000
      <<back to us.  A value of 0 = no error.       >>         <<04658>>13650000
                                                               <<04658>>13652000
      BEGIN                                                    <<04658>>13654000
                                                               <<04658>>13656000
            <<STORE.PUB.SYS created ok...>>                    <<04658>>13658000
                                                               <<04658>>13660000
      ACTIVATE (PIN, 2);            <<wait till done>>         <<04658>>13662000
                                                               <<04658>>13664000
            <<see what was put in the STOREJCW jcw...>>        <<04658>>13666000
                                                               <<04658>>13668000
      MOVE INFO':=(STORE'JCW', " ", %15);                      <<04658>>13670000
                                                               <<04658>>13672000
      FINDJCW (INFO', I, ERROR);                               <<04658>>13674000
                                                               <<04658>>13676000
            <<note: I has value, ERROR has FINDJCW error>>     <<04658>>13678000
                                                               <<04658>>13680000
      IF ERROR = 0 THEN       <<found the JCW!>>               <<04658>>13682000
         IF I <> 0 THEN       <<did STORE return an error?>>   <<04658>>13684000
            FAIL (STORE'FAILED, I)                             <<04658>>13686000
         ELSE                                                  <<04658>>13688000
            <<no error!>>                                      <<04658>>13690000
      ELSE                                                     <<04658>>13692000
         FAIL (STORE'JCW'FAILED, ERROR);                       <<04658>>13694000
                                                               <<04658>>13696000
      END <<WAIT'FOR'STORE SUB>>;                              <<04658>>13698000
   <<--------------------------->>                             <<04658>>13700000
                                                               <<04658>>13702000
   INITIALIZE'JCW;                                             <<04658>>13704000
                                                               <<04658>>13706000
   ISSUE'FILE'EQUATE;                                          <<04658>>13708000
                                                               <<04658>>13710000
   BUILD'INFO;                                                 <<04658>>13712000
                                                               <<04658>>13714000
   START'STORE;                                                <<04658>>13716000
                                                               <<04658>>13718000
   WAIT'FOR'STORE;                                             <<04658>>13720000
                                                               <<04658>>13722000
         <<if we get here, all worked fine!>>                  <<04658>>13724000
                                                               <<04658>>13726000
   ERRNUM:=0;                                                  <<04658>>13728000
   PARMNUM:=0;                                                 <<04658>>13730000
                                                               <<04658>>13732000
END'CXSTORENEW:                                                <<04658>>13734000
                                                               <<04658>>13736000
   END <<CXSTORENEW PROC>>;                                    <<04658>>13738000
$PAGE "OUTER BLOCK"                                            <<04658>>13740000
$CONTROL SEGMENT=MAIN                                                   13742000
PROCEDURE MAIN;                                                         13746000
   BEGIN                                                                13748000
    LOGICAL ARRAY XXXX(0:40);                                  <<00482>>13752000
    BYTE ARRAY XXX(*) = XXXX;                                  <<00482>>13754000
     INTEGER I,J,L;                                                     13756000
                                                                        13758000
    PUSH(STATUS);                                                       13760000
    TOS.(2:1) := 0;     << Disable user traps >>                        13762000
    SET(STATUS);                                                        13764000
AGAIN:                                                                  13766000
    MOVE XXX:=":STORE ";                                                13768000
    PRINT (XXXX,-7,%320);                                      <<00482>>13770000
    L:=READ(XXXX,-80);                                         <<00482>>13772000
    IF<>THEN GOTO OUT;                                                  13774000
    IF L<>0 THEN BEGIN                                                  13776000
        XXX(L):=%15;                                                    13778000
      I:=J:=0;                                                 <<00437>>13780000
        CXSTORE(XXX,I,J);                                               13782000
        END;                                                            13784000
    MOVE XXX:=":RESTORE ";                                              13786000
    PRINT (XXXX,-9,%320);                                      <<00482>>13788000
    L:=READ(XXXX,-80);                                         <<00482>>13790000
    IF<>THEN GOTO OUT;                                                  13792000
    IF L<>0 THEN BEGIN                                                  13794000
       XXX(L):=%15;                                                     13796000
      I:=J:=0;                                                 <<00437>>13798000
       CXRESTORE(XXX,I,J);                                              13800000
       END;                                                             13802000
    GOTO AGAIN;                                                         13804000
    OUT: END;<<MAIN>>                                                   13806000
   MAIN;                                                                13808000
END.    <<STORE'RESTORE>> ;                                    <<02546>>13810000
