$CONTROL MAP,CODE,USLINIT,LINES=120                            <<07286>>00005000
<< FILEIO - File System Record Operations - Module 97 >>                00010000
<< HP32002C MPE source C.00.00 >>                                       00015000
$COPYRIGHT     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00020000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00025000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00030000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00035000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00040000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00045000
                                                                        00050000
$SET X0=OFF,X1=ON, X2=ON, X3=OFF                                        00055000
$SET X9=OFF <<MODULE 97 DEFINES>> ,X8=ON << Pictures >>        <<06511>>00060000
                                                                        00065000
$ TITLE "  MPE-IV FILE SYSTEM - RECORD OPERATIONS - DECLARATIONS "      00070000
$ THIRTY                                                                00075000
$ CONTROL MAIN = FILEIO                                                 00080000
BEGIN                                                                   00085000
                                                                        00090000
<<----------------------------------------------------------------------00095000
*                       3000/30 FILE SYSTEM                            *00100000
*                                                                      *00105000
*  TOGGLES:                                                            *00110000
*     X0   ENABLES CODE THAT PRINTS THE PROCEDURE NAME AND CALLS       *00115000
*          DEBUG UPON ENTRY TO MOST FILE SYSTEM INTRINSICS.            *00120000
*                                                                      *00125000
*     X1   ENABLES CODE THAT CALLS SUDDENDEATH(50) WHEN IRRECOVERABLE  *00130000
*          ERRORS ARE DETECTED.  THESE ERRORS SHOULD NEVER OCCUR AND   *00135000
*          WOULD OTHERWISE GO UNDETECTED.                              *00140000
*                                                                      *00145000
*     X2   ENABLES CODE THAT CALLS SUDDENDEATH(50) WHEN DATA FAILS     *00150000
*          CREDIBLITY CHECKS.                                          *00155000
*                                                             *  +0.04  00160000
*     X3   ENABLES CODE THAT CALLS THE MMSTAT MEASUREMENT     *  +0.04  00165000
*          FACILITY FOR EACH INTRINSIC CALLED WHEN ACCESSING  *  +0.04  00170000
*          A DISC FILE.                                       *  +0.04  00175000
*     X8   Turns on listing of pictures in INCLUDES           *((*MPEV))00180000
*                                                             *((00630))00185000
*     X9   OFF - MODULE 97 DEFINES, ON - MODULE 50            *((*MPEV))00190000
*                                                                      *00195000
---------------------------------------------------------------------->>00200000
                                                                        00205000
$PAGE                                                          <<04558>>00210000
<<**********************************************************>> <<04558>>00215000
<<                                                          >> <<04558>>00220000
<<            LOCKING CONVENTIONS USED BY MODULE 97         >> <<04558>>00225000
<<                                                          >> <<04558>>00230000
<<     The follwing locking conventions used in module 97   >> <<04558>>00235000
<< are the accepted locking conventions and should be used  >. <<04558>>00240000
<< as described below.  The order and methods in which file >> <<04558>>00245000
<< system resources are obtained are as follows.            >> <<04558>>00250000
<<                                                          >> <<04558>>00255000
<< A. FMAVT SIR - currently this SIR is never locked in     >> <<04558>>00260000
<<    module 97.                                            >> <<04558>>00265000
<<                                                          >> <<04558>>00270000
<< B. ACB - The ACB is always obtained and locked via       >> <<04558>>00275000
<<    LOC'ACB.  LOC'ACB places a copy of the ACB in a       >> <<04558>>00280000
<<    Q-relative location of your choice and automatically  >> <<04558>>00285000
<<    locks the ACB if the file owns an LACB, signifying    >> <<04558>>00290000
<<    a mulitaccess file.  If the FMAVT SIR is obtained     >> <<04558>>00295000
<<    before calling LOC'ACB (it never is at present),      >> <<04558>>00300000
<<    then the FMAVT SIR must be sent as one of LOC'ACBs    >> <<04558>>00305000
<<    parameters so that if the process must impede on the  >> <<04558>>00310000
<<    ACB, the FMAVT SIR will be released for other proc-   >> <<04558>>00315000
<<    esses to use while the process requesting the lock    >> <<04558>>00320000
<<    impedes on the ACB.                                   >> <<04558>>00325000
<<                                                          >> <<04558>>00330000
<<    UNLOC'ACB is used to copy the PACB and LACB (if it    >> <<04558>>00335000
<<    exists) back into the data segment from which it      >> <<04558>>00340000
<<    came.  It also unlocks the ACB if it was previously   >> <<04558>>00345000
<<    locked by the process.                                >> <<04558>>00350000
<<                                                          >> <<04558>>00355000
<< C. Obtain FI SIR next.                                   >> <<04558>>00360000
<<                                                          >> <<04558>>00365000
<< D. FCB is locked via LOCK'CB.  LOCK'CB locks the FCB and >> <<04558>>00370000
<<    sets up the parameters for MDS instructions so that   >> <<04558>>00375000
<<    the FCB can be easily copied into the stack and back  >> <<04558>>00380000
<<    after it is changed.  It is the calling procedure's   >> <<04558>>00385000
<<    responsibility to update the FCB after it has been    >> <<04558>>00390000
<<    changed!  See the comment in the procedure heading of >> <<04558>>00395000
<<    LOCK'CB for more information about the "quick lock    >> <<04558>>00400000
<<    mode" and/or "conditional lock mode."                 >> <<04558>>00405000
<<                                                          >> <<04558>>00410000
<<    UNLOCK'CB unlocks the control block and un-impedes    >> <<04558>>00415000
<<    the next process waiting for the control block (if    >> <<04558>>00420000
<<    there is one).  Note:  no UNLOCK'CB is needed if the  >> <<04558>>00425000
<<    "quick lock" was successful, the process only needs   >> <<04558>>00430000
<<    to PSUEDO-ENABLE itself.                              >> <<04558>>00435000
<<                                                          >> <<04558>>00440000
<< These conventions must be adhered to so that deadlocks   >> <<04558>>00445000
<< can be avoided. Also, always make sure that there exists >> <<04558>>00450000
<< a corresponding unlock for every lock .  If a process    >> <<04558>>00455000
<< locks the same control block twice there must be two     >> <<04558>>00460000
<< corresponding unlocks for that control block.            >> <<04558>>00465000
<<**********************************************************>> <<04558>>00470000
                                                               <<04558>>00475000
$PAGE                                                          <<04558>>00480000
<< Correct problem in attempted write beyond FLIM >>           <<00532>>00485000
<< Add Relative I/O features >>                                <<00630>>00490000
<< Allow tape FOPEN without write ring. >>                     <<00685>>00495000
<< Fix EOT on unbuffered labeled tapes. >>                     <<00722>>00500000
<< Partially remove System Buffer code >>                      <<00822>>00505000
<< Add Tape Label info to FFILEINFO, etc. >>                   <<00828>>00510000
<< Change for 3270. >>                                         <<00838>>00515000
<< Labeled tape record and block size override FOPEN, FEQ. >>  <<00841>>00520000
<< FGETINFO can return "$NULL". >>                             <<00899>>00525000
<< FCONTROL write EOF to read-only tape rejected. >>           <<00900>>00530000
<< Correct FSPACE to labeled tape. >>                          <<00901>>00535000
<< Put all FCB's in system shared DST's. Fix SIR bug >>        <<01084>>00540000
<< Change test on initial extent alloc to <=0 >>               <<01084>>00545000
<< Initialize DX in FCONVBLK in case of error in LABELIOSQ. >> <<01085>>00550000
<< TEMPORARY fix for FCONTROL (2) and (6).                  >> <<01083>>00555000
<< Fix FGETINFO; chg FCLOSE to write EOF on mult.vol unlbl tp>><<01086>>00560000
<< Fast file system >>                                         <<*****>>00565000
<< Fix FLOCK/FUNLOCK to return error if device not disk >>     <<01672>>00570000
<< Fix IOWAIT, labeled tape, FDEVICECONTROL >>                 <<01698>>00575000
<< Fix :EOD, carriage control >>                               <<01720>>00580000
<< Fix FPOINT beyond EOF >>                                    <<01864>>00585000
<< Fix VIEW, priv file check, :EOD >>                          <<01790>>00590000
<< Add functions to FDEVICECONTROL >>                          <<01864>>00595000
<< Fix Break mode bug in UNLOCK'CB >>                          <<01898>>00600000
<< Fix extent initialization on FPOINT-WEOF >>                  <<1910>>00605000
<< Fix extent clear on WEOF >>                                 <<01936>>00610000
<< Fix variable file overflow >>                               <<01961>>00615000
<< Fix FUNLOCK to return correct errors (SR16944)            >><<02354>>00620000
<< Fix FFILEINFO of $NULL >>                                   <<02028>>00625000
<< fix FREADBACKWARD >>                                        <<02037>>00630000
<< Fix EOF recognition on variable files >>                    <<02049>>00635000
<< New Tape Labels code >>                                     <<02545>>00640000
<< Fix WEOF into unallocated extent >>                         <<02050>>00645000
<< FCONTROL: acc=APPEND: disallow rewind, fix write EOF      >><<02353>>00650000
<< Fix NOBUF FSPACE RIO >>                                     <<02054>>00655000
<< Fix bugs in FDEVICECONTROL and FCONTROL, add remote      >> <<02556>>00660000
<<   spoofle support to FDEVICECONTROL.                     >> <<02556>>00665000
<< Fix FREADBACKWARD >>                                        <<02068>>00670000
<< New error no. 74: No room left in stk seg for another file  <<02358>>00675000
<< Fix Report Recovered Tape Error >>                          <<02071>>00680000
<< Fix FREADBACKWARD and FSETMODE >>                           <<02076>>00685000
<< Oversize terminal writes now work in prespace mode.      >> <<02310>>00690000
<< Add support of variable density tape drives.             >> <<02570>>00695000
<< Add function code 140 to FDEVICECONTROL.                 >> <<02576>>00700000
<< Delete FCONTROL calls from FDEVICECONTROL.               >> <<02578>>00705000
<< Clean up Pre-read buffers on EOF >>                         <<03656>>00710000
<< Fix to convert to new disc free space management >>         <<03503>>00715000
<< Make sure FFILEINFO/FGETINFO return proper type/subtype.  >><<04161>>00720000
<< Add FSERR 6 and 7 for LINUS, chng NAVLSTAT for reel swt  >> <<03560>>00725000
<< Add FFILEINFO item 49 - PLABEL for soft int. (replaces   >> <<03657>>00730000
<< old item 47).                                            >> <<03657>>00735000
<< Fix FFILINFO item 43 to return blanks on non spool file  >> <<04611>>00740000
<< Add FDEVCNTL %213 and %220 for 2680G support.            >> <<04140>>00745000
<< Don't get FISIR in FCONV'BLK if file is opened EXC.      >> <<04160>>00750000
<< Add CIPER Phase I support to FDEVICECONTROL.             >> <<04321>>00755000
<< Fix problem created by fix 3656.  Dirty buffers when EOF>>  <<04250>>00760000
<<   hit on buffered read were not written to disk.        >>  <<04250>>00765000
<< Fix unitialized variablbe in FALTSEC.                   >>  <<04568>>00770000
<< Fix problem of clearing extents for ASCII RIO files     >>  <<04450>>00775000
<< Download entire VFC to 2608x printers.                   >> <<04482>>00780000
<< Make FGETPVINFO return -1 if file is remote.            >>  <<04877>>00785000
<< FSPACE now uses double arithmetic on NOBUF files.        >> <<04561>>00790000
<< Fixed NOBUF READ in IOMOVE, read past EOF when block not >> <<04557>>00795000
<< on sector boundries. (Not ACB'STREAMed)                  >> <<04557>>00800000
<< Added control code 192 to FDEVICECONTROL for LYNXII >>      <<lynx>> 00805000
<< terminal controller.                                >>      <<lynx>> 00810000
                                                                        00815000
DEFINE INT = INTEGER#,                                                  00820000
       DBL = DOUBLE#,                                          <<HM.00>>00825000
       LOG = LOGICAL#,                                                  00830000
       ABS = ABSOLUTE#,                                                 00835000
       ASMB = ASSEMBLE#;                                                00840000
DEFINE MOVE'DS'1 = ASSEMBLE(MDS 1)#;                                    00845000
DEFINE MOVE'DS'2 = ASSEMBLE(MDS 2)#;                                    00850000
DEFINE MOVE'DS'3 = ASSEMBLE(MDS 3)#;                                    00855000
DEFINE MOVE'DS'4 = ASSEMBLE(MDS 4)#;                                    00860000
DEFINE MOVE'DS'5 = ASSEMBLE(MDS 5)#;                                    00865000
DEFINE MOVE'DS'6 = ASSEMBLE(MDS 6)#;                                    00870000
INTEGER DB0 = DB+0;                                                     00875000
INTEGER DB1 = DB+1;                                                     00880000
INTEGER ARRAY ADB0 (*) = DB+0;                                          00885000
INTEGER ARRAY DUM (*) = DB+0;  << dummy reference param >>              00890000
DOUBLE ARRAY DADB0 (*) = DB+0;                                          00895000
INTEGER ARRAY AQM1 (*) = Q-1;                                           00900000
INTEGER ARRAY AQM2(*) = Q-2;                                            00905000
INTEGER ARRAY AQM3(*) = Q-3;                                            00910000
INTEGER ARRAY AQM4(*) = Q-4;                                            00915000
INTEGER ARRAY AQM5(*) = Q-5;                                   <<06511>>00920000
INTEGER ARRAY AQM6(*) = Q-6;                                   <<06511>>00925000
INTEGER ARRAY AQ0 (*) = Q-0;                                            00930000
INTEGER ARRAY QARRAY(*) = Q-0;                                 <<06044>>00935000
INTEGER ARRAY AQPL0(*) = Q+0;                                           00940000
INTEGER ARRAY AQPL1(*) = Q+1;                                           00945000
INTEGER ARRAY AQPL2(*) = Q+2;                                           00950000
INTEGER ARRAY AQPL3(*) = Q+3;                                           00955000
INTEGER ARRAY AQPL4(*) = Q+4;                                           00960000
INTEGER ARRAY AQPL5(*) = Q+5;                                           00965000
INTEGER ARRAY AQPL6(*) = Q+6;                                           00970000
INTEGER ARRAY AQPL7(*) = Q+7;                                           00975000
INTEGER ARRAY AQPL8(*) = Q+8;                                           00980000
INTEGER ARRAY AQPL48(*) = Q+48;                                <<06511>>00985000
INTEGER ARRAY AQPL49(*) = Q+49;                                <<06511>>00990000
INTEGER ARRAY AQPL50(*) = Q+50;                                <<06511>>00995000
INTEGER ARRAY AQPL51(*) = Q+51;                                <<06511>>01000000
INTEGER ARRAY AQPL52(*) = Q+52;                                <<06511>>01005000
INTEGER ARRAY AQPL53(*) = Q+53;                                <<06511>>01010000
INTEGER ARRAY AQPL54(*) = Q+54;                                <<06511>>01015000
INTEGER ARRAY AQPL55(*) = Q+55;                                <<06511>>01020000
LOGICAL ARRAY LQ0(*) = Q+0;                                             01025000
DOUBLE  ARRAY DQ0(*) = Q+0;                                    <<04591>>01030000
BYTE BS0 = S-0;                                                         01035000
BYTE BS1 = S-1;                                                         01040000
BYTE BS2 = S-2;                                                         01045000
BYTE BS3 = S-3;                                                         01050000
INTEGER Q0 = Q-0;                                              <<00630>>01055000
INTEGER S0 = S-0;                                                       01060000
INTEGER S1 = S-1;                                                       01065000
INTEGER S2 = S-2;                                                       01070000
INTEGER S3 = S-3;                                                       01075000
INTEGER S4 = S-4;                                                       01080000
INTEGER S5 = S-5;                                                       01085000
INTEGER S6 = S-6;                                                       01090000
INTEGER S7 = S-7;                                                       01095000
LOGICAL LS0 = S-0;                                                      01100000
LOGICAL LS1 = S-1;                                                      01105000
LOGICAL LS2 = S-2;                                                      01110000
DOUBLE DS1 = S-1;                                                       01115000
DOUBLE DS2 = S-2;                                                       01120000
DOUBLE DS3 = S-3;                                                       01125000
DOUBLE DS4 = S-4;                                                       01130000
DOUBLE DS5 = S-5;                                                       01135000
DOUBLE DS6 = S-6;                                                       01140000
BYTE POINTER BPS0 = S-0;                                                01145000
BYTE POINTER BPS1 = S-1;                                                01150000
BYTE POINTER BPS2 = S-2;                                                01155000
BYTE POINTER BPS3 = S-3;                                       <<RV.PV>>01160000
INTEGER POINTER PS0 = S-0;                                              01165000
INTEGER POINTER PS1 = S-1;                                              01170000
INTEGER POINTER PS2 = S-2;                                              01175000
LOGICAL POINTER LPS0 = S-0;                                             01180000
LOGICAL POINTER LPS1 = S-1;                                             01185000
DOUBLE POINTER DPS0 = S-0;                                              01190000
DOUBLE POINTER DPS1 = S-1;                                              01195000
DOUBLE POINTER DPS2 = S-2;                                              01200000
DOUBLE POINTER DPS3 = S-3;                                              01205000
DOUBLE POINTER DPS4 = S-4;                                              01210000
DOUBLE POINTER DPS5 = S-5;                                              01215000
DOUBLE POINTER DPS6 = S-6;                                              01220000
DOUBLE POINTER DPS7 = S-7;                                              01225000
INTEGER ARRAY AS0 (*) = S-0;                                            01230000
INTEGER ARRAY AS1 (*) = S-1;                                            01235000
INTEGER ARRAY AS2 (*) = S-2;                                            01240000
INTEGER ARRAY AS3 (*) = S-3;                                            01245000
INTEGER ARRAY AS4 (*) = S-4;                                            01250000
INTEGER ARRAY AS5 (*) = S-5;                                   <<43.PV>>01255000
INTEGER DELTAQ =Q-0;                                                    01260000
LOGICAL STATUS =Q-1;                                                    01265000
INTEGER PREGISTER=Q-2;                                         <<03038>>01270000
INTEGER X = X;                                                          01275000
EQUATE CCE=2,CCG=0,CCL=1;                                               01280000
                                                                        01285000
DEFINE PRIVMODE = STATUS.(0:1)#,                                        01290000
       CARRYCODE = STATUS.(5:1)#,                                       01295000
       CONDCODE = STATUS.(6:2)#;                                        01300000
DEFINE ENABLE = ASSEMBLE(SED 1)#;                                       01305000
DEFINE DISABLE = ASSEMBLE(SED 0)#;                                      01310000
DEFINE PSEUDODISABLE = ASSEMBLE(PSDB)#;                                 01315000
DEFINE PSEUDOENABLE = ASSEMBLE(PSEB)#;                                  01320000
                                                               <<00822>>01325000
comment CHECKDB: If DB is at the stack, then DBBANK=SBANK.       00822  01330000
STACKDB and SBANK for the current process are obtained           00822  01335000
from the two words preceding the dispatcher marker on            00822  01340000
the interrupt control stack.  ;                                <<00822>>01345000
DEFINE CHECKDB =                                                        01350000
   DISABLE;                                                             01355000
   PUSH(DB);                                                            01360000
   X := ABSOLUTE(QI)-5;                                                 01365000
   TOS := ABSOLUTE(X);                                                  01370000
   X := X+1;                                                            01375000
   TOS := ABSOLUTE(X);                                                  01380000
   ENABLE;                                                              01385000
   ASSEMBLE(DCMP)#;                                                     01390000
DEFINE CURRENTDB = CHECKDB; TOS := IF = THEN 0 ELSE FSDSTX#;            01395000
DEFINE MPYD = ASSEMBLE(LDXA,LMPY;CAB,LDXA;MPY,ZERO;DADD)#,              01400000
       DIVD = ASSEMBLE(ZERO,CAB;LDXA,LDIV;CAB,LDXA;LDIV)#,              01405000
       DIVD'DEL = ASSEMBLE(ZERO,CAB;LDXA,LDIV;CAB,LDXA;LDIV,DEL)#;      01410000
                                                                        01415000
<<----------------------------------------------------------------------01420000
*                                                                      *01425000
*  File System Parameters                                              *01430000
*                                                                      *01435000
---------------------------------------------------------------------->>01440000
                                                                        01445000
EQUATE                                                                  01450000
                                                               <<06511>>01455000
DEFEXTSIZE  =  256,   << default extent size >>                         01460000
DEFNUMEXTS  =    8,   << default number of extents >>                   01465000
DEFBUFFERS  =    2,   << default number of buffers >>          <<00.05>>01470000
MAXBUFFERS  = 8192,   << max. words of buffer space >>                  01475000
SPOOLRSIZE  =  506,   << default spoolfile rec size >>                  01480000
SPOOLRSECT  =    4,   << #sectors/spoolfile rec >>                      01485000
FISIR       =   37,   << File Integrity SIR number >>                   01490000
DSSIR       =    8;   << Directory SIR >>                               01495000
                                                                        01500000
$INCLUDE INCLFERR                                              <<06511>>01505000
                                                                        01510000
<<----------------------------------------------------------------------01515000
*                                                                      *01520000
*  File System Monitoring definitions                                  *01525000
*                                                                      *01530000
---------------------------------------------------------------------->>01535000
                                                                        01540000
DEFINE                                                                  01545000
CURPRC'NUM    = (CURPRC/PCBSIZE)#,                             <<06958>>01550000
MYPIN'MOD     = (ABS(MONITOR).(0:12) = 0 OR                    <<06958>>01555000
                 ABS(MONITOR).(0:12) = CURPRC'NUM)#,           <<06958>>01560000
                                                                        01565000
MONOTHER      = INTEGER(ABSOLUTE(MONITOR)) <> 0 AND            <<+1.C3>>01570000
                ABS(MONITOR).(13:1) AND MYPIN'MOD#,<<OTHER>>   <<06958>>01575000
MONUNCALLABLE = INTEGER(ABSOLUTE(MONITOR)) <> 0 AND            <<+1.C3>>01580000
                ABS(MONITOR).(14:1) AND MYPIN'MOD#,            <<06958>>01585000
MONCALLABLE   = INTEGER(ABSOLUTE(MONITOR)) <>0 AND             <<+1.C3>>01590000
                ABS(MONITOR).(15:1) AND MYPIN'MOD#;            <<06958>>01595000
                                                               <<+0.04>>01600000
<<-------------------------------------------------------------  +0.04  01605000
*                                                             *  +0.04  01610000
*  MMSTAT measurement definitions                             *  +0.04  01615000
*                                                             *  +0.04  01620000
---------------------------------------------------------------  +0.04>>01625000
                                                               <<+0.04>>01630000
DEFINE MEAS'TAPE'ON =LOGICAL(ABSOLUTE(MEASMSK1))#;             <<+1.C3>>01635000
EQUATE                                                         <<+0.04>>01640000
EFOPEN          = -60,  << FOPEN/FOPENDA initial >>            <<+0.04>>01645000
EFOPEN'         = -61,  << FOPEN/FOPENDA continuation >>       <<+0.04>>01650000
EFREAD          = -62,  << FREAD >>                            <<+0.04>>01655000
EFWRITE         = -63,  << FWRITE >>                           <<+0.04>>01660000
EFREADDIR       = -64,  << FREADDIR initial >>                 <<+0.04>>01665000
EFREADDIR'      = -64,  << FREADDIR continuation >>            <<+0.04>>01670000
EFWRITEDIR      = -65,  << FWRITEDIR initial >>                <<+0.04>>01675000
EFWRITEDIR'     = -65,  << FWRITEDIR continuation >>           <<+0.04>>01680000
EFUPDATE        = -66,  << FUPDATE >>                          <<+0.04>>01685000
EIOWAIT         = -67,  << IOWAIT >>                           <<+0.04>>01690000
EFREADSEEK      = -68,  << FREADSEEK >>                        <<+0.04>>01695000
EFSPACE         = -69,  << FSPACE >>                           <<+0.04>>01700000
EFPOINT         = -70,  << FPOINT >>                           <<+0.04>>01705000
EFCONTROL       = -71,  << FCONTROL >>                         <<+0.04>>01710000
EFSETMODE       = -72,  << FSETMODE >>                         <<+0.04>>01715000
EFRELATE        = -73,  << FRELATE >>                          <<+0.04>>01720000
EFCHECK         = -74,  << FCHECK >>                           <<+0.04>>01725000
EFGETINFO       = -75,  << FGETINFO >>                         <<+0.04>>01730000
EFREADLABEL     = -76,  << FREADLABEL >>                       <<+0.04>>01735000
EFWRITELABEL    = -77,  << FWRITELABEL >>                      <<+0.04>>01740000
EFLOCK          = -78,  << FLOCK >>                            <<+0.04>>01745000
EFUNLOCK        = -79,  << FUNLOCK >>                          <<+0.04>>01750000
EFRENAME        = -80,  << FRENAME >>                          <<+0.04>>01755000
EFCLOSE         = -81,  << FCLOSE >>                           <<+0.04>>01760000
EFALTSEC        = -82;  << FALTSEC >>                          <<01175>>01765000
                                                                        01770000
<<----------------------------------------------------------------------01775000
*                                                                      *01780000
*  SYSGLOB definitions                                                 *01785000
*                                                                      *01790000
---------------------------------------------------------------------->>01795000
                                                                        01800000
EQUATE                                                                  01805000
DSTP         =   2,         << DST base >>                              01810000
QI           =   5,                                                     01815000
SYSDB        = 512,         << System DB base >>                        01820000
CLOADID      = SYSDB+%75,   << Cold Load count >>                       01825000
SHFCBDST     = SYSDB+%76,   << Shared FCB DST nr. >>                    01830000
MONITOR      = SYSDB+%77,   << monitoring flag word >>                  01835000
MAXSSECT     = SYSDB+%100,  << max # spoolfile sectors >>               01840000
NUMSSECT     = SYSDB+%102,  << current # ...........   >>               01845000
EXTSSECT     = SYSDB+%104,  << # sectors/spoolfile extent >>            01850000
SPOOLINDEX   = SYSDB+%132,  << class spool index >>                     01855000
CSIOWAIT     = SYSDB+%135,  << CSIOWAIT P-label >>                      01860000
CCLOSEPLABL  = SYSDB+%140,  << CS CCLOSE Plabel - FPROCTERM >>          01865000
MEASMSK1     = SYSDB+%267,                                     <<+1.C3>>01870000
DSCHKPLABL   = SYSDB+%335,  << DSCHECK Plabel >>               <<DS.00>>01875000
DSOPENPLABL  = SYSDB+%336,  << DSOPEN Plabel >>                <<DS.00>>01880000
DSCLOSEPLABL = SYSDB+%337,  << DSCLOSE Plabel >>               <<DS.00>>01885000
SDSLDEVLABEL = SYSDB+%323,  << Plabel for SDSLDEV >>           <<DS.04>>01890000
EXTLAB3270   = %73,         << SYSGLOBEXT index >>             <<01165>>01895000
SYSEXTPTR    = %377,        << ptr to SYSEXT of SYSGLOB >>     <<01165>>01900000
MANWCPLABL   = SYSDB+%340,  << MANAGEWRITECONV Plabel >>       <<DS.00>>01905000
AVR          = SYSDB+%346;  << Auto Vol Recognition - tape labels >>    01910000
POINTER SYSGLOBEXT = SYSEXTPTR;                                <<01165>>01915000
DEFINE                                                         <<01165>>01920000
  PLABEL3270 = SYSGLOBEXT(EXTLAB3270)#;                        <<01165>>01925000
INTEGER POINTER DST' = DSTP;                                            01930000
                                                                        01935000
<<----------------------------------------------------------------------01940000
*                                                                      *01945000
*  Job Info Table (JIT) definitions                                    *01950000
*                                                                      *01955000
---------------------------------------------------------------------->>01960000
                                                                        01965000
EQUATE                                                                  01970000
   JITUSER = 28; ! Offset to JIT user name.                    <<06960>>01975000
                                                                        01980000
<<----------------------------------------------------------------------01985000
*                                                                      *01990000
*  I/O System definitions                                              *01995000
*                                                                      *02000000
---------------------------------------------------------------------->>02005000
                                                                        02010000
EQUATE   << Device type (subtype) & subclass >>                <<02560>>02015000
MHDISK       =  0,    DIRACC     =  0,                                  02020000
FHDISK       =  1,                                                      02025000
FDISC        =  7,                                             <<01115>>02030000
CARDR        =  8,    SERIALIN   =  1,                                  02035000
PTREAD       =  9,                                                      02040000
TERMINAL     = 16,    PARALELL   =  2,                                  02045000
   NORMAL'SUBTYPE = 0,   ! Normal or MTS term subtype.         <<07234>>02050000
   MODEM'SUBTYPE  = 1,   ! Phone modem subtype.                <<07234>>02055000
READERPUNCH  = 20,                                                      02060000
SSLC         = 22,                                                      02065000
PROGCONT     = 23,                                                      02070000
MTAPE        = 24,    SERIALIO   =  3,                                  02075000
   HP7970    =  0,    << subtype.(13:3) = 0 >>                 <<02560>>02080000
   HP7976    =  1,    << subtype.(13:3) = 1 >>                 <<02560>>02085000
   HP7978    =  2,    << subtype, Buchhorn  >>                 <<07284>>02090000
   HP7974    =  3,    << subtype, Antelope  >>                 <<07284>>02095000
SDISC        = 31,                                             <<00.SD>>02100000
LPTR         = 32,    SERIALOUT  =  4,                                  02105000
CPNCH        = 33,                                                      02110000
PTPNCH       = 34,                                                      02115000
CALCOMP500   = 35,                                                      02120000
CALCOMP600   = 36,                                                      02125000
CALCOMP700   = 37,                                                      02130000
CALCOMP836   = 38,                                                      02135000
NULL         = 63;                                                      02140000
                                                               <<*7856>>02145000
DEFINE  STREAMING'DEVICE =                                     <<*7856>>02150000
           ((ACB'DTYPE = MTAPE) LAND                           <<*7856>>02155000
              ((SUBTYPE = HP7974) LOR (SUBTYPE = HP7978)))#;   <<*7856>>02160000
                                                               <<*7856>>02165000
EQUATE      << attachio functions >>                           <<*7856>>02170000
  CHECK'STATUS     = 30;  << check status of device >>         <<*7856>>02175000
                                                                        02180000
DEFINE S1STAT         = S1.(8:8)#,                             <<04321>>02185000
       GENERAL'STATUS = (13:3)#;                               <<04321>>02190000
                                                               <<04321>>02195000
EQUATE   << IOCODE VALUES >>                                            02200000
EOFSTAT     = %12,                                                      02205000
EOTSTAT     = %31,                                                      02210000
NAVLSTAT    =%204,    << device not available after reelswt >> <<03560>>02215000
NO'ERR'STAT =   1,   << Normal return from ATTACHIO.        >> <<04321>>02220000
BREAKSTAT   =%173,   << BREAK hit on terminal >>                        02225000
PARERRSTAT  = %74,   << tape parity error >>                   <<02068>>02230000
EOFCODE     =  2;                                                       02235000
                                                               <<+0.05>>02240000
DEFINE  << ATTACHIO FLAGS >>                                   <<+0.05>>02245000
UFLAGS    = %010000#,  << unblocked >>                         <<+0.05>>02250000
BFLAGS    = %010001#;  << blocked >>                           <<+0.05>>02255000
                                                                        02260000
<<----------------------------------------------------------------------02265000
*                                                                      *02270000
*  Logical Physical Device Table (LPDT) definitions                    *02275000
*                                                                      *02280000
---------------------------------------------------------------------->>02285000
                                                                        02290000
EQUATE                                                         <<07284>>02295000
  LPDTENTRY = 4;                << LPDT entry size.         >> <<07284>>02300000
                                                                        02305000
LOGICAL POINTER LPDT = 8;  << LPDT system table >>             <<02545>>02310000
DEFINE                                                         <<07284>>02315000
   LPDT'BOT     = LPDT(LDEV*LPDTENTRY + 1).(4:1)#,             <<07284>>02320000
   LPDT'SUBTYPE = LPDT(LDEV*LPDTENTRY + 1).(13:3)#,            <<07284>>02325000
   VARIABLE'DENSITY =                                          <<07284>>02330000
                  LPDT'SUBTYPE = HP7974 OR                     <<07284>>02335000
                  LPDT'SUBTYPE = HP7976 OR                     <<07284>>02340000
                  LPDT'SUBTYPE = HP7978#,                      <<07284>>02345000
   NOT'VARIABLE'DENSITY =                                      <<07284>>02350000
                 (LPDT'SUBTYPE <> HP7974) LAND                 <<07284>>02355000
                 (LPDT'SUBTYPE <> HP7976) LAND                 <<07284>>02360000
                 (LPDT'SUBTYPE <> HP7978)#;                    <<07284>>02365000
                                                                        02370000
<<----------------------------------------------------------------------02375000
*                                                                      *02380000
*  Logical Device Table (LDT) definitions                              *02385000
*                                                                      *02390000
---------------------------------------------------------------------->>02395000
                                                                        02400000
EQUATE                                                                  02405000
LDT         = %16,  << Logical Device Table DST >>                      02410000
LDTENTRY    =   7,  << entry size >>                           <<06512>>02415000
LDTSIR      = %12,  << Table sir >>                            <<02560>>02420000
DENSITYW    =   3,  << Entry offset for density info >>        <<*8323>>02425000
LDTNO       =   6;                                             <<06512>>02430000
DEFINE  CS = (8:1)#;  <<CS device >>                           <<00161>>02435000
DEFINE                                                         <<02560>>02440000
   << Density definitions for LDT entry >>                     <<02560>>02445000
   TAPE'DENSITY    = LDT'DENW.(10:3)#,<< Actual tape den. >>   <<*8384>>02450000
   REQUEST'DENSITY = LDT'DENW.(13:3)#;<< User requested den. >><<*8513>>02455000
EQUATE                                                         <<02560>>02460000
   << Possible values for density field. >>                    <<02560>>02465000
   DEN'DEFAULT = 0,                                            <<07284>>02470000
   DEN'1600    = 1,                                            <<07284>>02475000
   DEN'6250    = 2,                                            <<07284>>02480000
   DEN'800     = 3;                                            <<07284>>02485000
                                                                        02490000
$INCLUDE INCLPCB5                                              <<06511>>02495000
                                                               <<06511>>02500000
!------------------------------------------------------------- <<06511>>02505000
! Added PCB and DST definitions                                <<06511>>02510000
!------------------------------------------------------------- <<06511>>02515000
                                                               <<06511>>02520000
LOGICAL POINTER PCB = SYSPCBINDEX;                             <<06511>>02525000
                                                               <<06511>>02530000
EQUATE                                                         <<06511>>02535000
   DSTENTRY = 4,                                               <<06511>>02540000
   USER'MAIN = 2,   ! CI PCB type                              <<06511>>02545000
   PORTWAKE  = 4,   ! Port wake bit                            <<06511>>02550000
   CI'PIN    = 1,   ! Upper 2 bits of PCB type for CI=1.       <<06511>>02555000
   NON'CI'PIN= 0;   ! Upper 2 bits of PCB type for non CI.     <<06511>>02560000
$INCLUDE INCLPXG;                                              <<06510>>02565000
                                                                        02570000
<<----------------------------------------------------------------------02575000
*                                                                      *02580000
*  AOPTIONS DEFINITIONS                                                *02585000
*                                                                      *02590000
---------------------------------------------------------------------->>02595000
                                                                        02600000
DEFINE  <<AOPTION fields>>                                              02605000
AOPCOPYF        = (3:1)#,                << COPY MODE >>       <<HM.00>>02610000
AOPNOWAITF      = (4:1)#,                << No-Wait I/O mode >>         02615000
AOPMULTACF      = (5:2)#,                << Multi-access mode >>        02620000
AOPINHIBITBUFF  = (7:1)#,                << inhibit buffering >>        02625000
AOPACMODEF      = (8:2)#,                << access mode >>              02630000
AOPLOCKINGF     = (10:1)#,               << dynamic locking >>          02635000
AOPMULTIRECF    = (11:1)#,               << multi-record >>             02640000
AOPACTYPEF      = (12:4)#;               << access type >>              02645000
                                                                        02650000
DEFINE                                                                  02655000
AOPCOPY         = AOPTIONS.(3:1)#,       << FILE TO BE COPIED>><<HM.00>>02660000
AOPNOWAIT       = AOPTIONS.(4:1)#,       << No-Wait I/O mode >>         02665000
AOPMULTAC       = AOPTIONS.(5:2)#,       << multi-access mode >>        02670000
AOPGLOBALMULTAC = AOPTIONS.(5:1)#,       << INTER JOB MULTI>>  <<HM.00>>02675000
AOPINHIBITBUF   = AOPTIONS.(7:1)#,       << inhibit buffering >>        02680000
AOPACMODE       = AOPTIONS.(8:2)#,       << access mode >>              02685000
AOPDEFAULT      = (INT(AOPACMODE) = 0)#, << default >>                  02690000
AOPEXCLUSIVE    = (INT(AOPACMODE) = 1)#, << exclusive >>                02695000
AOPSEMI         = (INT(AOPACMODE) = 2)#, << semi-exclusive >>           02700000
AOPSHARE        = (INT(AOPACMODE) = 3)#, << share >>                    02705000
AOPLOCKING      = AOPTIONS.(10:1)#,      << dynamic locking >>          02710000
AOPMULTIREC     = AOPTIONS.(11:1)#,      << multi-record >>             02715000
AOPACTYPE       = AOPTIONS.(12:4)#,      << access type >>              02720000
AOPREAD         = (INT(AOPACTYPE) = 0)#, << read only >>                02725000
AOPWRITE        = (INT(AOPACTYPE) = 1)#, << write only - delete >>      02730000
AOPWRITESAVE    = (INT(AOPACTYPE) = 2)#, << write only - save >>        02735000
AOPAPPEND       = (INT(AOPACTYPE) = 3)#, << append only >>              02740000
AOPREADWRITE    = (INT(AOPACTYPE) = 4)#, << read or write >>            02745000
AOPUPDATE       = (INT(AOPACTYPE) = 5)#, << update only >>              02750000
AOPEXECUTE      = (INT(AOPACTYPE) = 6)#, << execute only >>             02755000
AOPWRITEONLY    = (1 <= INT(AOPACTYPE) <= 3)#;  << form of write >>     02760000
                                                                        02765000
<<----------------------------------------------------------------------02770000
*                                                                      *02775000
*  FOPTIONS DEFINITIONS                                                *02780000
*                                                                      *02785000
---------------------------------------------------------------------->>02790000
                                                                        02795000
DEFINE  <<FOPTIONS fields>>                                             02800000
FILETYPE      = (2:3)#,                << TYPE OF FILE >>      <<HM.00>>02805000
FOPNOEQUATEF  = (5:1)#,                << no file equation >>           02810000
FOPLABELLEDF  = (6:1)#,                << labelled tape >>              02815000
FOPCONTROLF   = (7:1)#,                << carriage control >>           02820000
FOPFORMATF    = (8:2)#,                << record format >>              02825000
FOPDESIGNATORF= (10:3)#,               << designator type >>            02830000
FOPASCIIF     = (13:1)#,               << ASCII format >>               02835000
FOPDOMAINF    = (14:2)#;               << file domain >>                02840000
                                                                        02845000
DEFINE                                                                  02850000
FOPFILETYPE   = FOPTIONS.(2:3)#,         << TYPE OF FILE >>    <<HM.00>>02855000
FOPKSAM       = (FOPFILETYPE=1)#,      << RESERVED FOR KSAM >> <<HM.00>>02860000
FOPRIO        = (FOPFILETYPE=2)#,      << RIO FILE >>          <<HM.00>>02865000
FOPCIRFILE    = (FOPFILETYPE=4)#,      << CIRCULAR FILE >>     <<HM.00>>02870000
FOPMSGFILE    = (FOPFILETYPE=6)#,      << IPC FILE >>          <<HM.00>>02875000
FOPNOEQUATE   = FOPTIONS.(5:1)#,       << no file equation >>           02880000
FOPLABELLED   = LOG(FOPTIONS.(6:1))#,                        <<TL.02>>  02885000
FOPCONTROL    = FOPTIONS.(7:1)#,       << carriage control >>           02890000
FOPFORMAT     = FOPTIONS.(8:2)#,       << record format >>              02895000
FOPVARFLD     = FOPTIONS.(9:1)#,       << variable bit >>               02900000
FOPFIXED      = (INT(FOPFORMAT) = 0)#, << fixed >>                      02905000
FOPVARIABLE   = (INT(FOPVARFLD) = 1)#, << variable >>                   02910000
FOPNORMVAR    = (INT(FOPFORMAT) = 1)#, << normal variable >>            02915000
FOPSPECVAR    = (INT(FOPFORMAT) = 3)#, << special variable >>           02920000
FOPUNDEFINED  = (INT(FOPFORMAT) = 2)#, << undefined >>                  02925000
FOPFIXEDFMT   = 0  #,                                        <<01115>>  02930000
FOPDESIGNATOR = FOPTIONS.(10:3)#,      << designator type >>            02935000
FOPACTUAL     = (INT(FOPDESIGNATOR) = 0)#,<< actual >>                  02940000
FOPSTDLIST    = (INT(FOPDESIGNATOR) = 1)#,<< $STDLIST >>                02945000
FOPNEWPASS    = (INT(FOPDESIGNATOR) = 2)#,<< $NEWPASS >>                02950000
FOPOLDPASS    = (INT(FOPDESIGNATOR) = 3)#,<< $OLDPASS >>                02955000
FOPSTDIN      = (INT(FOPDESIGNATOR) = 4)#,<< $STDIN >>                  02960000
FOPSTDINX     = (INT(FOPDESIGNATOR) = 5)#,<< $STDINX >>                 02965000
FOPNULL       = (INT(FOPDESIGNATOR) = 6)#,<< $NULL >>                   02970000
FOPASCII      = FOPTIONS.(13:1)#,      << ASCII format >>               02975000
FOPDOMAIN     = FOPTIONS.(14:2)#,      << file domain >>                02980000
FOPNEW        = (INT(FOPDOMAIN) = 0)#, << new >>                        02985000
FOPPERMANENT  = (INT(FOPDOMAIN) = 1)#, << old - permanent >>            02990000
FOPTEMPORARY  = (INT(FOPDOMAIN) = 2)#, << old - temporary >>            02995000
FOPOLD        = (INT(FOPDOMAIN) = 3)#; << old - either >>               03000000
                                                                        03005000
                                                                        03010000
<<----------------------------------------------------------------------03015000
*                                                                      *03020000
*  FOPEN State Word (STATE) definitions                                *03025000
*                                                                      *03030000
---------------------------------------------------------------------->>03035000
                                                                        03040000
DEFINE                                                                  03045000
CARRIAGEF   = (9:1)#,         << carriage control flag >>               03050000
READCODE    = (11:4)#,        << input EOF check >>                     03055000
READTYPE    = (11:2)#,        << 00 Data,01 Job,10 Sess >>              03060000
READMODE    = (13:2)#;        << see below >>                           03065000
                                                                        03070000
EQUATE                                                                  03075000
STDINRD     = 0,    << type=Job/Session >>                              03080000
STDINXRD    = 1,                                                        03085000
STDINCIRD   = 2,                                                        03090000
MAGTRD      = 0,    << type=Data >>                                     03095000
OTHERRD     = 1,                                                        03100000
COLONRD     = 2;                                                        03105000
                                                                        03110000
$INCLUDE INCLPXFL                                              <<06511>>03115000
$INCLUDE INCLACB                                               <<06511>>03120000
$INCLUDE INCLFCB                                               <<06511>>03125000
$INCLUDE INCLFLAB                                              <<06511>>03130000
<<-------------------------------------------------------------  DS.00  03135000
*                                                             *  DS.00  03140000
*   REMOTE FILE ACCESS DEFINITIONS                            *  DS.00  03145000
*                                                             *  DS.00  03150000
---------------------------------------------------------------  DS.00>>03155000
                                                               <<DS.00>>03160000
EQUATE                                                         <<DS.00>>03165000
DSDUMMYDEV     = 41, << device type of DS dummy >>             <<DS.00>>03170000
RFAMSG         = 7,  << message type >>                        <<DS.00>>03175000
RFASTREAM      = %20,<< stream type >>                         <<DS.00>>03180000
RFASUBSTR      = 0;  << substream type >>                      <<DS.00>>03185000
                                                               <<DS.00>>03190000
DEFINE                                                         <<DS.00>>03195000
ALLOCRFABUF    = PUSH(S); @RFAPTR := TOS+1#,                   <<DS.00>>03200000
CC             = (6:2)#, << Cond. code bits of status >>       <<DS.00>>03205000
CHECKXFER      = IF <> THEN                                    <<DS.00>>03210000
                 BEGIN                                         <<DS.00>>03215000
                    TOS := 0;                                  <<DS.00>>03220000
                    TOS := RFALINE;                            <<DS.00>>03225000
                    TOS := DSCHKPLABEL;                        <<DS.00>>03230000
                    ASMB(PCAL 0);                              <<DS.00>>03235000
$                   IF X1 = ON                                 <<DS.00>>03240000
                    IF <> THEN FTROUBLE(486);                  <<KJ.03>>03245000
$                   IF                                         <<DS.00>>03250000
                    TOS := CCL;                                <<DS.00>>03255000
                    GO EXIT;                                   <<DS.00>>03260000
                 END#,                                         <<DS.00>>03265000
DELAPPENDAGE   = TOS := RFALEN-1; ASSEMBLE(SUBS 0)#,           <<DS.00>>03270000
GETMWCPARMS    = TOS := 0;  TOS := RFALINE;  TOS := RFAMSG;    <<DS.00>>03275000
                 TOS := RFASTREAM;  TOS := RFASUBSTR;          <<DS.00>>03280000
                 TOS := @RFAPTR;  TOS := RFALEN#,              <<DS.00>>03285000
LOAD'ERROR    = TOS := TOS LOR LOCAL'FAILURE&LSL(8)#,          <<DS.04>>03290000
MWCNOBUF       = GETMWCPARMS;  TOS := 0D;  TOS := 0D;          <<DS.00>>03295000
                 TOS := MWCPLABEL;  ASMB(PCAL 0); DEL#,        <<DS.00>>03300000
DSCHKPLABEL    = ABS(DSCHKPLABL)#,                             <<DS.00>>03305000
DSOPENPLABEL   = ABS(DSOPENPLABL)#,                            <<DS.00>>03310000
DSCLOSEPLABEL  = ABS(DSCLOSEPLABL)#,                           <<DS.00>>03315000
MWCPLABEL      = ABS(MANWCPLABL)#,                             <<DS.00>>03320000
SDSLDEVPLABEL = ABS(SDSLDEVLABEL)#,                            <<DS.04>>03325000
PREPRETURN     = TOS := TOS.CC; ASSEMBLE(ZERO,XCH)#,           <<DS.00>>03330000
RFAMREC        = LOGICAL(AFTE)#, << RFA Multi-rec file >>      <<DS.03>>03335000
SETRFAPTR      = DSTX := EXCHANGEDB(0);                        <<DS.00>>03340000
                 ALLOCRFABUF;                                  <<DS.00>>03345000
                 DSTX := EXCHANGEDB(DSTX)#;                    <<DS.00>>03350000
DEFINE                                                         <<*7845>>03355000
   GET'REMOTE'MPE'PLABEL =                                     <<*7845>>03360000
   TOS := SYSGLOBEXT(%16);#;                                   <<*7845>>03365000
                                                               <<*7845>>03370000
DEFINE                                                         <<*8760>>03375000
   CALL'GETDS'NODENAME =                                       <<*8760>>03380000
      TOS := SYSGLOBEXT(%17);                                  <<*8760>>03385000
      ASSEMBLE(PCAL 0); #;                                     <<*8760>>03390000
                                                               <<*8760>>03395000
                                                               <<DS.00>>03400000
<<-------------------------------------------------------------  RV.PV  03405000
*                                                             *  RV.PV  03410000
*  DIRECTORY ENTRY DEFINITIONS                                *  RV.PV  03415000
*                                                             *  RV.PV  03420000
---------------------------------------------------------------  RV.PV>>03425000
                                                               <<RV.PV>>03430000
EQUATE                                                         <<RV.PV>>03435000
                                                               <<RV.PV>>03440000
   NAMESIZE        = 4,                                        <<RV.PV>>03445000
                                                               <<RV.PV>>03450000
<<Group entry>>                                                <<RV.PV>>03455000
   GNAME           = 0,                  <<name>>              <<RV.PV>>03460000
   GFIPNTR         = GNAME+NAMESIZE,     <<file index>>        <<RV.PV>>03465000
   GPASS           = GFIPNTR+1,          <<password>>          <<RV.PV>>03470000
   GDFSCOUNT       = GPASS+NAMESIZE,     <<disc file space>>   <<RV.PV>>03475000
   GDFSLIMIT       = GDFSCOUNT+2,                              <<RV.PV>>03480000
   GCPUCOUNT       = GDFSLIMIT+2,        <<CPU time>>          <<RV.PV>>03485000
   GCPULIMIT       = GCPUCOUNT+2,                              <<RV.PV>>03490000
   GCONTIMECOUNT   = GCPULIMIT+2,                              <<RV.PV>>03495000
   GCONTIMELIMIT   = GCONTIMECOUNT+2,                          <<RV.PV>>03500000
   GSEC            = GCONTIMELIMIT+2,                          <<RV.PV>>03505000
   GPURGEFLAGW     = GSEC,                                     <<RV.PV>>03510000
   GCAP            = GSEC +2,                                  <<RV.PV>>03515000
   GLINKAGE        = GCAP+1,                                   <<RV.PV>>03520000
   GVSDIPNTR       = GLINKAGE+1,         <<VS def index pntr>> <<RV.PV>>03525000
   GHVSNAME        = GVSDIPNTR+1,        <<Home VS name>>      <<RV.PV>>03530000
   GHVSANAME       = GHVSNAME,           << "   "  acct name>> <<RV.PV>>03535000
   GHVSGNAME       = GHVSANAME+NAMESIZE, << "   "  grp  name>> <<RV.PV>>03540000
   GHVSVSNAME      = GHVSGNAME+NAMESIZE, << "   "  VS   name>> <<RV.PV>>03545000
   GSAVEFIPNTR     = GHVSVSNAME+NAMESIZE,<<saves GFIPNTR>>     <<RV.PV>>03550000
   GMOUNTREFCNTR   = GSAVEFIPNTR+1,      <<mount use counter>> <<RV.PV>>03555000
   GSPARE          = GMOUNTREFCNTR+1,                          <<RV.PV>>03560000
   GSIZE           = GSPARE+1;                                 <<RV.PV>>03565000
<<GLINKAGE DEFINITIONS>>                                       <<RV.PV>>03570000
DEFINE                                                         <<RV.PV>>03575000
   PVF             = 0:1 #,                                    <<RV.PV>>03580000
   MVTABXF         = 8:8 #;                                    <<RV.PV>>03585000
EQUATE                                                         <<RV.PV>>03590000
   PV              = 1;                                        <<RV.PV>>03595000
<<----------------------------------------------------------------------03600000
*                                                                      *03605000
*  FORWARD PROCEDURE DECLARATIONS                                      *03610000
*                                                                      *03615000
---------------------------------------------------------------------->>03620000
                                                                        03625000
INTEGER PROCEDURE FCLEAR (ASCII,DADDR,SECTADDR,NUM);                    03630000
   VALUE ASCII,DADDR,SECTADDR,NUM;                                      03635000
   LOGICAL ASCII,DADDR,NUM;                                             03640000
   DOUBLE SECTADDR;                                                     03645000
   OPTION EXTERNAL;                                                     03650000
INTEGER PROCEDURE FLABIO(LDEV,SECT,FUNC,FLAB);                 <<00.06>>03655000
   VALUE   LDEV,SECT,FUNC;                                     <<00.06>>03660000
   INTEGER LDEV,FUNC;                                          <<00.06>>03665000
   DOUBLE  SECT;                                               <<00.06>>03670000
   INTEGER ARRAY FLAB;                                         <<00.06>>03675000
   OPTION  EXTERNAL;                                           <<00.06>>03680000
PROCEDURE FLABIOERR(FLAG,FN,FGA);                              <<00.06>>03685000
   VALUE   FLAG,FN,FGA;                                        <<00.06>>03690000
   LOGICAL FLAG;                                               <<00.06>>03695000
   INTEGER FN,FGA;                                             <<00.06>>03700000
   OPTION EXTERNAL,VARIABLE;                                   <<00.06>>03705000
PROCEDURE FREADLABEL(FN,TARGET,TCOUNT,LBL);                             03710000
   VALUE FN,TCOUNT,LBL;                                                 03715000
   INTEGER FN,TCOUNT,LBL;                                               03720000
   ARRAY TARGET;                                                        03725000
   OPTION FORWARD,VARIABLE;                                             03730000
PROCEDURE LDEVTOVTAB (TARGET,SOURCE,COUNT,LOCAL);              <<RV.PV>>03735000
   VALUE COUNT,LOCAL;                                          <<RV.PV>>03740000
   DOUBLE ARRAY TARGET,SOURCE;                                          03745000
   INTEGER COUNT;                                                       03750000
   LOGICAL LOCAL;                                              <<RV.PV>>03755000
   OPTION EXTERNAL;                                                     03760000
INTEGER PROCEDURE IOSTAT (STAT);                                        03765000
   VALUE STAT;                                                          03770000
   INTEGER STAT;                                                        03775000
   OPTION EXTERNAL;                                                     03780000
PROCEDURE FTROUBLE (CODE);                                              03785000
   VALUE CODE;                                                          03790000
   INTEGER CODE;                                                        03795000
   OPTION EXTERNAL;                                                     03800000
PROCEDURE FTITLE (T1,T2,T3,T4);                                         03805000
   VALUE T1,T2,T3,T4;                                                   03810000
   DOUBLE T1,T2,T3,T4;                                                  03815000
   OPTION EXTERNAL;                                                     03820000
DOUBLE PROCEDURE DISCSIZE(LDEV);                               <<01115>>03825000
   VALUE LDEV;                                                 <<01115>>03830000
   INTEGER LDEV;                                               <<01115>>03835000
   OPTION EXTERNAL;                                            <<01115>>03840000
PROCEDURE KWRITE(FILENUM,TARGET,TCOUNT);                       <<KS.00>>03845000
   VALUE FILENUM,TCOUNT;                                       <<KS.00>>03850000
   INTEGER FILENUM,TCOUNT;                                     <<KS.00>>03855000
   ARRAY TARGET;                                               <<KS.00>>03860000
   OPTION EXTERNAL;                                            <<KS.00>>03865000
INTEGER PROCEDURE KREADDIR(FILENUM,TARGET,TCOUNT,REC);         <<KS.00>>03870000
   VALUE FILENUM,TCOUNT,REC;                                   <<KS.00>>03875000
   INTEGER FILENUM,TCOUNT;                                     <<KS.00>>03880000
   DOUBLE REC;                                                 <<KS.00>>03885000
   ARRAY TARGET;                                               <<KS.00>>03890000
   OPTION EXTERNAL;                                            <<KS.00>>03895000
PROCEDURE KUPDATE(FILENUM,TARGET,TCOUNT);                      <<KS.00>>03900000
   VALUE FILENUM,TCOUNT;                                       <<KS.00>>03905000
   INTEGER FILENUM,TCOUNT;                                     <<KS.00>>03910000
   ARRAY TARGET;                                               <<KS.00>>03915000
   OPTION EXTERNAL;                                            <<KS.00>>03920000
PROCEDURE KSPACE(FILENUM,DISPLACEMENT);                        <<KS.00>>03925000
   VALUE FILENUM,DISPLACEMENT;                                 <<KS.00>>03930000
   INTEGER FILENUM,DISPLACEMENT;                               <<KS.00>>03935000
   OPTION EXTERNAL;                                            <<KS.00>>03940000
PROCEDURE KPOINT(FILENUM,RECNUM);                              <<KS.00>>03945000
   VALUE FILENUM,RECNUM;                                       <<KS.00>>03950000
   INTEGER FILENUM;                                            <<KS.00>>03955000
   DOUBLE RECNUM;                                              <<KS.00>>03960000
   OPTION EXTERNAL;                                            <<KS.00>>03965000
PROCEDURE KCONTROL(FILENUM,CODE,PARAM);                        <<KS.00>>03970000
   VALUE FILENUM,CODE;                                         <<KS.00>>03975000
   INTEGER FILENUM,CODE,PARAM;                                 <<KS.00>>03980000
   OPTION EXTERNAL;                                            <<KS.00>>03985000
PROCEDURE KSETMODE(FILENUM,FLAGS);                             <<KS.00>>03990000
   VALUE FILENUM,FLAGS;                                        <<KS.00>>03995000
   INTEGER FILENUM;                                            <<KS.00>>04000000
   LOGICAL FLAGS;                                              <<KS.00>>04005000
   OPTION EXTERNAL;                                            <<KS.00>>04010000
PROCEDURE KCHECK(FILENUM,ERRCODE,TLOG,BLKNUM,                  <<KS.00>>04015000
   NUMRECS);                                                   <<KS.00>>04020000
   VALUE FILENUM;                                              <<KS.00>>04025000
   INTEGER FILENUM,ERRCODE,TLOG,NUMRECS;                       <<KS.00>>04030000
   DOUBLE BLKNUM;                                              <<KS.00>>04035000
   OPTION EXTERNAL;                                            <<KS.00>>04040000
PROCEDURE KGETINFO(FILENUM,FILENAME,FOPTIONS,                  <<KS.00>>04045000
   AOPTIONS,RECSIZE,DEVTYPE,LDNUM,HDADDR,FILECODE,             <<KS.00>>04050000
   RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,BLKSIZE,               <<KS.00>>04055000
   EXTSIZE,NUMEXTENTS,USERLABELS,CREATORID,DISKADR);           <<KS.00>>04060000
   VALUE FILENUM;                                              <<KS.00>>04065000
   INTEGER FILENUM,RECSIZE,DEVTYPE,FILECODE,BLKSIZE,           <<KS.00>>04070000
   NUMEXTENTS,USERLABELS;                                      <<KS.00>>04075000
   BYTE ARRAY FILENAME,CREATORID;                              <<KS.00>>04080000
   LOGICAL FOPTIONS,AOPTIONS,LDNUM,HDADDR,EXTSIZE;             <<KS.00>>04085000
   DOUBLE RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,DISKADR;        <<KS.00>>04090000
   OPTION EXTERNAL,VARIABLE;                                   <<KS.00>>04095000
PROCEDURE KFILEINFO(FILENUM,ITEMNUM1,ITEMVAL1,                 <<04876>>04100000
                    ITEMNUM2,ITEMVAL2,ITEMNUM3,ITEMVAL3,       <<04876>>04105000
                    ITEMNUM4,ITEMVAL4,ITEMNUM5,ITEMVAL5);      <<04876>>04110000
   VALUE FILENUM,ITEMNUM1,ITEMNUM2,ITEMNUM3,ITEMNUM4,ITEMNUM5; <<04876>>04115000
   INTEGER FILENUM,ITEMNUM1,ITEMNUM2,ITEMNUM3,ITEMNUM4,        <<04876>>04120000
           ITEMNUM5;                                           <<04876>>04125000
   BYTE ARRAY ITEMVAL1,ITEMVAL2,ITEMVAL3,ITEMVAL4,ITEMVAL5;    <<04876>>04130000
   OPTION EXTERNAL,VARIABLE;                                   <<04876>>04135000
PROCEDURE KREADLABEL(FN,TARGET,TCOUNT,LBL);                    <<KS.00>>04140000
   VALUE FN,TCOUNT,LBL;                                        <<KS.00>>04145000
   INTEGER FN,TCOUNT,LBL;                                      <<KS.00>>04150000
   ARRAY TARGET;                                               <<KS.00>>04155000
   OPTION EXTERNAL;                                            <<KS.00>>04160000
PROCEDURE KWRITELABEL(FN,TARGET,TCOUNT,LBL);                   <<KS.00>>04165000
   VALUE FN,TCOUNT,LBL;                                        <<KS.00>>04170000
   INTEGER FN,TCOUNT,LBL;                                      <<KS.00>>04175000
   ARRAY TARGET;                                               <<KS.00>>04180000
   OPTION EXTERNAL;                                            <<KS.00>>04185000
PROCEDURE KLOCK(FN,T);                                         <<KS.00>>04190000
   VALUE FN,T;                                                 <<KS.00>>04195000
   INTEGER FN;                                                 <<KS.00>>04200000
   LOGICAL T;                                                  <<KS.00>>04205000
   OPTION EXTERNAL;                                            <<KS.00>>04210000
PROCEDURE KUNLOCK(FN);                                         <<KS.00>>04215000
   VALUE FN;                                                   <<KS.00>>04220000
   INTEGER FN;                                                 <<KS.00>>04225000
   OPTION EXTERNAL;                                            <<KS.00>>04230000
INTEGER PROCEDURE KREAD(FILENUM,TARGET,TCOUNT);                <<KS.00>>04235000
   VALUE FILENUM,TCOUNT;                                       <<KS.00>>04240000
   INTEGER FILENUM,TCOUNT;                                     <<KS.00>>04245000
   ARRAY TARGET;                                               <<KS.00>>04250000
   OPTION EXTERNAL;                                            <<KS.00>>04255000
PROCEDURE FCHECK(P1,P2,P3,P4,P5);                                       04260000
   VALUE P1;                                                            04265000
   INTEGER P1,P2,P3,P5;                                                 04270000
   DOUBLE P4;                                                           04275000
   OPTION VARIABLE,PRIVILEGED,FORWARD;                                  04280000
                                                                        04285000
<<----------------------------------------------------------------------04290000
*                                                                      *04295000
*  EXTERNAL PROCEDURE DECLARATIONS                                     *04300000
*                                                                      *04305000
---------------------------------------------------------------------->>04310000
                                                               <<06959>>04315000
PROCEDURE IOWAITDISPATCHER(INDEX);                             <<06959>>04320000
  VALUE INDEX;                                                 <<06959>>04325000
  INTEGER INDEX;                                               <<06959>>04330000
  OPTION EXTERNAL;                                             <<06959>>04335000
                                                               <<06959>>04340000
PROCEDURE ENABLEIOWAITPORT(INDEX);                             <<06959>>04345000
  VALUE INDEX;                                                 <<06959>>04350000
  INTEGER INDEX;                                               <<06959>>04355000
  OPTION EXTERNAL;                                             <<06959>>04360000
                                                               <<06959>>04365000
PROCEDURE DISABLEIOWAITPORT(INDEX);                            <<06959>>04370000
  VALUE INDEX;                                                 <<06959>>04375000
  INTEGER INDEX;                                               <<06959>>04380000
  OPTION EXTERNAL;                                             <<06959>>04385000
                                                               <<03038>>04390000
PROCEDURE ABORT(MODE,CODE,PARAM);                              <<03038>>04395000
VALUE MODE,CODE,PARAM;                                         <<03038>>04400000
LOGICAL MODE,CODE,PARAM;                                       <<03038>>04405000
OPTION EXTERNAL;                                               <<03038>>04410000
                                                                        04415000
PROCEDURE ABORTIOX (IOQX);                                     <<+0.05>>04420000
   VALUE IOQX;                                                 <<+0.05>>04425000
   INTEGER IOQX;                                               <<+0.05>>04430000
   OPTION EXTERNAL;                                            <<+0.05>>04435000
                                                               <<04566>>04440000
DOUBLE PROCEDURE IOSTATUS(IOQX);                               <<04566>>04445000
VALUE IOQX;                                                    <<04566>>04450000
INTEGER IOQX;                                                  <<04566>>04455000
OPTION EXTERNAL,PRIVILEGED,UNCALLABLE;                         <<04566>>04460000
                                                               <<04566>>04465000
DOUBLE PROCEDURE ATTACHIO (LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS);  04470000
   VALUE LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS;                     04475000
   INTEGER LDEV,QMISC,DSTX,ADDR,FUNC,CNT,P1,P2,FLAGS;                   04480000
   OPTION EXTERNAL;                                                     04485000
PROCEDURE AWAKE(PCBPT,CONDITION,WAITFLAG);                     <<HM.00>>04490000
VALUE PCBPT,CONDITION,WAITFLAG;                                <<HM.00>>04495000
INTEGER PCBPT,WAITFLAG;                                        <<HM.00>>04500000
LOGICAL CONDITION;                                             <<HM.00>>04505000
OPTION EXTERNAL;                                               <<HM.00>>04510000
                                                               <<HM.00>>04515000
INTEGER PROCEDURE CALENDAR;                                             04520000
   OPTION EXTERNAL;                                                     04525000
LOGICAL PROCEDURE CHANGEINTSTATE(NEWSTATE);                    <<03038>>04530000
   VALUE NEWSTATE;                                             <<03038>>04535000
   LOGICAL NEWSTATE;                                           <<03038>>04540000
   OPTION EXTERNAL;                                            <<03038>>04545000
PROCEDURE CLEARWAKE (IOQX);                                             04550000
   VALUE IOQX;                                                          04555000
   INTEGER IOQX;                                                        04560000
   OPTION EXTERNAL;                                                     04565000
PROCEDURE CLEARWWS;                                                     04570000
   OPTION EXTERNAL;                                                     04575000
                                                               <<TL.02>>04580000
INTEGER PROCEDURE CHECKUL(FN,CODE,FUNC);                       <<02693>>04585000
  VALUE FN,CODE,FUNC;                                          <<02545>>04590000
  INTEGER FN,CODE,FUNC;                                        <<02545>>04595000
  OPTION EXTERNAL;                                             <<TL.02>>04600000
                                                               <<TL.02>>04605000
PROCEDURE DEBUG;                                                        04610000
   OPTION EXTERNAL;                                                     04615000
LOGICAL PROCEDURE DEVICESTATUS (LDEV);                                  04620000
   VALUE LDEV;                                                          04625000
   INTEGER LDEV;                                                        04630000
   OPTION EXTERNAL;                                                     04635000
                                                               <<07234>>04640000
INTEGER PROCEDURE GET'DSDEVICE(LDEV);                          <<07234>>04645000
VALUE LDEV;                                                    <<07234>>04650000
INTEGER LDEV;                                                  <<07234>>04655000
OPTION EXTERNAL;                                               <<07234>>04660000
                                                               <<07234>>04665000
DOUBLE PROCEDURE DIRECADJUST (NUMSECTS,DUMMY,AN,GN,MVTABX);    <<39.PV>>04670000
   VALUE NUMSECTS,DUMMY,MVTABX;                                <<39.PV>>04675000
   DOUBLE NUMSECTS;                                                     04680000
   INTEGER DUMMY,MVTABX;                                       <<39.PV>>04685000
   ARRAY AN,GN;                                                         04690000
   OPTION EXTERNAL,VARIABLE;                                   <<39.PV>>04695000
INTEGER PROCEDURE DISKALLOC (INDEX,NUMEXT,SPACEDATA,PVINFO);   <<RH.PV>>04700000
   VALUE INDEX,NUMEXT,PVINFO;                                  <<RH.PV>>04705000
   INTEGER INDEX,NUMEXT;                                       <<RH.PV>>04710000
   LOGICAL PVINFO;                                             <<RH.PV>>04715000
   DOUBLE ARRAY SPACEDATA;                                              04720000
   OPTION EXTERNAL;                                                     04725000
   COMMENT  Returns operation status as result:                         04730000
      0 - OK                                                            04735000
      1 - Invalid number of sectors                                     04740000
      2 - Device not available (left byte contains LDEV)                04745000
      3 - Disc space not available                                      04750000
      4 - Misc. I/O error                                               04755000
      5 - Invalid index;                                                04760000
INTEGER PROCEDURE DISKDEALLOC (EXTSIZE,LASTEXTSIZE,NUMEXT,MAP);         04765000
   VALUE EXTSIZE,LASTEXTSIZE,NUMEXT;                                    04770000
   INTEGER EXTSIZE,LASTEXTSIZE,NUMEXT;                                  04775000
   DOUBLE ARRAY MAP;                                                    04780000
   OPTION EXTERNAL;                                                     04785000
   COMMENT  Returns operation status as result:                         04790000
      Left byte:                                                        04795000
         Map entry index                                                04800000
      Right byte:                                                       04805000
         0 - OK                                                         04810000
         1 - Misc. I/O error                                            04815000
         2 - Invalid number of sectors                                  04820000
         4 - Invalid sector number                                      04825000
         5 - Free space table full;                                     04830000
PROCEDURE ERROREXIT (WORDS,ERROR,ZERO);                                 04835000
   VALUE WORDS,ERROR,ZERO;                                              04840000
   INTEGER WORDS,ERROR,ZERO;                                            04845000
   OPTION EXTERNAL;                                                     04850000
PROCEDURE ERRORON;                                                      04855000
   OPTION EXTERNAL;                                                     04860000
LOGICAL PROCEDURE EXCHANGEDB (DSTX);                                    04865000
   VALUE DSTX;                                                          04870000
   LOGICAL DSTX;                                                        04875000
   OPTION EXTERNAL;                                                     04880000
INTEGER PROCEDURE FCCONTROL(FUNCTION,PARAMETER);               <<HM.00>>04885000
   VALUE FUNCTION;                                             <<HM.00>>04890000
   INTEGER FUNCTION;                                           <<HM.00>>04895000
   LOGICAL PARAMETER;                                          <<HM.00>>04900000
   OPTION EXTERNAL;                                            <<HM.00>>04905000
DOUBLE PROCEDURE FCHECKMSGBLOCK(TARGET,BC);                    <<HM.00>>04910000
   VALUE TARGET,BC;                                            <<HM.00>>04915000
   INTEGER POINTER TARGET;                                     <<HM.00>>04920000
   INTEGER BC;                                                 <<HM.00>>04925000
   OPTION EXTERNAL;                                            <<HM.00>>04930000
PROCEDURE FCREAD(FUNCTION,TARGET,TCOUNT);                      <<HM.00>>04935000
   VALUE FUNCTION,TARGET,TCOUNT;                               <<HM.00>>04940000
   INTEGER POINTER TARGET;                                     <<HM.00>>04945000
   INTEGER FUNCTION,TCOUNT;                                    <<HM.00>>04950000
   OPTION EXTERNAL;                                            <<HM.00>>04955000
PROCEDURE FCWRITE(FUNCTION,TARGET,TCOUNT);                     <<HM.00>>04960000
   VALUE FUNCTION,TARGET,TCOUNT;                               <<HM.00>>04965000
   INTEGER POINTER TARGET;                                     <<HM.00>>04970000
   INTEGER FUNCTION,TCOUNT;                                    <<HM.00>>04975000
   OPTION EXTERNAL;                                            <<HM.00>>04980000
INTEGER PROCEDURE FCWRITEOF(DUMMY1,DUMMY2);                    <<HM.00>>04985000
   VALUE DUMMY1,DUMMY2;                                        <<HM.00>>04990000
   INTEGER DUMMY1,DUMMY2;                                      <<HM.00>>04995000
   OPTION EXTERNAL;                                            <<HM.00>>05000000
INTEGER PROCEDURE FCABORTREQUESTS(DUMMY1,DUMMY2);              <<HM.00>>05005000
   VALUE DUMMY1,DUMMY2;                                        <<HM.00>>05010000
   INTEGER DUMMY1,DUMMY2;                                      <<HM.00>>05015000
   OPTION EXTERNAL;                                            <<HM.00>>05020000
PROCEDURE FCUPDATEWRITE(ACBLOC,NONDATARECORDS);                <<HM.00>>05025000
   VALUE ACBLOC,NONDATARECORDS;                                <<HM.00>>05030000
   INTEGER ACBLOC,NONDATARECORDS;                              <<HM.00>>05035000
   OPTION EXTERNAL;                                            <<HM.00>>05040000
PROCEDURE FCGETINFO(ACBLOC,INDEX,RETURNVALUE);                 <<03038>>05045000
VALUE ACBLOC,INDEX;                                            <<03038>>05050000
INTEGER ACBLOC,INDEX;                                          <<03038>>05055000
ARRAY RETURNVALUE;                                             <<03038>>05060000
OPTION EXTERNAL;                                               <<03038>>05065000
DOUBLE PROCEDURE FCRETURNINFO(RSIZE,ACBLOC);                   <<HM.00>>05070000
   VALUE RSIZE,ACBLOC;                                         <<HM.00>>05075000
   INTEGER RSIZE,ACBLOC;                                       <<HM.00>>05080000
   OPTION EXTERNAL;                                            <<HM.00>>05085000
LOGICAL PROCEDURE FCPORTENABLE(PORT'NUMBER);                   <<HM.00>>05090000
   VALUE PORT'NUMBER;                                          <<HM.00>>05095000
   INTEGER PORT'NUMBER;                                        <<HM.00>>05100000
   OPTION EXTERNAL;                                            <<HM.00>>05105000
PROCEDURE FCPORTDISABLE(PORT);                                 <<HM.00>>05110000
   VALUE PORT;                                                 <<HM.00>>05115000
   INTEGER PORT;                                               <<HM.00>>05120000
   OPTION EXTERNAL;                                            <<HM.00>>05125000
LOGICAL PROCEDURE FCCHECKFILEND(ACBLOC,BLOCKNUM);              <<01750>>05130000
   VALUE ACBLOC,BLOCKNUM;                                      <<01750>>05135000
   INTEGER ACBLOC;                                             <<01750>>05140000
   DOUBLE BLOCKNUM;                                            <<01750>>05145000
   OPTION EXTERNAL;                                            <<01750>>05150000
LOGICAL PROCEDURE GETSIR (SIRNUM);                                      05155000
   VALUE SIRNUM;                                                        05160000
   INTEGER SIRNUM;                                                      05165000
   OPTION EXTERNAL;                                                     05170000
PROCEDURE IMPEDE (PCBPT);                                               05175000
   VALUE PCBPT;                                                         05180000
   INTEGER PCBPT;                                                       05185000
   OPTION EXTERNAL;                                                     05190000
INTEGER PROCEDURE LDEVTODRT(LDEV);                             <<00157>>05195000
   VALUE LDEV;                                                 <<00157>>05200000
   LOGICAL LDEV;                                               <<00157>>05205000
   OPTION EXTERNAL;                                            <<00157>>05210000
INTEGER PROCEDURE LDEVTOSUBTYPE(LDEV);                         <<01115>>05215000
   VALUE LDEV;                                                 <<01115>>05220000
   INTEGER LDEV;                                               <<01115>>05225000
   OPTION EXTERNAL;                                            <<01115>>05230000
INTEGER PROCEDURE LDEVTOTYPE(LDEV);                            <<01115>>05235000
   VALUE LDEV;                                                 <<01115>>05240000
   INTEGER LDEV;                                               <<01115>>05245000
   OPTION EXTERNAL;                                            <<01115>>05250000
PROCEDURE MMSTAT'(EVENT,P1,P2,P3,P4,P5,P6);                    <<06958>>05255000
   VALUE EVENT,P1,P2,P3,P4,P5,P6;                              <<06958>>05260000
   INTEGER EVENT,P1,P2,P3,P4,P5,P6;                            <<06958>>05265000
   OPTION EXTERNAL;                                            <<+0.04>>05270000
LOGICAL PROCEDURE MRCAPOK (SB, RIN);                           <<00560>>05275000
  VALUE SB, RIN;                                               <<00560>>05280000
  LOGICAL SB;                                                  <<00560>>05285000
  INTEGER RIN;                                                 <<00560>>05290000
  OPTION VARIABLE, EXTERNAL;                                   <<00560>>05295000
INTEGER PROCEDURE REELSWITCH(LDEV,RDWR);                       <<02545>>05300000
   VALUE LDEV,RDWR;                                            <<02545>>05305000
   LOGICAL LDEV;                                               <<02545>>05310000
   INTEGER RDWR;                                               <<02545>>05315000
  OPTION EXTERNAL;                                             <<TL.02>>05320000
PROCEDURE RELSIR (SIRNUM,A);                                            05325000
   VALUE SIRNUM,A;                                                      05330000
   INTEGER SIRNUM;                                                      05335000
   LOGICAL A;                                                           05340000
   OPTION EXTERNAL;                                                     05345000
DOUBLE PROCEDURE REQSTATUS(LDN);                               <<01115>>05350000
   VALUE LDN; INTEGER LDN;                                     <<01115>>05355000
   OPTION EXTERNAL;                                            <<01115>>05360000
PROCEDURE RESETCRITICAL (OLDVAL);                                       05365000
   VALUE OLDVAL;                                                        05370000
   LOGICAL OLDVAL;                                                      05375000
   OPTION EXTERNAL;                                                     05380000
PROCEDURE RLOCK (RIN,T);                                                05385000
   VALUE RIN,T;                                                         05390000
   INTEGER RIN;                                                         05395000
   LOGICAL T;                                                           05400000
   OPTION EXTERNAL;                                                     05405000
PROCEDURE RUNLOCK (RIN);                                                05410000
   VALUE RIN;                                                           05415000
   INTEGER RIN;                                                         05420000
   OPTION EXTERNAL;                                                     05425000
LOGICAL PROCEDURE SETCRITICAL;                                          05430000
   OPTION EXTERNAL;                                                     05435000
PROCEDURE SETWAKE (IOQX);                                               05440000
   VALUE IOQX;                                                          05445000
   INTEGER IOQX;                                                        05450000
   OPTION EXTERNAL;                                                     05455000
PROCEDURE UNIMPEDE (PCBPT);                                             05460000
   VALUE PCBPT;                                                         05465000
   INTEGER PCBPT;                                                       05470000
   OPTION EXTERNAL;                                                     05475000
PROCEDURE WAIT (WF,JPCNTX);                                             05480000
   VALUE WF,JPCNTX;                                                     05485000
   INTEGER WF,JPCNTX;                                                   05490000
   OPTION EXTERNAL;                                                     05495000
                                                               <<04333>>05500000
LOGICAL PROCEDURE VALIDDEVTYPE (LDEV, FUNCTION, FLAGS);        <<04333>>05505000
   VALUE LDEV, FUNCTION;                                       <<04333>>05510000
   INTEGER LDEV, FUNCTION;                                     <<04333>>05515000
   LOGICAL FLAGS;                                              <<04333>>05520000
   OPTION EXTERNAL;                                            <<04333>>05525000
                                                               <<04333>>05530000
PROCEDURE FCAWAKEN(PIN);                                       <<03038>>05535000
VALUE PIN;                                                     <<03038>>05540000
INTEGER PIN;                                                   <<03038>>05545000
OPTION EXTERNAL;                                               <<03038>>05550000
DOUBLE PROCEDURE WAITFORIO (IOQX);                                      05555000
   VALUE IOQX;                                                          05560000
   INTEGER IOQX;                                                        05565000
   OPTION EXTERNAL;                                                     05570000
DOUBLE PROCEDURE WAITFORIOX (IOQX);                                     05575000
   VALUE IOQX;                                                          05580000
   INTEGER IOQX;                                                        05585000
   OPTION EXTERNAL;                                                     05590000
PROCEDURE TGETINFO(LDEV,FBUF,ITEMNUM);                         <<02545>>05595000
   VALUE LDEV,ITEMNUM; INTEGER LDEV,ITEMNUM;                   <<02545>>05600000
   ARRAY FBUF;                                                 <<02545>>05605000
   OPTION EXTERNAL;                                            <<02545>>05610000
                                                               <<TL.02>>05615000
DOUBLE PROCEDURE XDDSPOOLINFO (DVAL,ITEM,XDDSUBP);                      05620000
   VALUE   DVAL,ITEM,XDDSUBP;                                           05625000
   LOGICAL ITEM;                                                        05630000
   DOUBLE  DVAL;                                                        05635000
   INTEGER POINTER XDDSUBP;                                             05640000
   OPTION EXTERNAL;                                                     05645000
PROCEDURE QUEUEONSEGMENT(SEGID);                               <<01701>>05650000
   VALUE SEGID;                                                <<01701>>05655000
   DOUBLE  SEGID;                                              <<06511>>05660000
   OPTION EXTERNAL;                                            <<01701>>05665000
                                                                        05670000
 PROCEDURE HELP  << for dummy call >>;                         <<00117>>05675000
    OPTION EXTERNAL;                                           <<00117>>05680000
                                                               <<04776>>05685000
INTEGER PROCEDURE DST'SIZE(DSTN);                              << 7972>>05690000
VALUE DSTN;                                                    << 7972>>05695000
INTEGER DSTN;                                                  << 7972>>05700000
OPTION EXTERNAL;                                               << 7972>>05705000
                                                               <<*8760>>05710000
$PAGE " LOCK'CB "                                                       05715000
$CONTROL SEGMENT=FILESYS1A                                              05720000
PROCEDURE LOCK'CB(FLAGS,STACKDST,STK'TARGET,CBVECTOR);                  05725000
VALUE   FLAGS,STACKDST,STK'TARGET,CBVECTOR;                             05730000
INTEGER STACKDST,STK'TARGET;                                            05735000
LOGICAL FLAGS;                                                          05740000
DOUBLE CBVECTOR;                                                        05745000
OPTION PRIVILEGED,UNCALLABLE;                                           05750000
                                                                        05755000
COMMENT  This  procedure  locks  a control block using MDS instructions.05760000
It  returns  four  words (via partial cutback of the stack) suitable for05765000
an MDS  to  copy the CB into a buffer of the calling procedure.  The top05770000
two  words  will  be CBDST and CBOFST (address of start of control block05775000
data  area)  so  TOS  upon  return must be incremented in order to start05780000
start  copying from the middle of the control block.  A word count needs05785000
to be pushed upon return and a MDS executed to read the control block.  05790000
                                                                        05795000
A special feature is the treatment used if FLAGS = 8.  This is a request05800000
for a "quick mode" lock, which, if granted, will cause  the procedure to05805000
return with the system P'disabled.  This  will  allow the calling proce-05810000
dure to copy in data without actually setting the locked state in the CB05815000
lock  area.  This  saves  both a MDS back of the lock words as well as a05820000
call to UNLOCK'CB.  This strategy is suitable if the control block needs05825000
to  be  locked  for only a millisecond or so and there can be no absence05830000
traps  (either  code  or  data).  In  practice,  this requires that this05835000
option (FLAG= 8) only be called from a procedure in the same  segment as05840000
LOCK'CB.  An  example  is updating  EOF in the FCB.  It is possible that05845000
such  a  request  for  quick mode cannot be satisfied (because the CB is05850000
locked  and an IMPDE was required). Therefore the value of the FLAG parm05855000
upon  return is used to inform the caller whether an UNLOCK'CB  needs to05860000
be done (FLAG=TRUE means need UNLOCK'CB ).  The lowest parameter is used05865000
to pass back this information rather than the condition code since often05870000
several  instructions need to be executed before testing whether to call05875000
UNLOCK'CB.                                                              05880000
                                                                        05885000
Another  special  feature is that of a conditional lock.  If the condit-05890000
tional lock bit has been set by LOC'ACB (FLAGS.(1:1) = 1), then we don't05895000
impede  the  process  on  a locked control block.  Instead, we leave him05900000
PSEUDO-DISABLED  on  the  control  block queue and return.  LOC'ACB does05905000
this to release the FMAVT SIR before impeding on the control block. This05910000
is used by FCLOSE only at this point.                                   05915000
                                                                        05920000
All potentially sharable FCB'S and ACB's will be in extra data segments.05925000
The  given  control block will always be in the users own stack or in an05930000
extra data segment.  Shared CB's will NEVER reside in a stack!          05935000
                                                                        05940000
Input variables:                                                        05945000
                                                                        05950000
   FLAGS       bit 14 -- create break mode [FBREAK]                     05955000
               bit 12 -- request for "quick mode"                       05960000
               bit  1 -- conditional lock                               05965000
   STK'TARGET  Caller's Q-relative CB buffer address.                   05970000
   CBVECTOR    Vector of the control block.                             05975000
                                                                        05980000
Output variables and modes:                                             05985000
                                                                        05990000
   FLAGS       True if the UNLOCK'CB is needed                          05995000
   STACKDST    The DST number of the users stack (target DST)           06000000
   STK'TARGET  Stack relative offset of users target array              06005000
   CBVECTOR    The double word vector is returned as follows:           06010000
      CBVECTOR'DSTN  - DST number of source CB DST                      06015000
      CBVECTOR'ENTRY - DST  relative offset of source CB. Takes the PCBX06020000
                       CBT offset in mind if in the stack.              06025000
                                                                        06030000
   NOCARRY - Succesful                                                  06035000
   CARRY   - Conditional lock (Queued, no impede)                      ;06040000
                                                                        06045000
BEGIN                                                                   06050000
! Keep VT array at Q+1 unless VTMQ equate is changed.                   06055000
INTEGER ARRAY VT(0:VTENTRY-1)=Q;                                        06060000
EQUATE VTMQ = 1;  ! VT is located at Q + 1.                             06065000
INTEGER                                                                 06070000
   DQIN = STK'TARGET,  ! DQ input is sent in this var.                  06075000
   DQ,                 ! Q-relative offset to the CB array.             06080000
   PCBPT,              ! Pointer to PCB for defines.                    06085000
   MY'PIN,             ! Our PIN number.                                06090000
   PXFILE'OFFSET,      ! Stack relative offset to CBT.                  06095000
   PXCBT'OFFSET := 0,  ! Offset to the PXFILE table of stack.           06100000
   PCBGLOBLOC,         ! Q relative offset to PXGLOBAL area.            06105000
   CBVECTOR'DSTN       = CBVECTOR + 0,                                  06110000
   CBVECTOR'ENTRY      = CBVECTOR + 1;                                  06115000
LOGICAL                                                                 06120000
   MUST'IMPEDE := FALSE,  ! Impede needed on the CB?                    06125000
   LOCKED      := TRUE ;  ! Was the quick lock successfull?             06130000
DEFINE                                                                  06135000
   QUICK'LOCK        = FLAGS.(12:1)#,                                   06140000
   FBREAK'MODE       = FLAGS.(14:1)#,                                   06145000
   COND'LOCK         = FLAGS.(1:1)#,                                    06150000
   SETCARRY          = CARRYCODE :=1#,                                  06155000
   SETNOCARRY        = CARRYCODE :=0#;                                  06160000
$PAGE    " LOCK'CB - Subroutines "                                      06165000
SUBROUTINE LOC'VTENTRY;                                                 06170000
                                                                        06175000
!-------------------------------------------------------------          06180000
! This subroutine copies the vector table entry of the given            06185000
! CB vector into the Q-relative array.                                  06190000
!-------------------------------------------------------------          06195000
                                                                        06200000
BEGIN                                                                   06205000
TOS := STACKDST;            ! Goes to our stack.                        06210000
TOS := VTMQ-PCBGLOBLOC;     ! Stack relative offset to VT.              06215000
TOS := CBVECTOR'DSTN;       ! Vector DST number.                        06220000
TOS := CBVECTOR'ENTRY;      ! DST relative offset to VT entry.          06225000
TOS := VTENTRY;             ! Vector table entry size.                  06230000
MOVE'DS'5;                  ! Off they go!                              06235000
END;                                                                    06240000
                                                                        06245000
                                                                        06250000
                                                                        06255000
                                                                        06260000
                                                                        06265000
                                                                        06270000
SUBROUTINE UNLOC'VTENTRY;                                               06275000
                                                                        06280000
!-------------------------------------------------------------          06285000
! This subroutine copies the VT entry of the given CB from the          06290000
! Q-relative array to the CB's VT entry.                                06295000
!-------------------------------------------------------------          06300000
                                                                        06305000
BEGIN                                                                   06310000
TOS := CBVECTOR'DSTN;       ! Vector DST number.                        06315000
TOS := CBVECTOR'ENTRY;      ! DST relative offset to VT entry.          06320000
TOS := STACKDST;            ! Comes from our stack.                     06325000
TOS := VTMQ-PCBGLOBLOC;     ! Stack relative offset to VT.              06330000
TOS := VTENTRY;             ! Vector table entry size.                  06335000
MOVE'DS'5;                  ! Off they go!                              06340000
END;                                                                    06345000
                                                                        06350000
                                                                        06355000
                                                                        06360000
                                                                        06365000
                                                                        06370000
                                                                        06375000
SUBROUTINE IMPEDE'ON'HIGH'QUEUE;                                        06380000
                                                                        06385000
!----------------------------------------------------------             06390000
! During normal locking, processes impede on this, the                  06395000
! high or normal queue.  During break, the CI will im-                  06400000
! pede on this queue until its son calls UNLOC'ACB with                 06405000
! create break queue.  Then, the son will impede on the                 06410000
! low prio queue and the CI will run.                                   06415000
!----------------------------------------------------------             06420000
                                                                        06425000
BEGIN                                                                   06430000
IF VT'QHEAD = 0 THEN                                                    06435000
   BEGIN         ! No one else is waiting, were at head.                06440000
   VT'QHEAD := MY'PIN;                                                  06445000
   VT'QTAIL := MY'PIN;                                                  06450000
   END                                                                  06455000
ELSE                                                                    06460000
   BEGIN         ! Wasn't empty, go to end of queue.                    06465000
   PCBPT := VT'QTAIL;                                                   06470000
   SPCBNIMPPIN := MY'PIN;                                               06475000
   VT'QTAIL := MY'PIN;                                                  06480000
   END;                                                                 06485000
PCBPT := MY'PIN;                                                        06490000
SPCBNIMPPIN := 0;                 ! No next impeded PIN.                06495000
MUST'IMPEDE := TRUE;              ! We must now impede.                 06500000
END;                                                                    06505000
                                                                        06510000
                                                                        06515000
                                                                        06520000
                                                                        06525000
                                                                        06530000
                                                                        06535000
SUBROUTINE IMPEDE'ON'LOW'QUEUE;                                         06540000
                                                                        06545000
!----------------------------------------------------------             06550000
! All  non  CI  processes  will  impede on the low priority             06555000
! queue  during break.  Thus, the CI will have sole control             06560000
! of  the  control block untill FUNBREAK is called. At that             06565000
! time, the  low queue will be moved into the  high or nor-             06570000
! mal  queue  and  the son process at the head of the queue             06575000
! will be allowed to run.                                               06580000
!----------------------------------------------------------             06585000
                                                                        06590000
BEGIN                                                                   06595000
IF VT'SAVEQ'HEAD = 0 THEN                                               06600000
   BEGIN         ! No one else is waiting, were at head.                06605000
   VT'SAVEQ'HEAD := MY'PIN;                                             06610000
   VT'SAVEQ'TAIL := MY'PIN;                                             06615000
   END                                                                  06620000
ELSE                                                                    06625000
   BEGIN         ! Wasn't empty, go to end of queue.                    06630000
   PCBPT := VT'SAVEQ'TAIL;                                     << 8466>>06635000
   SPCBNIMPPIN := MY'PIN;                                               06640000
   VT'SAVEQ'TAIL := MY'PIN;                                             06645000
   END;                                                                 06650000
PCBPT := MY'PIN;                                                        06655000
SPCBNIMPPIN := 0;                 ! No next impeded PIN.                06660000
MUST'IMPEDE := TRUE;              ! We must now impede.                 06665000
END;                                                                    06670000
$PAGE " LOCK'CB - OUTER BLOCK "                                         06675000
   !----------------------------------------------------------          06680000
   ! First, obtain our stack DST number and PIN number.  Then           06685000
   ! get the PCBX CBT offset and add to vector entry offset if          06690000
   ! the CB resides in our stack.                                       06695000
   !----------------------------------------------------------          06700000
                                                                        06705000
   SETNOCARRY;         ! Normal case, no conditional lock.              06710000
   MY'PIN := PCBPT := CURPRC;                                           06715000
   DQ := DQIN - DELTAQ;! Make CB array relative to our Q.               06720000
   STACKDST := SPCBSTKDST;                                              06725000
   PXGLOBAL;           ! Set PCBGLOBLOC value.                          06730000
   IF CBVECTOR'DSTN = STACKDST THEN                                     06735000
      BEGIN            ! Add PCBX offset to reach VT entry.             06740000
      GET'PXFILE'OFFSET;                                                06745000
      PXCBT'OFFSET := PXFILE'OFFSET + PXFOVERHEAD;                      06750000
      CBVECTOR'ENTRY := CBVECTOR'ENTRY + PXCBT'OFFSET;                  06755000
      END;                                                              06760000
                                                                        06765000
   !----------------------------------------------------------          06770000
   ! Make  sure  that the needed data segment is in memory be-          06775000
   ! fore  P-disableing.  Test  bit  one, word zero of the DST          06780000
   ! entry.  If on, then the DST is not present.                        06785000
   !----------------------------------------------------------          06790000
                                                                        06795000
AGAIN:                                                                  06800000
   DISABLE;                                                             06805000
                                                                        06810000
   IF DST'(CBVECTOR'DSTN*DSTENTRY).(0:1) = 1 THEN                       06815000
      BEGIN          ! Not present.                                     06820000
      ENABLE;                                                           06825000
      QUEUEONSEGMENT(DBL(CBVECTOR'DSTN));                               06830000
      GOTO AGAIN;    ! Hope the damned thing stays put.                 06835000
      END;                                                              06840000
                                                                        06845000
   PSEUDODISABLE;    ! Aha! Gotcha.                                     06850000
   ENABLE;                                                              06855000
                                                                        06860000
   ! Copy Vector table entry into the stack and check.                  06865000
                                                                        06870000
   LOC'VTENTRY;                                                         06875000
   IF NOT (9 <= VT'ADR <= FSEGMAX) THEN FTROUBLE(59);                   06880000
                                                                        06885000
   !----------------------------------------------------------          06890000
   ! Check locking bits and queue.  If not locked, then we              06895000
   ! have an easy case. Otherwise, it gets a difficult.                 06900000
   !----------------------------------------------------------          06905000
                                                                        06910000
   IF VT'CONTROL = 0 AND VT'QHEAD = 0 THEN                              06915000
      BEGIN          ! CB wasn't locked - easy case                     06920000
      IF QUICK'LOCK THEN                                                06925000
         LOCKED := FALSE            ! Quick lock succeded.              06930000
      ELSE                                                              06935000
         IF FBREAK'MODE THEN                                            06940000
            BEGIN                   ! Set up for break.                 06945000
            VT'CONTROL := %140400;  ! Lock, break, count=1              06950000
            VT'PIN := MY'PIN;       ! Insert our PIN #.                 06955000
            END                                                         06960000
         ELSE                                                           06965000
            BEGIN                   ! Simply lock it.                   06970000
            VT'CONTROL := %100400;  ! Lock; count=1                     06975000
            VT'PIN := MY'PIN;       ! Insert our PIN #.                 06980000
            END;                                                        06985000
      END                                                               06990000
   ELSE              ! Difficult case, check it out.                    06995000
      IF NOT VT'LOCK THEN                                               07000000
         BEGIN       ! Not locked, check break bit                      07005000
         IF VT'BREAK THEN                                               07010000
            BEGIN    ! In break mode, non CI impedes.                   07015000
            IF SPCBPTYPE' = NON'CI'PIN THEN                             07020000
               IMPEDE'ON'LOW'QUEUE                                      07025000
            ELSE                                                        07030000
               BEGIN ! CI now has control of the CB!                    07035000
               VT'CONTROL := %140400;! Lock, cnt =1, break.             07040000
               VT'PIN := MY'PIN     ! Insert our PIN.                   07045000
               END;                                                     07050000
            END                                                         07055000
         ELSE                                                           07060000
            BEGIN    ! We somehow snuck by????????????????              07065000
            VT'CONTROL := %100400; ! Locked; count=1                    07070000
            VT'PIN := MY'PIN;      ! Insert our PIN number.             07075000
            END;                                                        07080000
         END                                                            07085000
      ELSE                                                              07090000
         BEGIN       ! CB is indeed already locked!                     07095000
         IF VT'PIN = MY'PIN THEN                                        07100000
            VT'COUNT := VT'COUNT + 1   ! Bump our count.                07105000
         ELSE                                                           07110000
            BEGIN    ! Locked by a different process.                   07115000
            IF FBREAK'MODE AND NOT VT'BREAK THEN                        07120000
               BEGIN ! Go ahead and create the break Q.                 07125000
               VT'BREAK'BIT := 1;                                       07130000
               VT'SAVEQ'TAIL:=  VT'QTAIL; ! Save normal Q               07135000
               VT'SAVEQ'HEAD:=  VT'QHEAD; ! in low pri Q.               07140000
               VT'QTAIL := 0;             ! Clear normal Q.             07145000
               VT'QHEAD := 0;                                           07150000
               END;                                                     07155000
            IF VT'BREAK AND SPCBPTYPE' = NON'CI'PIN                     07160000
               THEN IMPEDE'ON'LOW'QUEUE  ! Non CI in break.             07165000
               ELSE IMPEDE'ON'HIGH'QUEUE;! CI or no break.              07170000
            END;                                                        07175000
         END;                                                           07180000
                                                                        07185000
   !----------------------------------------------------------          07190000
   ! Now, if the control block has truly been locked (this              07195000
   ! is not the strange quick lock case), then either im-               07200000
   ! ede on the control block or P-enable and return.                   07205000
   ! Check for conditional lock case if one must impede.                07210000
   !----------------------------------------------------------          07215000
                                                                        07220000
   IF LOCKED THEN                                                       07225000
      BEGIN          ! Not the quick lock case, copy back.              07230000
      UNLOC'VTENTRY;                                                    07235000
      IF MUST'IMPEDE THEN                                               07240000
         BEGIN       ! Must impede, check conditional bit.              07245000
         IF COND'LOCK                                                   07250000
            THEN SETCARRY   ! Return queued, P-disabled.                07255000
            ELSE IMPEDE(0); ! Go to sleep, go to sleep.                 07260000
         END                                                            07265000
      ELSE                                                              07270000
         PSEUDOENABLE;      ! Lets rip this joint.                      07275000
      END;                                                              07280000
                                                                        07285000
   ! Set up the return parameters for the MDS.                          07290000
                                                                        07295000
   FLAGS := LOCKED;   ! Quick lock or regular?                          07300000
   CBVECTOR'ENTRY := VT'ADR + PXCBT'OFFSET;                             07305000
   STK'TARGET := DQ - PCBGLOBLOC;                                       07310000
   RETURN 0;          ! Pop marker only, leave parms.                   07315000
   END;     ! procedure LOCK'CB                                         07320000
$PAGE  " UNLOCK'CB - Declaraions and Subroutines "                      07325000
$CONTROL SEGMENT=FILESYS1A                                              07330000
PROCEDURE UNLOCK'CB(FLAGS,CBVECTOR);                                    07335000
VALUE FLAGS,CBVECTOR;                                                   07340000
LOGICAL FLAGS;                                                          07345000
DOUBLE CBVECTOR;                                                        07350000
OPTION PRIVILEGED,UNCALLABLE;                                           07355000
                                                                        07360000
!-------------------------------------------------------------          07365000
! Unlocks the specified control block. If no one is queued              07370000
!up waiting for it and we don't have to fiddle with break               07375000
! queues, we can just clear the lockword and leave.                     07380000
!                                                                       07385000
! Input variables:                                                      07390000
!    FLAGS  = flag word                                                 07395000
!    (13:1) = destroy Break queue [FUNBREAK]                            07400000
!    (14:1) = create Break queue [IOMOVE (terminal, NOBUF)]             07405000
!     CBVECTOR =  Control block vector.                                 07410000
!-------------------------------------------------------------          07415000
                                                                        07420000
BEGIN                                                                   07425000
! VT array must be at Q+1 unless VTMQ equate is changed.                07430000
INTEGER ARRAY VT(0:VTENTRY-1) = Q;                                      07435000
EQUATE VTMQ = 1;    ! Q relative offset to the VT array.                07440000
INTEGER                                                                 07445000
   PCBPT,             ! Pointer for PCB defines.                        07450000
   STACKDST,          ! DST number for our stack.                       07455000
   MY'PIN,            ! Our Process Identification number.              07460000
   NEXT'PIN,          ! Next process to run.                            07465000
   PXCBT'OFFSET := 0, ! Stack rel. offset to CBTAB.                     07470000
   PXFILE'OFFSET,     ! Stack rel. offset to PXFILE.                    07475000
   PCBGLOBLOC,        ! Q relative offset to PXGLOBAL area.             07480000
   CBVECTOR'DSTN  = CBVECTOR + 0,                                       07485000
   CBVECTOR'ENTRY = CBVECTOR + 1;                                       07490000
DEFINE                                                                  07495000
   FUNBREAK'MODE     = FLAGS.(13:1)#,                                   07500000
   CREATE'BREAK'MODE = FLAGS.(14:1)#;                                   07505000
                                                                        07510000
                                                                        07515000
                                                                        07520000
                                                                        07525000
SUBROUTINE UNIMPEDE'NEXT'PROCESS;                                       07530000
                                                                        07535000
!----------------------------------------------------------             07540000
! Take the next process in the normal Q and release it                  07545000
! to the world.                                                         07550000
!----------------------------------------------------------             07555000
                                                                        07560000
BEGIN                                                                   07565000
IF VT'QHEAD = 0 THEN                                                    07570000
   BEGIN   ! No one waiting, clear lock words and leave.                07575000
   VT'LOCK'BIT := 0;! Clear lock bit and PIN, but leave                 07580000
   VT'PIN  := 0;    ! break bit alone, could be set.                    07585000
   END                                                                  07590000
ELSE                                                                    07595000
   BEGIN   ! Unimped the next process in the Q.                         07600000
   NEXT'PIN := PCBPT := VT'QHEAD; ! Head PIN runs next.                 07605000
   IF VT'QHEAD = VT'QTAIL THEN                                          07610000
      BEGIN             ! No one else is waiting.                       07615000
      VT'QHEAD := 0;    ! Clear normal Q.                               07620000
      VT'QTAIL := 0;                                                    07625000
      END                                                               07630000
   ELSE    ! Head becomes next in line, linked to next.                 07635000
      VT'QHEAD := SPCBNIMPPIN;                                          07640000
   SPCBNIMPPIN := 0;    ! Clear my next impeded link.                   07645000
   VT'PIN := NEXT'PIN;  ! Next has lock.                                07650000
   VT'COUNT := 1;       ! Lock count = 1.                               07655000
   UNIMPEDE(NEXT'PIN);  ! Wake him up.                                  07660000
   END;                                                                 07665000
END; ! of subroutine.                                                   07670000
                                                                        07675000
                                                                        07680000
                                                                        07685000
                                                                        07690000
                                                                        07695000
SUBROUTINE LOC'VTENTRY;                                                 07700000
                                                                        07705000
!-------------------------------------------------------------          07710000
! This subroutine copies the vector table entry of the given            07715000
! CB vector into the Q-relative array.                                  07720000
!-------------------------------------------------------------          07725000
                                                                        07730000
BEGIN                                                                   07735000
TOS := STACKDST;            ! Our stack is target DST.                  07740000
TOS := VTMQ-PCBGLOBLOC;     ! Stack relative offset to VT.              07745000
TOS := CBVECTOR'DSTN;       ! Source vector DST number.                 07750000
TOS := CBVECTOR'ENTRY;      ! DST relative offset to VT entry.          07755000
TOS := VTENTRY;             ! Vector table entry size.                  07760000
MOVE'DS'5;                  ! Off they go!                              07765000
END;                                                                    07770000
                                                                        07775000
                                                                        07780000
                                                                        07785000
                                                                        07790000
                                                                        07795000
SUBROUTINE UNLOC'VTENTRY;                                               07800000
                                                                        07805000
!-------------------------------------------------------------          07810000
! This subroutine copies the VT entry of the given CB from the          07815000
! Q-relative array to the CB's VT entry.                                07820000
!-------------------------------------------------------------          07825000
                                                                        07830000
BEGIN                                                                   07835000
TOS := CBVECTOR'DSTN;       ! Vector DST number.                        07840000
TOS := CBVECTOR'ENTRY;      ! DST relative offset to VT entry.          07845000
TOS := STACKDST;            ! Comes from our stack.                     07850000
TOS := VTMQ-PCBGLOBLOC;     ! Stack relative offset to VT.              07855000
TOS := VTENTRY;             ! Vector table entry size.                  07860000
MOVE'DS'5;                  ! Off they go!                              07865000
END;                                                                    07870000
$PAGE "UNLOCK'CB - OUTER BLOCK "                                        07875000
   !----------------------------------------------------------          07880000
   ! First,  obtain  our  stack DST number and our PIN#.  Then          07885000
   ! get the PCBX CBT offset and add to vector entry offset if          07890000
   ! the CB resides in our stack.                                       07895000
   !----------------------------------------------------------          07900000
                                                                        07905000
   MY'PIN := PCBPT := CURPRC;                                           07910000
   STACKDST := SPCBSTKDST;                                              07915000
   PXGLOBAL;           ! Set PCBGLOBLOC value.                          07920000
   IF CBVECTOR'DSTN = STACKDST THEN                                     07925000
      BEGIN            ! Add PCBX offset to reach VT entry.             07930000
      GET'PXFILE'OFFSET;                                                07935000
      PXCBT'OFFSET := PXFILE'OFFSET + PXFOVERHEAD;                      07940000
      CBVECTOR'ENTRY := CBVECTOR'ENTRY + PXCBT'OFFSET;                  07945000
      END;                                                              07950000
                                                                        07955000
   !----------------------------------------------------------          07960000
   ! Make sure that the needed data segment is in memory                07965000
   ! before P-disableing.  Test bit one, word zero of the               07970000
   ! DST entry.  If on, then the DST is not present.                    07975000
   !----------------------------------------------------------          07980000
                                                                        07985000
AGAIN:                                                                  07990000
   DISABLE;                                                             07995000
                                                                        08000000
   IF DST'(CBVECTOR'DSTN*DSTENTRY).(0:1) = 1 THEN                       08005000
      BEGIN          ! Not present.                                     08010000
      ENABLE;                                                           08015000
      QUEUEONSEGMENT(DBL(CBVECTOR'DSTN));                               08020000
      GOTO AGAIN;                                                       08025000
      END;                                                              08030000
                                                                        08035000
   PSEUDODISABLE;    ! Zot!                                             08040000
   ENABLE;                                                              08045000
                                                                        08050000
   ! Copy vector table entry to stack and check it.                     08055000
                                                                        08060000
   LOC'VTENTRY;                                                         08065000
   IF NOT (9 <= VT'ADR <= FSEGMAX) THEN FTROUBLE(59);                   08070000
   IF MY'PIN <> VT'PIN THEN FTROUBLE(50);                               08075000
                                                                        08080000
   !----------------------------------------------------------          08085000
   ! Decrement  the locking count.  If this is our last access          08090000
   ! and  no break stuff, great!  Otherwise, if this is the CI          08095000
   ! calling us from FUNBREAK, then shuffle the low priority            08100000
   ! queue and let the son process run.                                 08105000
   !----------------------------------------------------------          08110000
                                                                        08115000
   VT'COUNT := VT'COUNT-1;  ! Decrement locking count.                  08120000
   IF VT'COUNT = 0 AND NOT VT'BREAK AND FLAGS = 0 AND                   08125000
      VT'QHEAD = 0 THEN                                                 08130000
      BEGIN  ! Easy case, last access and no break stuff.               08135000
      VT'CONTROL := 0;                                                  08140000
      VT'PIN := 0;                                                      08145000
      END                                                               08150000
   ELSE                                                                 08155000
      BEGIN       ! If last access by us, check it out.                 08160000
      IF VT'COUNT = 0 THEN                                              08165000
         IF CREATE'BREAK'MODE THEN                                      08170000
            BEGIN ! Are we already in break?                            08175000
            IF VT'BREAK THEN                                            08180000
               UNIMPEDE'NEXT'PROCESS                                    08185000
            ELSE                                                        08190000
               BEGIN  ! Create the break queue.                         08195000
               VT'CONTROL   := %040000;! Set break bit.                 08200000
               VT'PIN := 0;            ! Clear current PIN.    << 8466>>08205000
               VT'SAVEQ'HEAD := VT'QHEAD;! Save in low Q.               08210000
               VT'SAVEQ'TAIL := VT'QTAIL;                               08215000
               VT'QHEAD := 0;          ! Set high Q empty.              08220000
               VT'QTAIL := 0;                                           08225000
               END;                                                     08230000
            END                                                         08235000
         ELSE                                                           08240000
            BEGIN     ! Unimpede the next process.                      08245000
            IF FUNBREAK'MODE THEN                                       08250000
               BEGIN  ! Destroy break queue.                            08255000
               VT'BREAK'BIT := 0;                                       08260000
               IF VT'SAVEQ'HEAD <> 0 THEN                               08265000
                  BEGIN  ! Must shuffle the Q's.                        08270000
                  IF VT'QHEAD = 0 THEN                                  08275000
                     BEGIN   ! Place low Q in normal Q.                 08280000
                     VT'QHEAD := VT'SAVEQ'HEAD;                         08285000
                     VT'QTAIL := VT'SAVEQ'TAIL;                         08290000
                     END                                                08295000
                  ELSE                                                  08300000
                     BEGIN   ! Merge the two Q's together.              08305000
                     PCBPT := VT'QTAIL;                                 08310000
                     SPCBNIMPPIN := VT'SAVEQ'HEAD;                      08315000
                     VT'QTAIL := VT'SAVEQ'HEAD;                         08320000
                     END;                                               08325000
                  VT'SAVEQ'HEAD := 0; ! Mark low prio Q                 08330000
                  VT'SAVEQ'TAIL := 0; ! empty.                          08335000
                  END;                                                  08340000
               END;   ! FUNBREAK mode.                                  08345000
            UNIMPEDE'NEXT'PROCESS;                                      08350000
            END;      ! Unimpede the next process.                      08355000
      END;        ! Possibly last access by us.                         08360000
                                                                        08365000
   ! Now copy vector entry back and P-enable thyself.                   08370000
                                                                        08375000
   UNLOC'VTENTRY;                                                       08380000
   PSEUDOENABLE;                                                        08385000
   END;     ! procedure UNLOCK'CB                                       08390000
$PAGE  " LOCACB - Definitions and Subroutines "                         08395000
$CONTROL SEGMENT=FILESYS1A                                              08400000
PROCEDURE LOC'ACB(DSTX,DQ,FILENUM,FLAGS,FMAVT'SIR,A);                   08405000
VALUE DSTX,FILENUM,DQ,FLAGS,FMAVT'SIR,A;                                08410000
LOGICAL FLAGS;                                                          08415000
INTEGER DSTX,FILENUM,DQ,FMAVT'SIR,A;                                    08420000
OPTION PRIVILEGED,UNCALLABLE,VARIABLE;                                  08425000
                                                                        08430000
BEGIN                                                                   08435000
! VT array must be at Q+1 unless VTMQ equate is changed.                08440000
INTEGER ARRAY VT(0:VTENTRY-1) = Q;                                      08445000
EQUATE VTMQ = 1;     ! Q-relative offset to VT array.                   08450000
LOGICAL PMAP = Q-4;  ! Parameter map.                                   08455000
INTEGER                                                                 08460000
   PCBPT,            ! Pointer to PCB for defines.                      08465000
   STACKDST,         ! DST number of our stack.                         08470000
   CB'FLAGS,         ! FLAGS parm sent to LOCK'CB.                      08475000
   PCBGLOBLOC,       ! Q-rel offset to PCBX GLOBAL area.                08480000
   Q'REL'DL,         ! Q-rel offset to DL.                              08485000
   Q'REL'PXFILE,     ! Q-rel offset to PCBX FILE area.                  08490000
   PXCBT'OFFSET,     ! Offset to PX CB area in our stack.               08495000
   GLOBAL'AFT'SIZE,  ! Size of global AFT DST.                          08500000
   AFT'OFFSET;       ! Offset into AFT of our entry.                    08505000
DOUBLE                                                                  08510000
   PACBV;            ! Vector for LOCK'CB.                              08515000
DEFINE                                                                  08520000
   PRIV'MODE   =  FLAGS.(0:1)#,                                         08525000
   ACB'BUFX    =  LQ0(DQ+31)#,                                          08530000
   COND'LOCK   =  PMAP.(14:2) = 3#;                                     08535000
EQUATE                                                                  08540000
   NULL'FILE   =  CCG,                                                  08545000
   BAD'FILENUM =  CCL,                                                  08550000
   PRIV'VIOL   =  CCL,                                                  08555000
   OK          =  CCE;                                                  08560000
                                                                        08565000
                                                                        08570000
                                                                        08575000
                                                                        08580000
                                                                        08585000
                                                                        08590000
SUBROUTINE EXIT(CC');                                                   08595000
VALUE CC';                                                              08600000
INTEGER CC';                                                            08605000
BEGIN                                                                   08610000
CONDCODE := CC';                                                        08615000
ASMB(EXIT 6);       ! Leave DSTX on TOS for caller.                     08620000
END;                                                                    08625000
                                                                        08630000
                                                                        08635000
                                                                        08640000
SUBROUTINE RELEASE'SIR;                                                 08645000
                                                                        08650000
!-------------------------------------------------------------          08655000
! If we must impede on the ACB when calling LOCK'CB, then               08660000
! release the FMAVT Sir before impeding and then reaqure   ire          08665000
! the SIR back. We are P-Disabled until we impede.                      08670000
!-------------------------------------------------------------          08675000
                                                                        08680000
BEGIN                                                                   08685000
RELSIR(FMAVT'SIR,A);              ! Release SIR.                        08690000
IMPEDE(0);                        ! Go to sleep.                        08695000
GETSIR(FMAVT'SIR);                ! Re-aquire the SIR.                  08700000
END;                                                                    08705000
$PAGE                                                                   08710000
SUBROUTINE LOC'VTENTRY(CB'TYPE);                                        08715000
VALUE CB'TYPE;                                                          08720000
INTEGER CB'TYPE;                                                        08725000
                                                                        08730000
!-------------------------------------------------------------          08735000
! Locates the vector table entry of the PACB or LACB of the             08740000
! file.  Copies the entry to the VT Q-relative array.                   08745000
!-------------------------------------------------------------          08750000
                                                                        08755000
BEGIN                                                                   08760000
IF CB'TYPE = CBPACB THEN                                                08765000
   BEGIN                      ! Get info from AFT PACB words.           08770000
   TOS := STACKDST;           ! Target DST, our stack.                  08775000
   TOS := VTMQ - PCBGLOBLOC;  ! Stack rel. offset to VT array.          08780000
   TOS := ACBM'PACBV'DSTN;    ! PACB DST number.                        08785000
   TOS := ACBM'PACBV'ENTRY;   ! CBT rel. offset to VT entry.            08790000
   END                                                                  08795000
ELSE                                                                    08800000
   BEGIN                      ! Get info from AFT LACB words.           08805000
   TOS := STACKDST;           ! Target DST, our stack.                  08810000
   TOS := VTMQ - PCBGLOBLOC;  ! Stack rel. offset to VT array.          08815000
   TOS := ACBM'LACBV'DSTN;    ! LACB DST number.                        08820000
   TOS := ACBM'LACBV'ENTRY;   ! CBT rel. offset to VT entry.            08825000
   END;                                                                 08830000
IF S1 = STACKDST THEN         ! Add PXCBT offset if the CB              08835000
   TOS := TOS + PXCBT'OFFSET; ! resides in our stack.                   08840000
TOS := VTENTRY;               ! Size of a VT entry.                     08845000
MOVE'DS'5;                    ! Off they go!                            08850000
END;                                                                    08855000
                                                                        08860000
SUBROUTINE LOC'GLOBAL'AFT;                                              08865000
                                                                        08870000
!-------------------------------------------------------------          08875000
! Locate the global AFT entry and copy it to the users ACB-             08880000
! AFT area.  Check to make sure that the file number is not             08885000
! out of bounds.                                                        08890000
!-------------------------------------------------------------          08895000
                                                                        08900000
BEGIN                                                                   08905000
IF NOT PRIV'MODE THEN                                          <<*8806>>08910000
   EXIT(BAD'FILENUM);  << Must be priv to use global files >>  <<*8806>>08915000
IF GLOBAL'AFT'DSTN = 0                                                  08920000
   THEN EXIT(BAD'FILENUM);                                              08925000
AFT'OFFSET := \FILENUM\ * AFTENTRY;                                     08930000
GLOBAL'AFT'SIZE := DST'SIZE(GLOBAL'AFT'DSTN);                  << 7972>>08935000
IF NOT(AFT'OFFSET+AFTENTRY <= GLOBAL'AFT'SIZE)                          08940000
   THEN EXIT(BAD'FILENUM);                                              08945000
                                                                        08950000
! Now copy the AFT into the callers ACB-AFT area.                       08955000
                                                                        08960000
TOS := STACKDST;          ! Copying to our stack.                       08965000
TOS := ACBX'ACBOFFSET - AFTENTRY;                                       08970000
TOS := GLOBAL'AFT'DSTN;   ! Get from global AFT.                        08975000
TOS := AFT'OFFSET;                                                      08980000
TOS := AFTENTRY;          ! AFT entry size.                             08985000
MOVE'DS'5;                ! They are here!                              08990000
END;                                                                    08995000
                                                                        09000000
                                                                        09005000
                                                                        09010000
                                                                        09015000
                                                                        09020000
                                                                        09025000
SUBROUTINE LOC'LOCAL'AFT;                                               09030000
                                                                        09035000
!-------------------------------------------------------------          09040000
! Copies a normal AFT into the callers ACB-AFT area and                 09045000
! performs all types of checking on the AFT entry.                      09050000
!-------------------------------------------------------------          09055000
                                                                        09060000
BEGIN                                                                   09065000
AFT'OFFSET := FILENUM*AFTENTRY;                                         09070000
IF NOT(AFTENTRY <= AFT'OFFSET <= QPXFAFTSIZE) OR                        09075000
   FILENUM <= 2 AND NOT PRIV'MODE                              <<*7847>>09080000
   THEN EXIT(BAD'FILENUM);                                              09085000
                                                                        09090000
! Now copy the AFT into the callers ACB-AFT entry.                      09095000
                                                                        09100000
TOS := STACKDST;          ! Copying to our stack.                       09105000
TOS := ACBX'ACBOFFSET - AFTENTRY;                                       09110000
TOS := STACKDST;          ! From our AFT in the stack.                  09115000
TOS := PXG'RELATIVE'DL - AFT'OFFSET - 4;                                09120000
TOS := AFTENTRY;          ! AFT entry size.                             09125000
MOVE'DS'5;                ! They are here.                              09130000
                                                                        09135000
!-------------------------------------------------------------          09140000
! Check for legal file types, FS, RF, KS or MSG.  The TBC               09145000
! instruction is done for speed.                                        09150000
!-------------------------------------------------------------          09155000
                                                                        09160000
X := ACBM'AFTTYPE;          ! Check against AFT type.                   09165000
TOS := LEGAL'FTYPES;        ! Bit mask of legal file types.             09170000
ASMB(TBC 0,X);DEL;          ! Test the bit and delete word.             09175000
IF = THEN EXIT(BAD'FILENUM);! Legal file type?                          09180000
END;                                                                    09185000
$PAGE "LOC'ACB - Outer block "                                          09190000
   ! Make DQ relative to our Q and obtain DB information.               09195000
                                                                        09200000
   DQ := DQ - DELTAQ;                                                   09205000
   PCBPT := CURPRC;                                                     09210000
   STACKDST := SPCBSTKDST;                                              09215000
   DSTX := SPCBXDSDST;                                                  09220000
                                                                        09225000
   !----------------------------------------------------------          09230000
   ! Now, obtain Q rel. offset to DL and stack offset to                09235000
   ! Q+0.  Also, set the Q-rel offset to PXFILE to obtain               09240000
   ! AFTSIZE.  Then, set two ACB extension variables.                   09245000
   !----------------------------------------------------------          09250000
                                                                        09255000
   PXGLOBAL;         ! Sets PCBGLOBLOC, see declaration.                09260000
   Q'REL'DL         := PXG'RELATIVE'DL + PCBGLOBLOC;                    09265000
   Q'REL'PXFILE     := Q'REL'DL - AQM3(Q'REL'DL);                       09270000
   PXCBT'OFFSET     := (Q'REL'PXFILE-PCBGLOBLOC)+PXFOVERHEAD;           09275000
   ACBX'DBOFFSET    := PXG'RELATIVE'DB; ! Stack-rel to DB.              09280000
   ACBX'ACBOFFSET   := DQ - PCBGLOBLOC; ! Stack rel to PACB             09285000
                                                                        09290000
   ! Find and copy the AFT, could be global or normal.                  09295000
                                                                        09300000
   IF GLOBAL'FILENUM                                                    09305000
      THEN LOC'GLOBAL'AFT                                               09310000
      ELSE LOC'LOCAL'AFT;                                               09315000
                                                                        09320000
   !----------------------------------------------------------          09325000
   ! Check for NULL file and then open file.  Finally, if               09330000
   ! this is a KSAM or REMOTE file, then we are all done.               09335000
   !----------------------------------------------------------          09340000
                                                                        09345000
   IF ACBM'AFTNULL                                                      09350000
      THEN EXIT(NULL'FILE);      ! NULL file, all done.                 09355000
   IF ACBM'PACBV'DSTN = 0                                               09360000
      THEN EXIT(BAD'FILENUM);    ! File was not FOPENed.                09365000
   IF ACBM'KSTYPE OR ACBM'RFTYPE                                        09370000
      THEN EXIT(OK);                                                    09375000
                                                                        09380000
   TOS   := ACBM'PACBV'DSTN;                                            09385000
   TOS   := ACBM'PACBV'ENTRY;                                           09390000
   PACBV := TOS;   ! Create double word vector for LOCK'CB.             09395000
                                                                        09400000
   ! Now, if the file was opened Multi-access (LACB exists)             09405000
   ! then copy the LACB to stack ACB and lock the ACB.                  09410000
                                                                        09415000
   IF ACBM'LACBV'DSTN <> 0 THEN                                         09420000
      BEGIN                                                             09425000
      LOC'VTENTRY(CBLACB);                                              09430000
      TOS := STACKDST;           ! Copying to our stack.                09435000
      TOS := ACBX'ACBOFFSET;     ! DST-rel @ACB on stack.               09440000
      TOS := ACBM'LACBV'DSTN;                                           09445000
      TOS := VT'ADR;             ! CBTAB address of LACB.               09450000
      IF ACBM'LACBV'DSTN = STACKDST ! Add offset if in stk.             09455000
         THEN TOS := TOS + PXCBT'OFFSET;                                09460000
      ACBX'LACBOFFSET := S0;     ! Save LACB DST-rel offset             09465000
      TOS := SIZELACB;                                                  09470000
      MOVE'DS'5;                 ! Copy LACB.                           09475000
                                                                        09480000
      ! Now call LOCK'CB to really lock the ACB and set up              09485000
      ! MDS parms.  Set up FLAGS word for LOCK'CB.                      09490000
                                                                        09495000
      CB'FLAGS := FLAGS.(1:15);  ! Clear PM bit.                        09500000
      IF COND'LOCK THEN                                                 09505000
         CB'FLAGS.(1:1) := 1;    ! Lock CB conditionally.               09510000
      LOCK'CB(CB'FLAGS,STACKDST,DQ+SIZELACB,PACBV);                     09515000
      IF CARRY THEN                                                     09520000
         RELEASE'SIR;            ! Don't impede with SIR.               09525000
                                                                        09530000
      ACBX'PACBOFFSET := S0;     ! LOCK'CB gave us @PACB.               09535000
      TOS := TOS + SIZELACB;     ! Start past LACB.                     09540000
      TOS := SIZEMRPACB;         ! Copy non LACB part.                  09545000
      MOVE'DS'6;                 ! Copy PACB and pop FLAGS.             09550000
                                                                        09555000
      IF ACB'PRIV AND NOT PRIV'MODE THEN                                09560000
         BEGIN  ! Non priv access to a priv file.                       09565000
         UNLOCK'CB(FLAGS,PACBV);                                        09570000
         EXIT(PRIV'VIOL);                                               09575000
         END;                                                           09580000
      END                                                               09585000
   ELSE                                                                 09590000
                                                                        09595000
      !-------------------------------------------------------          09600000
      ! Only the PACB needs to be copied.  We don't have                09605000
      ! to lock the ACB unless this is a global file.                   09610000
      !-------------------------------------------------------          09615000
                                                                        09620000
      BEGIN                                                             09625000
      ACBX'LACBOFFSET := 0;      ! LACB does not exist.                 09630000
      LOC'VTENTRY(CBPACB);                                              09635000
      TOS := STACKDST;           ! Copying to our stack.                09640000
      TOS := ACBX'ACBOFFSET;     ! Stack rel. addr. of ACB.             09645000
      TOS := ACBM'PACBV'DSTN;                                           09650000
      TOS := VT'ADR;             ! CBTAB address of PACB.               09655000
      IF ACBM'PACBV'DSTN = STACKDST ! Add offset if in stk.             09660000
         THEN TOS := TOS + PXCBT'OFFSET;                                09665000
      ACBX'PACBOFFSET := S0;     ! Save DST rel @PACB.                  09670000
      TOS := SIZEACB;            ! Copy full PACB size.                 09675000
      MOVE'DS'5;                                                        09680000
                                                                        09685000
      IF ACB'PRIV AND NOT PRIV'MODE THEN                                09690000
         EXIT(PRIV'VIOL);                                               09695000
      IF GLOBAL'FILENUM                                                 09700000
         THEN LOCK'CB(0,STACKDST,DQ,PACBV);                             09705000
      ASSEMBLE(SUBS 6);          ! Don't need return parms.             09710000
      END;                                                              09715000
                                                                        09720000
   EXIT(OK);                     ! A-OK, rip this joint.                09725000
END;                             ! LOC'ACB                              09730000
$PAGE  " UNLOC'ACB "                                                    09735000
$CONTROL SEGMENT = FILESYS1A  ! UNLOC'ACB                               09740000
                                                                        09745000
PROCEDURE UNLOC'ACB(DQ,FLAGS);                                          09750000
                                                                        09755000
!-------------------------------------------------------------          09760000
! This procedure releases the ACB by storing the contents into          09765000
! the  PACB and into the LACB (if it exists).  The PACB is un-          09770000
! locked  by UNLOCK'CB  and all the FLAGS stuff is done by it.          09775000
! This procedure can only be called if LOC'ACB reported a con-          09780000
! ventional or  message  file since we obtain all our informa-          09785000
! tion  from  the ACB extention. For all global file accesses,          09790000
! we  previously locked the ACB, even if the file was not mul-          09795000
! ti-access.  Therefore, always unlock a global access file.            09800000
!                                                                       09805000
!   FLAGS is only used for $STDIN, which is always open                 09810000
!   multi-access.                                                       09815000
!                                                                       09820000
!   Input variables:                                                    09825000
!       DQ - Caller's Q-relative address of his ACB.                    09830000
!       FLAGS - Flag word                                               09835000
!          (12:1) - Do not unlock the PACB.  Called by                  09840000
!                   FCLOSE because DELACB will do the un-               09845000
!                   locking for him.                                    09850000
!          (13:1) - Destroy Break queue, FUNBREAK call.                 09855000
!          (14:1) - Create Break queue, called by IOMOVE                09860000
!                   for $STDIN from a terminal.                         09865000
!-------------------------------------------------------------          09870000
                                                                        09875000
VALUE DQ,FLAGS;                                                         09880000
INTEGER DQ;                                                             09885000
LOGICAL FLAGS;                                                          09890000
OPTION PRIVILEGED,UNCALLABLE;                                           09895000
                                                                        09900000
   BEGIN                                                                09905000
   INTEGER                                                              09910000
      PCBPT,                ! Pointer to PCB for defines.               09915000
      STACKDST,             ! DST number of our stack.                  09920000
      PCBGLOBLOC;           ! Q-rel offset to PCBX GLOBAL.              09925000
   DOUBLE                                                               09930000
      PACBV;                ! Used for LOCK'CB.                         09935000
   DEFINE                                                               09940000
      UNLOCK'REQUESTED = (NOT FLAGS.(12:1))#,                           09945000
      ACB'GLOBAL'FILE  = (AQ0(DQ+1) < 0)   #;                           09950000
                                                                        09955000
   PCBPT := CURPRC;                                                     09960000
   STACKDST := SPCBSTKDST;                                              09965000
   DQ := DQ-DELTAQ;         ! Make DQ relative to our Q.                09970000
                                                                        09975000
   !----------------------------------------------------------          09980000
   ! Recalculate following two values since it is indeed poss-          09985000
   ! ible  for  PXFILE  to have been expanded for FOPEN, since          09990000
   ! FOPEN  is  now  called  by  LYNXII  drivers  for  certain          09995000
   ! FCONTROL functions.                                                10000000
   !----------------------------------------------------------          10005000
                                                                        10010000
   PXGLOBAL;                                                            10015000
   ACBX'DBOFFSET := PXG'RELATIVE'DB;                                    10020000
   ACBX'ACBOFFSET := DQ - PCBGLOBLOC;                                   10025000
                                                                        10030000
   !----------------------------------------------------------          10035000
   ! If the LACB exists, copy it back only the part that could          10040000
   ! possibly change.                                                   10045000
   !----------------------------------------------------------          10050000
                                                                        10055000
   IF ACBM'LACBV'DSTN <> 0 THEN                                         10060000
      BEGIN                                                             10065000
      TOS := ACBM'LACBV'DSTN;                                           10070000
      TOS := ACBX'LACBOFFSET+SIZENOWR;                                  10075000
      TOS := STACKDST;                                                  10080000
      TOS := ACBX'ACBOFFSET+SIZENOWR;                                   10085000
      TOS := SIZELACBWR;                                                10090000
      MOVE'DS'5;                                                        10095000
                                                                        10100000
      ! Copy back parts of the PACB that could change.                  10105000
                                                                        10110000
      TOS := ACBM'PACBV'DSTN;                                           10115000
      TOS := ACBX'PACBOFFSET+SIZENOWR;                                  10120000
      TOS := STACKDST;                                                  10125000
      TOS := ACBX'ACBOFFSET+SIZENOWR;                                   10130000
      TOS := SIZEPACBWR;                                                10135000
      MOVE'DS'5;                                                        10140000
                                                                        10145000
      ! Now actually unlock the ACB and do FLAGS stuff.                 10150000
                                                                        10155000
      IF UNLOCK'REQUESTED THEN                                          10160000
         BEGIN                                                          10165000
         TOS := ACBM'PACBV'DSTN;                                        10170000
         TOS := ACBM'PACBV'ENTRY;                                       10175000
         PACBV := TOS;      ! Set double word PACB.                     10180000
         UNLOCK'CB(FLAGS,PACBV);                                        10185000
         END;                                                           10190000
      END                                                               10195000
   ELSE                                                                 10200000
                                                                        10205000
      ! No LACB, just copy parts of PACB that could change.             10210000
                                                                        10215000
      BEGIN                                                             10220000
      TOS := ACBM'PACBV'DSTN;                                           10225000
      TOS := ACBX'PACBOFFSET+SIZENOWR;                                  10230000
      TOS := STACKDST;                                                  10235000
      TOS := ACBX'ACBOFFSET+SIZENOWR;                                   10240000
      TOS := SIZEPACBWR;                                                10245000
      MOVE'DS'5;                                                        10250000
      IF ACB'GLOBAL'FILE THEN                                           10255000
         BEGIN                                                          10260000
         TOS := ACBM'PACBV'DSTN;                                        10265000
         TOS := ACBM'PACBV'ENTRY;                                       10270000
         PACBV := TOS;      ! Set double word PACB.                     10275000
         UNLOCK'CB(0,PACBV);                                            10280000
         END;                                                           10285000
      END;                                                              10290000
   END;      ! of UNLOC'ACB                                             10295000
$PAGE " POST'ACB'ERROR "                                       <<04558>>10300000
$CONTROL SEGMENT = FILESYS1A  <<POST'ACB'ERROR>>               <<02702>>10305000
PROCEDURE POST'ACB'ERROR(FILENUM,THEIRSTATUS,ERROR);           <<02702>>10310000
  VALUE FILENUM,THEIRSTATUS,ERROR;                             <<02702>>10315000
  INTEGER FILENUM,ERROR;                                       <<02702>>10320000
  LOGICAL THEIRSTATUS;                                         <<02702>>10325000
  OPTION PRIVILEGED,UNCALLABLE;                                <<02702>>10330000
<< this procedure calls LOC'ACB                              >><<02702>>10335000
<< to put an error into the acb.                             >><<02702>>10340000
BEGIN                                                          <<02702>>10345000
                                                               <<02702>>10350000
                                                               <<06511>>10355000
  INTEGER ACBMQ;                                               <<06511>>10360000
                                                               <<02702>>10365000
  <<the following loc'acb params must be last and in order>>   <<02702>>10370000
  INTEGER AFTE;                                                <<02702>>10375000
  DOUBLE  PACBV;                                               <<06511>>10380000
  DOUBLE  LACBV;                                               <<06511>>10385000
  INTEGER IOQX;                                                <<02702>>10390000
  INTEGER ARRAY ACB(0:SIZEXACB-1) = Q; << q + acbmq >>         <<02702>>10395000
  DOUBLE ARRAY ACBDBL(*)=ACB;                                  <<02702>>10400000
  << build'acb >>                                              <<02702>>10405000
  INTEGER ACB'ERROR = ACB + 14;                                <<02702>>10410000
  LOGICAL DSTX;                                                <<02702>>10415000
  <<end of loc'acb params >>                                   <<02702>>10420000
  GET'ACB'Q'LOC;                                               <<06511>>10425000
  LOC'ACB(*,ACBMQ,FILENUM,THEIRSTATUS);                        <<02702>>10430000
  IF <> THEN FTROUBLE(455);                                    <<02702>>10435000
  ACB'ERROR:=ERROR;                                            <<02702>>10440000
  UNLOC'ACB(ACBMQ,0);                                          <<02702>>10445000
END;                                                           <<02702>>10450000
$PAGE " FBNDVIOL "                                             <<04558>>10455000
$CONTROL SEGMENT = FILESYS1A  << FBNDVIOL >>                            10460000
LOGICAL PROCEDURE FBNDVIOL(TARGET,WC,UBND);                             10465000
COMMENT                                                                 10470000
     This procedure bounds-checks the user's buffer.  It is used        10475000
when the buffer is a word address but the size can be either            10480000
words(+) or bytes (-).  If the buffer can be a byte address,            10485000
use FBNDCHK instead.                                                    10490000
                                                                        10495000
     Input variables:                                                   10500000
         TARGET - user's buffer address (words)                         10505000
         WC   - user's specified word or byte count                     10510000
         UBND - upper word bound, for bounds check                      10515000
                relative to caller's Q register                <<03059>>10520000
                (a small negative number)                      <<03059>>10525000
                                                                        10530000
     Output variables: FBNDVIOL - True if out of bounds.                10535000
                                                                        10540000
     DB is assumed to be set to the data segment                        10545000
     containing the user's buffer.  ;                                   10550000
                                                                        10555000
VALUE TARGET,UBND,WC;                                                   10560000
INTEGER TARGET,UBND,WC;                                                 10565000
OPTION PRIVILEGED,UNCALLABLE;                                           10570000
                                                                        10575000
   BEGIN                                                                10580000
   INTEGER PCBPT;                                              <<06511>>10585000
   INTEGER DSTX;                                                        10590000
   INTEGER DELTAQ=Q-0;                                         <<03059>>10595000
                                                                        10600000
   IF WC < 0 THEN                                                       10605000
      WC := (1-WC)&LSR(1);    << make pos. words >>                     10610000
   PCBPT := CURPRC;                                            <<06511>>10615000
   DSTX := SPCBXDSDST;      << User's buffer DST >>            <<06511>>10620000
   IF DSTX <> 0 THEN                                           <<06511>>10625000
      BEGIN     << DB at extra data segment. >>                         10630000
      TOS := 0;  << lower bound >>                                      10635000
      TOS := DST'(DSTX&LSL(2)).(3:13)&LSL(2)-WC;   <<UB>>               10640000
      END                                                               10645000
   ELSE                                                                 10650000
      BEGIN        << DB at stack. >>                                   10655000
      IF UBND >= 0 THEN                                        <<03059>>10660000
        BEGIN                                                  <<03059>>10665000
        <<Some pre-ICF/55 code has called with a DB relative>> <<03059>>10670000
        <<rather than Q relative address.  Catch it.>>         <<03059>>10675000
        FBNDVIOL := TRUE;                                      <<03059>>10680000
        RETURN;                                                <<03059>>10685000
        END;                                                   <<03059>>10690000
      PUSH(DL);     << lower word bound >>                              10695000
      TOS := @DELTAQ-DELTAQ+UBND-WC+1; << upper word bound>>   <<03059>>10700000
      END;                                                              10705000
   X := TARGET;                                                         10710000
   IF NOT(TOS <= X <= TOS) THEN                                         10715000
      FBNDVIOL := TRUE;    << Bounds violation. Boo! >>                 10720000
                                                                        10725000
   END;      << procedure FBNDVIOL >>                                   10730000
$PAGE   " PUT'ACB'INFO "                                       <<04700>>10735000
$CONTROL SEGMENT=FILESYS1A                                     <<04700>>10740000
PROCEDURE PUT'ACB'INFO(FILE'NUM,ITEM'NUM,ITEM);                <<04700>>10745000
VALUE FILE'NUM,ITEM'NUM,ITEM;                                  <<04700>>10750000
INTEGER FILE'NUM,ITEM'NUM,ITEM;                                <<04700>>10755000
OPTION UNCALLABLE,PRIVILEGED;                                  <<04700>>10760000
                                                               <<04700>>10765000
<<**********************************************************>> <<04700>>10770000
<< This procedure is used by our friends at DS to place cer->> <<04700>>10775000
<< tain items in the ACB.                                   >> <<04700>>10780000
<<                                                          >> <<04700>>10785000
<< Input variables:                                         >> <<04700>>10790000
<<    FILE'NUM - File number for which to use.              >> <<04700>>10795000
<<    ITEM'NUM - Number specifying the particular ACB item  >> <<04700>>10800000
<<               in which to replace.  The following values >> <<04700>>10805000
<<               are legal:                                 >> <<04700>>10810000
<<                                                          >> <<04700>>10815000
<<               1 - ACB'ERROR                              >> <<04700>>10820000
<<               2 - ACB'DADDR                              >> <<04700>>10825000
<<                                                          >> <<04700>>10830000
<<    ITEM     - The item to place in the ACB location.     >> <<04700>>10835000
<<                                                          >> <<04700>>10840000
<< Condition Codes:                                         >> <<04700>>10845000
<<    CCE - Everything is A-OK.                             >> <<04700>>10850000
<<    CCL - Invalid file number or invalid item number.     >> <<04700>>10855000
<<    CCG - File is $NULL file.                             >> <<04700>>10860000
<< DB can be set to anywhere upon entrance.                 >> <<04700>>10865000
<<**********************************************************>> <<04700>>10870000
                                                               <<04700>>10875000
BEGIN                                                          <<04700>>10880000
                                                               <<04700>>10885000
<< ACB declarations must be in order!                       >> <<04700>>10890000
                                                               <<06511>>10895000
INTEGER ACBMQ;    << Q-relative offset to our ACB.          >> <<06511>>10900000
INTEGER AFTE;     << Word 0 of the AFT.                     >> <<06511>>10905000
DOUBLE PACBV;     << Physical Access Control Block Vector.  >> <<06511>>10910000
DOUBLE LACBV;     << Logical    "       "     "       "     >> <<06511>>10915000
INTEGER IOQX;     << I/O Queue Index.                       >> <<06511>>10920000
INTEGER ARRAY ACB(0:SIZEXACB - 1) = Q;                         <<04700>>10925000
INTEGER                                                        <<04700>>10930000
   DSTX;        << Users current DB DST.                    >> <<04700>>10935000
BUILD'ACB;      << Define, declares ACB variables.          >> <<04700>>10940000
                                                               <<04700>>10945000
<< Check for legal item number.                             >> <<04700>>10950000
                                                               <<04700>>10955000
CONDCODE := CCE;            << Assume successful completion.>> <<04700>>10960000
IF ITEM'NUM < 1 OR ITEM'NUM > 2 THEN                           <<04700>>10965000
   CONDCODE := CCL                                             <<04700>>10970000
ELSE                                                           <<04700>>10975000
   BEGIN                                                       <<04700>>10980000
   GET'ACB'Q'LOC;        << Obtain Q-relative loc. of ACB.  >> <<04700>>10985000
   LOC'ACB(0,ACBMQ,FILE'NUM,UMODE);                            <<04700>>10990000
   DSTX := TOS;          << LOC'ACB returns DSTX on TOS.    >> <<04700>>10995000
   IF < THEN                                                   <<04700>>11000000
      CONDCODE := CCL    << Invalid file number.            >> <<04700>>11005000
   ELSE IF > THEN                                              <<04700>>11010000
      CONDCODE := CCG    << $NULL.                          >> <<04700>>11015000
   ELSE IF NOT FSTYPE AND NOT MSGTYPE THEN                     <<04766>>11020000
      CONDCODE := CCG    << Not a legal file type.          >> <<04766>>11025000
   ELSE                                                        <<04700>>11030000
      BEGIN              << OK, place item in proper loc.   >> <<04700>>11035000
      ITEM'NUM := ITEM'NUM - 1;  << CASE starts at 0.       >> <<04700>>11040000
      CASE ITEM'NUM OF                                         <<04700>>11045000
           BEGIN                                               <<04700>>11050000
                                                               <<04700>>11055000
           <<  1  >>                                           <<04700>>11060000
           ACB'ERROR := ITEM;                                  <<04700>>11065000
           <<  1  >>                                           <<04700>>11070000
                                                               <<04700>>11075000
           <<  2  >>                                           <<04700>>11080000
           ACB'DADDR := ITEM;                                  <<04700>>11085000
           <<  2  >>                                           <<04700>>11090000
                                                               <<04700>>11095000
           END;                                                <<04700>>11100000
       UNLOC'ACB(ACBMQ,0);                                     <<04700>>11105000
       END;                                                    <<04700>>11110000
   END;                                                        <<04700>>11115000
                                                               <<04700>>11120000
END;   << PROCEDURE PUT'ACB'INFO                            >> <<04700>>11125000
$PAGE " GETFCB'INFO "                                          <<04558>>11130000
$ CONTROL SEGMENT = FILESYS1A  << GETFCB'INFO >>                        11135000
DOUBLE PROCEDURE GETFCB'INFO(FCBV, ITEM);                               11140000
VALUE FCBV, ITEM;                                                       11145000
INTEGER ITEM;                                                  <<06511>>11150000
DOUBLE FCBV;                                                   <<06511>>11155000
OPTION PRIVILEGED,UNCALLABLE;                                           11160000
                                                               <<04558>>11165000
<<**********************************************************>> <<04558>>11170000
<< GETFCB'INFO returns as its value two words from an FCB   >> <<04558>>11175000
<< from the desired FCB word offset.                        >> <<04558>>11180000
<<                                                          >> <<04558>>11185000
<< Input Variables:                                         >> <<04558>>11190000
<<    FCBV - The File Control Block Vector.                 >> <<04558>>11195000
<<    ITEM - The word offset into the FCB in which to start >> <<04558>>11200000
<<           the two word transfer.                         >> <<04558>>11205000
<<                                                          >> <<04558>>11210000
<< Output Variables:                                        >> <<04558>>11215000
<<    GETFCB'INFO - The two words retieved from the FCB     >> <<04558>>11220000
<<                  starting at ITEM.                       >> <<04558>>11225000
<<                                                          >> <<04558>>11230000
<< Copy the 2 words to Q-8, the return parameter location,  >> <<06511>>11235000
<< using the parameters returned from LOCK'CB.  The FCB is  >> <<04558>>11240000
<< locked via the "quick lock" mode.  If FLAG is returned   >> <<04558>>11245000
<< true, then we must explicitly unlock the FCB, otherwise  >> <<04558>>11250000
<< we simply P-Disable ourselves and return.                >> <<04558>>11255000
<<**********************************************************>> <<04558>>11260000
                                                               <<04558>>11265000
                                                                        11270000
   BEGIN                                                                11275000
   LOCK'CB(8,0,-8,FCBV);                << quick lock >>       <<06511>>11280000
   TOS := TOS+ITEM;       << source offset into FCB >>                  11285000
   TOS := 2;                                                            11290000
   MOVE'DS'5;    << move data to GETFCB'INFO return >>                  11295000
   IF LOGICAL(TOS)                                             <<06511>>11300000
      THEN UNLOCK'CB(0,FCBV)      << Quick lock failed.     >> <<06511>>11305000
      ELSE PSEUDOENABLE;         << Quick lock succeeded.   >> <<06511>>11310000
   END;      << procedure GETFCB'INFO >>                                11315000
$PAGE " PUTFCB'INFO "                                          <<04562>>11320000
$CONTROL SEGMENT=FILESYS1A                                     <<04562>>11325000
                                                               <<04562>>11330000
PROCEDURE PUTFCB'INFO(FCBV,OFFSET,ITEM);                       <<04562>>11335000
VALUE FCBV,OFFSET,ITEM;                                        <<04562>>11340000
INTEGER OFFSET;                                                <<06511>>11345000
DOUBLE FCBV;                                                   <<06511>>11350000
DOUBLE ITEM;                                                   <<04562>>11355000
OPTION PRIVILEGED,UNCALLABLE;                                  <<04562>>11360000
                                                               <<04562>>11365000
<<**********************************************************>> <<04562>>11370000
<< This procedure transfers a double word into the FCB at a >> <<04562>>11375000
<< desired location.  It is used by STORE/RESTORE and IOMOVE>> <<04562>>11380000
<< to update the EOF in the FCB.                            >> <<04562>>11385000
<<                                                          >> <<04562>>11390000
<< Input variables:                                         >> <<04562>>11395000
<<    FCBV   - FCB vector.                                  >> <<04562>>11400000
<<    OFFSET - The word offset into the FCB in which to     >> <<04562>>11405000
<<             start the transfer.                          >> <<04562>>11410000
<<    ITEM   - The double word item to transfer.            >> <<04562>>11415000
<<                                                          >> <<04562>>11420000
<< Transfer the ITEM from Q-5 to the FCB offset.            >> <<04562>>11425000
<<**********************************************************>> <<04562>>11430000
                                                               <<04562>>11435000
BEGIN                                                          <<04562>>11440000
                                                               <<04562>>11445000
DOUBLE                                                         <<04562>>11450000
   SOURCE'WORDS,           << Bank and address of ITEM.     >> <<04562>>11455000
   TARGET'WORDS;           << Bank and address of FCB words.>> <<04562>>11460000
INTEGER                                                        <<04562>>11465000
   TARGET'ADDR=TARGET'WORDS + 1;                               <<04562>>11470000
LOGICAL                                                        <<04562>>11475000
   LOCKED;                  << True if quick lock failed.   >> <<04562>>11480000
EQUATE                                                         <<04562>>11485000
   QUICK'LOCK      = %(2)1000,                                 <<04562>>11490000
   Q'REL'LOC'ITEM  = -5;                                       <<04562>>11495000
                                                               <<04562>>11500000
LOCK'CB(QUICK'LOCK,0,Q'REL'LOC'ITEM,FCBV);                     <<06511>>11505000
TARGET'WORDS := TOS;                                           <<04562>>11510000
SOURCE'WORDS := TOS;                                           <<04562>>11515000
LOCKED := TOS;                                                 <<04562>>11520000
                                                               <<04562>>11525000
<< Place the target and source addresses up on TOS.         >> <<04562>>11530000
                                                               <<04562>>11535000
TARGET'ADDR := TARGET'ADDR + OFFSET;                           <<04562>>11540000
TOS := TARGET'WORDS;                                           <<04562>>11545000
TOS := SOURCE'WORDS;                                           <<04562>>11550000
TOS := 2;                                                      <<04562>>11555000
MOVE'DS'5;                 << Off they go!                  >> <<04562>>11560000
                                                               <<04562>>11565000
IF LOCKED                  << Did we get the quick lock?    >> <<04562>>11570000
   THEN UNLOCK'CB(0,FCBV)                                      <<06511>>11575000
   ELSE PSEUDOENABLE;                                          <<04562>>11580000
                                                               <<04562>>11585000
END;                                                           <<04562>>11590000
$PAGE " FBNDCHK "                                              <<04558>>11595000
$ CONTROL SEGMENT = FILESYS3   << FBNDCHK >>                            11600000
LOGICAL PROCEDURE FBNDCHK (PARM,SIZE,UBND);                             11605000
   << Checks whether DB is at the stack, and if so, that the            11610000
  specified area (PARM to PARM+SIZE-1) is within bounds.                11615000
                                                                        11620000
     Input variables:                                                   11625000
         PARM - initial stack address (word or byte address)            11630000
         SIZE - number of stack words                                   11635000
         UBND - upper stack bound (word address)                        11640000
                                                                        11645000
     Output variables:                                                  11650000
         FBNDCHK - error indication                                     11655000
            1 - DB not at stack. Callers generally consider this OK.    11660000
            FALSE - out of bounds                                       11665000
            TRUE - OK                                                   11670000
                                                                        11675000
     For word address, check size must be positive; for byte            11680000
     address, check size must be negative.   >>                         11685000
VALUE PARM,SIZE,UBND;                                                   11690000
INTEGER PARM,SIZE,UBND;                                                 11695000
OPTION PRIVILEGED,UNCALLABLE;                                           11700000
   BEGIN                                                                11705000
   INTEGER DELTAQ=Q-0;                                         <<03059>>11710000
   CHECKDB;      << Where's DB?>>                                       11715000
   IF <> THEN                                                           11720000
      BEGIN    << Not at the stack. >>                                  11725000
      FBNDCHK := 1;                                                     11730000
      RETURN;                                                           11735000
      END;                                                              11740000
   IF SIZE < 0 THEN                                                     11745000
      BEGIN     << Convert for byte addressing. >>                      11750000
      PARM := PARM&LSR(1);                                              11755000
      PUSH(S);                                                          11760000
      IF TOS < PARM THEN PARM.(0:1) := 1;                               11765000
      SIZE := (1-SIZE)&LSR(1);                                          11770000
      END;                                                              11775000
   IF UBND >= 0 THEN                                           <<03059>>11780000
     <<Some pre-ICF/55 code has called with a DB relative,>>   <<03059>>11785000
     <<rather than Q relative, address.  Catch it.>>           <<03059>>11790000
     BEGIN                                                     <<03059>>11795000
     FBNDCHK := TRUE;                                          <<03059>>11800000
     RETURN;                                                   <<03059>>11805000
     END;                                                      <<03059>>11810000
   PUSH(DL);     << lower bound >>                                      11815000
   TOS := @DELTAQ-DELTAQ+UBND-SIZE+1;                          <<03059>>11820000
   X := PARM;     << initial address >>                                 11825000
   IF NOT (TOS <= X <= TOS) THEN RETURN;  << if out of bnds >>          11830000
   FBNDCHK := TRUE                                                      11835000
   END;     << procedure FBNDCHK >>                                     11840000
$PAGE  " FCONV'BLK "                                                    11845000
$CONTROL SEGMENT = FILESYS1A  << FCONV'BLK >>                           11850000
                                                                        11855000
PROCEDURE FCONV'BLK(BLOCK,LDEV,CODE,STX,FCEOF,EXTBASE,EXTSIZE);<<04653>>11860000
   << This procedure determines the disk address of the specified       11865000
   block.  If it lies in a non-existent extent, the extent is created.  11870000
   The number of words remaining within the extent gives the            11875000
   maximum allowable transfer size.                                     11880000
                                                                        11885000
   The procedure also releases spoofle extents after they have          11890000
   been read for the last time.                                         11895000
                                                                        11900000
     Input variables:                                                   11905000
         BLOCK - block number                                           11910000
         LDEV - caller's Q-rel ACB location                             11915000
         CODE - I/O op code:                                            11920000
            0 - Read                                                    11925000
            1 - Write                                                   11930000
         STX  - ignored                                                 11935000
         FCEOF - ignored                                                11940000
         EXTBASE - ignored                                              11945000
         EXTSIZE - ignored                                              11950000
                                                                        11955000
     Output variables:                                                  11960000
         BLOCK - sector address of specified block                      11965000
         LDEV - logical device nr. of extent containing block           11970000
         CODE - record location code                                    11975000
           -1 - Reading from an un-allocated extent            <<ALEXT  11980000
            0 - OK                                                      11985000
            1 - Beyond EOF                                              11990000
            2 - Beyond file limit                                       11995000
            N - FS error number                                         12000000
         STX  - sectors available in extent                             12005000
         FCEOF - EOF record nr.                                         12010000
         EXTBASE - double sector address of current extent              12015000
         EXTSIZE - size (in sectors) of current extent                  12020000
                                                                        12025000
     The output variables are returned by a partial cutback of          12030000
     the stack.  DB can be anywhere, although normally it will          12035000
     be at the user's buffer.                                           12040000
>>                                                                      12045000
<< NOTE:                                                    >> <<04160>>12050000
<< We will only acquire the FISIR if the file was not opened>> <<04160>>12055000
<< EXC. The sir is used to "lock" the FLAB while updating   >> <<04160>>12060000
<< the extent map. Since EXC is used, we will be the only   >> <<04160>>12065000
<< process accessing the FLAB. This is especially important >> <<04160>>12070000
<< because of past hangs dealing with the FISIR and System  >> <<04160>>12075000
<< Logging.                                                 >> <<04160>>12080000
                                                               <<04160>>12085000
   VALUE BLOCK,LDEV,CODE,STX,FCEOF,EXTBASE,EXTSIZE;            <<04653>>12090000
   INTEGER LDEV,CODE;                                                   12095000
   LOGICAL STX,EXTSIZE;                                        <<04653>>12100000
   DOUBLE BLOCK,FCEOF,EXTBASE;                                 <<04653>>12105000
   OPTION PRIVILEGED,UNCALLABLE;                                        12110000
BEGIN                                                                   12115000
                                                                        12120000
INTEGER FCBMQ;                                                 <<04578>>12125000
DOUBLE FCBV;                                                   <<06511>>12130000
   << ACB variables >>                                                  12135000
                                                                        12140000
DEFINE                                                                  12145000
   ACB'FNUM    =AQ0(ACBQ+1)#,                                           12150000
   ACB'FOPTIONS=LQ0(ACBQ+6)#,                                  <<04159>>12155000
   ACB'AOPTIONS=LQ0(ACBQ+7)#,                                  <<04160>>12160000
   ACB'EXCL    =(ACB'AOPTIONS.(8:2) = 1)#,   << EXC Access >>  <<04160>>12165000
   ACB'RSIZE   =AQ0(ACBQ+8)#,    << Record size >>             <<04159>>12170000
   ACB'BLKLO   =AQ0(ACBQ+19)#,   << lo half ACBBLK >>                   12175000
   ACB'FCB'DSTN=AQ0(ACBQ+26)#,                                 <<06511>>12180000
   ACB'FCB'ENTRY=AQ0(ACBQ+27)#,                                <<06511>>12185000
   ACB'STATW   =LQ0(ACBQ+29)#,                                          12190000
   ACB'DADDR   =AQ0(ACBQ+30)#,                                 <<06511>>12195000
   ACB'AMLD    =AQ0(ACBQ+38)#,                                          12200000
   ACB'GSTW    =LQ0(ACBQ+39)#,                                 <<06511>>12205000
   ACB'SPXDDX  =AQ0(ACBQ+43)#;                                 <<04450>>12210000
                                                               <<04159>>12215000
   INTEGER ACBQ;         << our Q-rel addr of caller's ACB >>           12220000
   INTEGER PCBPT;        << Pointer to PCB for defines.     >> <<06511>>12225000
   LOGICAL SPOOLF;        << -1 if spooler, +1 if user >>               12230000
   INTEGER POINTER XDDEP;  << spoofle directory entry pointer >>        12235000
                                                                        12240000
   << FCB variables >>                                                  12245000
                                                                        12250000
   DOUBLE EMAPADDR;     << FCB DST & e-map offset >>                    12255000
                                                                        12260000
   << Record and block parameters >>                                    12265000
                                                                        12270000
   LOGICAL NEWEXTSIZE;   << sectors >>                                  12275000
   DOUBLE BLKFACT;                                                      12280000
   DOUBLE NEWEXTD;       << E-map data for new block >>                 12285000
      INTEGER NEWEXTX = NEWEXTD;   << E-table index >>                  12290000
      LOGICAL NEWEXTO = NEWEXTD+1; << offset, sectors >>                12295000
                                                                        12300000
   DOUBLE OLDEOFBLK;     << first block beyond present EOF >>           12305000
   DOUBLE OLDEOFD;       << E-map data for old EOF >>                   12310000
      INTEGER OLDEOFX = OLDEOFD;   << E-table index >>                  12315000
      LOGICAL OLDEOFO = OLDEOFD+1; << offset, sectors >>                12320000
                                                                        12325000
   DOUBLE DJ1J2;                                                        12330000
      INTEGER J1 = DJ1J2;                                               12335000
                                                                        12340000
                                                                        12345000
   << Output spoofle squeeze >>                                         12350000
                                                                        12355000
   LOGICAL SQEEZE;  << TRUE if spoofle is being squeezed >>             12360000
   INTEGER Z;       << index of first non-purged extent >>              12365000
   INTEGER DX;      << data seg nr. >>                                  12370000
                                                                        12375000
   << File label access >>                                              12380000
                                                                        12385000
   INTEGER POINTER FLAB;  << file label pointer >>                      12390000
   DOUBLE POINTER FLABDBL = FLAB;                                       12395000
                                                                        12400000
                                                               <<04564>>12405000
                                                                        12410000
   INTEGER A;             << File SIR >>                                12415000
                                                                        12420000
EQUATE                                                         <<04567>>12425000
       WRITE      =   1,     << ATTACHIO function code >>      <<04567>>12430000
       UNALLOC'EXT = -1;     << Reading from unalloc. ext   >> <<04567>>12435000
                                                               <<04159>>12440000
                                                               <<04159>>12445000
INTEGER ARRAY FCB'(0:SIZEBFCB-1) = Q;                          <<04159>>12450000
BUILD'FCB;                                                     <<06511>>12455000
DOUBLE ARRAY XMAP(0:MAXEXTENTS-1) = Q;   << local extent map >><<04159>>12460000
                                                               <<04159>>12465000
DEFINE READ = (CODE = 0)#;                                     <<06511>>12470000
                                                               <<04159>>12475000
<< ******  Begin subroutines  ****** >>                        <<04159>>12480000
                                                                        12485000
   SUBROUTINE ERREXIT(ERRNUM);                                          12490000
   VALUE ERRNUM; INTEGER ERRNUM;                                        12495000
      BEGIN                                                             12500000
      DEL;         << discard return address >>                         12505000
      CODE := TOS;      << ERRNUM >>                                    12510000
      GO EXIT                                                           12515000
      END;                                                              12520000
                                                                        12525000
   DOUBLE SUBROUTINE EXTENTPOOP (BLKNR);                                12530000
      << Determines the extent number and offset in sectors             12535000
     within the extent for the specified block.                         12540000
                                                                        12545000
        Input variable:                                                 12550000
            BLKNR - block number                                        12555000
                                                                        12560000
        Output variables:                                               12565000
            S-0   Offset within extent, sectors                         12570000
            S-1   Extent index (zero relative)    >>                    12575000
                                                                        12580000
   VALUE BLKNR;                                                         12585000
   DOUBLE BLKNR;                                                        12590000
      BEGIN                                                             12595000
      TOS := BLKNR+FCB'START;  <<FORM ACTUAL BLOCK NUMBER>>    <<HM.00>>12600000
      TOS := FCB'FLIM; <<FILE LIMIT IN RECORDS>>               <<HM.00>>12605000
      X := FCB'BLKFACT;  <<BLOCKING FACTOR>>                   <<HM.00>>12610000
      DIVD;                                                    <<HM.00>>12615000
      IF TOS <> 0 THEN TOS := TOS+1D;  <<FORM # FILE BLOCKS>>  <<HM.00>>12620000
      IF DS3 >= DS1 THEN ASSEMBLE(DSUB) ELSE DDEL; <<WRAP?>>   <<HM.00>>12625000
      X := FCB'SECTPBLK;                                                12630000
      MPYD;           << get total sectors >>                           12635000
      TOS := TOS+DOUBLE(FCB'SECTOFF);    << for labels >>               12640000
      TOS := FCB'EXTSIZE;  << extent size, sectors >>                   12645000
      ASMB(LDIV);                                                       12650000
      DS6 := TOS     << extent nr. and extent displ. >>                 12655000
      END;                                                              12660000
                                                                        12665000
$PAGE                                                          <<06511>>12670000
   SUBROUTINE LABELIOSQ(RW);                                            12675000
   VALUE   RW;                                                          12680000
   INTEGER RW;                                                          12685000
      BEGIN                                                             12690000
      TOS := 0D;   << for result and LDEV >>                            12695000
      TOS := XMAP(0);                                                   12700000
      TOS := TOS&TASL(8)&DLSR(8);   << separate LDEV >>                 12705000
      X := FLABIO(*,*,S5,FLAB);    << R/W label >>                      12710000
      IF <> THEN                                                        12715000
         BEGIN                                                          12720000
         FLABIOERR(X,ACB'FNUM);                                         12725000
         RELSIR(FISIR,A);                                               12730000
         IF NOT SQEEZE THEN  << adjust squeeze bit in ODD >>            12735000
            XDDSPOOLINFO( 0D,%1001,XDDEP);                              12740000
         ERREXIT(LBLIOERR);                                             12745000
         END;                                                           12750000
      END;                                                              12755000
                                                                        12760000
   SUBROUTINE CLEARDISK(START,NSECTS);                                  12765000
   VALUE START, NSECTS; INTEGER NSECTS; DOUBLE START;                   12770000
                                                               <<04159>>12775000
   << DB is at stack.                                >>        <<04159>>12780000
   << Upper 8 bits  of START has the Ldev #, bottom  >>        <<04159>>12785000
   << 24 bits the sector address.                    >>        <<04159>>12790000
   <<                                                >>        <<04159>>12795000
      BEGIN                                                             12800000
      IF NSECTS = 0 THEN RETURN;                                        12805000
      TOS := 0;      << for result of FCLEAR >>                         12810000
                                                               <<04450>>12815000
      << Want to clear RIO files with zeroes, even if ASCII >> <<04450>>12820000
      << to clear the ART with zeroes.                      >> <<04450>>12825000
                                                               <<04450>>12830000
      TOS := IF (ACB'RIO OR (NOT FCB'ASCII))                   <<04450>>12835000
               THEN FALSE ELSE TRUE;                           <<04450>>12840000
      TOS := 0;      << for LDEV >>                                     12845000
      TOS := DS6;    << START - LDEV and sector nr.>>                   12850000
      TOS := TOS&TASL(8)&DLSR(8);  << separate LDEV >>                  12855000
      X := FCLEAR(*,*,*,S6);   << (ASC,LDEV,SECTOR,NSECTS) >>           12860000
$  IF X1 = ON                                                           12865000
      IF <> THEN FTROUBLE(475);  << error >>                            12870000
$  IF                                                                   12875000
      END;                                                              12880000
                                                                        12885000
$ PAGE                                                                  12890000
<< ******  FCONVBLK: Begin execution  ****** >>                         12895000
                                                                        12900000
$  IF X0 = ON                                                           12905000
   IF MONUNCALLABLE THEN  << Monitoring? >>                             12910000
      BEGIN                                                             12915000
      FTITLE("FCON","VBLK",0D,0D);                                      12920000
      DEBUG                                                             12925000
      END;                                                              12930000
$  IF                                                                   12935000
   ACBQ := LDEV-DELTAQ;   << get our ACB Q-rel index >>                 12940000
                                                                        12945000
<< Special treatment for Foreign Disk request. >>                       12950000
                                                                        12955000
   IF ACB'DTYPE=FDISC THEN                                              12960000
      BEGIN                                                             12965000
      CODE := 0;    << Initially assume OK >>                           12970000
      LDEV := ACB'DADDR;                                       <<01672>>12975000
      FCEOF := DISCSIZE(LDEV)-1D;                              <<*7933>>12980000
      STX := INTEGER(FCEOF-BLOCK);                             <<01672>>12985000
      IF (FCEOF - BLOCK) <= 0D THEN                            <<*7933>>12990000
         CODE := 2;   << Beyond FLIM. >>                                12995000
      RETURN 0;                                                         13000000
      END;                                                              13005000
                                                                        13010000
   <<* * * Save info from ACB * * *>>                                   13015000
                                                                        13020000
   DX := -1;     << Reset EXCHANGEDB flag >>                            13025000
   @XDDEP := ACB'SPXDDX;                                                13030000
   TOS := ACB'SPOOLED;                                                  13035000
   IF = THEN                                                   <<HM.00>>13040000
      BEGIN   <<NOT A USER SPOOL FILE>>                        <<HM.00>>13045000
      IF TOS <> ACB'SPXDDX AND NOT ACB'MSGFILE THEN            <<HM.00>>13050000
         TOS:=TRUE  <<SPOOLER FILE>>                           <<HM.00>>13055000
      ELSE                                                     <<HM.00>>13060000
         TOS:=FALSE;  <<NOT ANY TYPE OF SPOOL FILE>>           <<HM.00>>13065000
      END;                                                     <<HM.00>>13070000
   SPOOLF:=TOS;                                                <<HM.00>>13075000
   SQEEZE := IF INTEGER(SPOOLF) < 0 THEN ACB'SPSQZ ELSE 0;              13080000
                                                                        13085000
   <<* * * Copy FCB to Q + FCBMQ buffer * * *               >> <<04578>>13090000
                                                               <<06511>>13095000
   TOS := ACB'FCB'DSTN;       << Build double FCBV.         >> <<06511>>13100000
   TOS := ACB'FCB'ENTRY;                                       <<06511>>13105000
   FCBV := TOS;                                                <<06511>>13110000
   GET'FCB'PRIME'Q'LOC;                                        <<04578>>13115000
                                                               <<04159>>13120000
   LOCK'CB(0,0,FCBMQ,FCBV);                                    <<06511>>13125000
   TOS := SIZEBFCB;    << excluding E-map >>                            13130000
   MOVE'DS'1;          << get FCB, incl. E-map size >>                  13135000
   X := FCB'.(2:14);   << FCB size >>                                   13140000
   IF BADFCBSIZE THEN FTROUBLE(61);                                     13145000
   EMAPADDR := DS1;    << save FCB e-map location >>                    13150000
   TOS := (FCB'NUMEXTS+1)&LSL(1);                                       13155000
   MOVE'DS'6;          << get the E-map >>                              13160000
   FCEOF := FCB'EOF;    << return parameter >>                          13165000
                                                                        13170000
                                                                        13175000
   <<* * * Get block nr. and extent index * * *>>                       13180000
                                                                        13185000
   BLKFACT := DOUBLE(FCB'BLKFACT);                                      13190000
   IF BLOCK < 0D THEN ERREXIT(BADRECNO)                        <<02068>>13195000
   ELSE IF BLOCK > (FCB'FLIM-1D)/BLKFACT THEN                  <<02068>>13200000
      ERREXIT(2);        << Bad address; throw the bum out. >>          13205000
   NEWEXTD := EXTENTPOOP(BLOCK);  << Get extent nr. & displ. >>         13210000
   NEWEXTSIZE := EXTSIZE := IF NEWEXTX < FCB'NUMEXTS           <<04653>>13215000
      THEN FCB'EXTSIZE ELSE FCB'LASTEXTSIZE;                            13220000
                                                               <<04564>>13225000
   <<*******************************************************>> <<04564>>13230000
   << Calculate the old EOF block number and report EOF if  >> <<04564>>13235000
   << reading past this block number.  The FCB EOF/END check>> <<04770>>13240000
   << is to protect pre MPE-IV variable files since these   >> <<04770>>13245000
   << files do not have FCB'END set to the EOF block numb.  >> <<04770>>13250000
   <<*******************************************************>> <<04564>>13255000
                                                               <<04564>>13260000
   IF FCB'VARIABLE                                             <<04564>>13265000
      THEN OLDEOFBLK :=  FCB'END - FCB'START + 1D              <<04564>>13270000
      ELSE OLDEOFBLK := (FCB'EOF + BLKFACT - 1D) / BLKFACT;    <<04564>>13275000
   IF READ AND BLOCK >= OLDEOFBLK AND NOT ACB'MSGFILE AND      <<04770>>13280000
      NOT (FCB'VARIABLE LAND FCB'EOF <> 0D LAND FCB'END = 0D)  <<04770>>13285000
      THEN ERREXIT(1);            << Report EOF             >> <<04564>>13290000
                                                                        13295000
<< If reading spoofle, skip over deleted extents. >>                    13300000
                                                                        13305000
   Z := 1;                                                              13310000
   IF READ AND SQEEZE THEN      << reading squeezed spoofle >>          13315000
      BEGIN             << find first non-deleted extent. >>            13320000
      WHILE XMAP(Z) = 0D DO Z := Z+1;                                   13325000
      IF NEWEXTX < Z AND Z > 1 THEN                                     13330000
         BEGIN           << Addressing a deleted extent. >>             13335000
         NEWEXTX := Z;    << Go to first existing extent >>             13340000
         NEWEXTO := 0;                                                  13345000
         TOS := BLOCK := (DOUBLE(Z)*DOUBLE(FCB'EXTSIZE)                 13350000
            -DOUBLE(FCB'SECTOFF))/DOUBLE(FCB'SECTPBLK);                 13355000
         ACB'BLKLO := TOS;                                              13360000
         AQ0(X := X-1) := TOS;   << Adjust BLK pointer in ACB >>        13365000
         END;                                                           13370000
      END;                                                              13375000
   IF NEWEXTX > FCB'NUMEXTS THEN ERREXIT(2);                            13380000
                                                                        13385000
<< ****  If the new extent hasn't been allocated, do so,                13390000
   and clear it up to the new block if advancing EOF.                   13395000
   If not advancing EOF, clear the entire new extent.   ****  >>        13400000
                                                                        13405000
   IF XMAP(NEWEXTX) = 0D AND CODE <> %11 THEN                  <<01936>>13410000
      BEGIN          << Extent not yet allocated. >>                    13415000
                                                               <<04567>>13420000
      <<****************************************************>> <<04567>>13425000
      << If we are reading from an un-allocated extent, re- >> <<04567>>13430000
      << turn with an "error".  IOMOVE will then simply fill>> <<04567>>13435000
      << the needed buffers will fill characters. This will >> <<04567>>13440000
      << save much time and disc space!                     >> <<04567>>13445000
      <<****************************************************>> <<04567>>13450000
                                                               <<04567>>13455000
      IF READ THEN                                             <<04567>>13460000
         BEGIN                                                 <<04567>>13465000
         STX := NEWEXTSIZE - NEWEXTO;  << Sectors avb. ext. >> <<04567>>13470000
         BLOCK := 0D;                  << No extent address.>> <<04567>>13475000
         LDEV  := 0;                                           <<04567>>13480000
         ERREXIT(UNALLOC'EXT);         <<  Report "error".  >> <<04567>>13485000
         END;                                                  <<04567>>13490000
                                                               <<04567>>13495000
      IF FCB'PERMANENT AND ACB'ACCESS.(11:2)=0                          13500000
          AND ACB'ACCESS.(14:1)=0 THEN                                  13505000
         ERREXIT(2);   << Can't extend; report beyond file limit. >>    13510000
                                                                        13515000
   << Adjust directory disc space counts.  Runs with DB at stack. >>    13520000
                                                                        13525000
      PCBPT := CURPRC;                                         <<06511>>13530000
      IF SPCBXDSDST <> 0 THEN DX := EXCHANGEDB(0);             <<06511>>13535000
      IF FCB'PERMANENT THEN                                             13540000
         BEGIN           << Old permanent file. >>                      13545000
         DJ1J2 := DIRECADJUST(DOUBLE(NEWEXTSIZE),0,                     13550000
            FCB'AN,FCB'GN,FCB'MVTABX);                                  13555000
         IF <> THEN                                                     13560000
            ERREXIT(IF < THEN DIRIOERR ELSE J1+NORIN);  <<%74>>         13565000
         END;     << old permanent file >>                              13570000
                                                                        13575000
      <<* * * Allocate disk space for new extent * * *>>                13580000
                                                                        13585000
      IF SPOOLF AND XDDSPOOLINFO(0D,%400,XDDEP) <> 0D THEN              13590000
         ERREXIT(SPOOLNOSPACE);     << NOSPACE bit was set >>           13595000
      XMAP(NEWEXTX) := DOUBLE(NEWEXTSIZE);  << amt. needed >>           13600000
      j1 := Diskalloc (IF spoolf THEN 0 ELSE fcb'device,       <<03503>>13605000
                       1, xmap(newextx), fcb'pvinfo).(8:8);    <<03503>>13610000
      IF <> THEN                                                        13615000
         BEGIN          << Error allocating space. >>                   13620000
         XMAP(NEWEXTX) := 0D;     << Poof! >>                           13625000
         IF j1 = 1 THEN    << No disc space? >>                <<03503>>13630000
            IF NOT SPOOLF THEN                                          13635000
               TOS := NOSPACE                                           13640000
            ELSE                                                        13645000
               BEGIN                                                    13650000
               TOS := SPOOLNOSPACE;                                     13655000
               XDDSPOOLINFO(0D,%200,XDDEP) <<set NOSPACE bit>>          13660000
               END                                                      13665000
         ELSE IF j1 = 2 THEN   << I/O error >>                 <<03503>>13670000
            TOS := IF SPOOLF THEN SPOOLERROR ELSE DISCIOERR             13675000
         ELSE IF j1 = 4 THEN   << Device not avail? >>         <<03503>>13680000
            TOS := NAVAILDEV                                            13685000
         ELSE IF j1 = 3 THEN                                   <<03503>>13690000
            TOS := disc'space'allocation'disabled              <<03503>>13695000
         ELSE                                                           13700000
            BEGIN      << Other error. >>                               13705000
$  IF X1 = ON                                                           13710000
            FTROUBLE(468);                                              13715000
$  IF                                                                   13720000
            TOS := IF SPOOLF THEN SPOOLERROR ELSE SYSTEM                13725000
            END;                                                        13730000
         IF FCB'PERMANENT THEN                                          13735000
            BEGIN      << Reset directory space counts. >>              13740000
            DJ1J2 := DIRECADJUST(-DOUBLE(NEWEXTSIZE),0,                 13745000
               FCB'AN,FCB'GN,FCB'MVTABX);                               13750000
$  IF X1 = ON                                                           13755000
            IF <> THEN FTROUBLE(468);      << Error >>                  13760000
$  IF                                                                   13765000
            END;                                                        13770000
         ERREXIT(*);                                                    13775000
         END;       << error allocating space >>                        13780000
      IF SPOOLF THEN    << bump nr. of extents >>              <<01672>>13785000
         XDDSPOOLINFO(0D,%100,XDDEP);                          <<01672>>13790000
                                                                        13795000
   << Update extent map entry in FCB. >>                                13800000
                                                                        13805000
      TOS := EMAPADDR;       << DST and offset >>                       13810000
      TOS := TOS+NEWEXTX&LSL(1);                                        13815000
      TOS := @XMAP(NEWEXTX);                                            13820000
      TOS := 2;                                                         13825000
      ASMB(MTDS 4);                                                     13830000
                                                                        13835000
                                                                        13840000
   << Update extent map in file label.  The dance with the FCB          13845000
      maintains resource hierarchy.  >>                                 13850000
                                                                        13855000
      UNLOCK'CB(0,FCBV);                      << release FCB >><<06511>>13860000
      IF NOT ACB'EXCL  THEN A := GETSIR(FISIR);                <<04160>>13865000
      LOCK'CB(0,0,1,FCBV);                 << get it back >>   <<06511>>13870000
      ASMB(SUBS 5);      << discard results >>                          13875000
      PUSH (S);                                                         13880000
      @FLAB := TOS+1;                                                   13885000
      ASMB (ADDS 128);                                                  13890000
      LABELIOSQ(0);      << Read label into stack buffer >>             13895000
      FLEOF := FCB'EOF;                                                 13900000
      FLSTART:=FCB'START;                                      <<HM.00>>13905000
      FLEND:=FCB'END;                                          <<HM.00>>13910000
      FLHDRECS:=FCB'HDR;                                       <<HM.00>>13915000
      LDEVTOVTAB(FLEXTMAP,XMAP,FLNUMEXTS+1,FCB'MVTABX<>0);              13920000
      LABELIOSQ(-1);         << Rewrite label >>               <<06961>>13925000
      ASMB (SUBS 128);                                                  13930000
      IF NOT ACB'EXCL  THEN RELSIR(FISIR,A);                   <<04160>>13935000
                                                                        13940000
   <<  If variable or not advancing EOF, clear all of new extent.  >>   13945000
                                                                        13950000
      IF BLOCK < OLDEOFBLK OR FCB'VARIABLE THEN                <<04564>>13955000
         CLEARDISK(XMAP(NEWEXTX),NEWEXTSIZE);                           13960000
      END;       << extent not yet allocated >>                         13965000
                                                                        13970000
<< ****  If fixed, and the block is beyond the prior EOF, clear any     13975000
   allocated space from the prior EOF to the new block.  >>             13980000
                                                                        13985000
   IF BLOCK > OLDEOFBLK AND                                    <<04564>>13990000
      NOT FCB'MSGFILE AND NOT FCB'VARIABLE THEN                <<04564>>13995000
      BEGIN             << New block is beyond prior EOF. >>            14000000
      OLDEOFD := EXTENTPOOP(OLDEOFBLK);                                 14005000
      IF XMAP(OLDEOFX) <> 0D THEN   << clear in old EOF extent >>       14010000
         CLEARDISK(XMAP(OLDEOFX)+DOUBLE(OLDEOFO),                       14015000
            IF OLDEOFX=NEWEXTX THEN   << advancing in old extent >>     14020000
               NEWEXTO-OLDEOFO   << clear from EOF to new block >>      14025000
            ELSE        << clear all the rest of old EOF extent >>      14030000
               FCB'EXTSIZE-OLDEOFO);                                    14035000
                                                                        14040000
                                                                        14045000
<<  Clear from beginning of new extent to block containing new EOF. >>  14050000
                                                                        14055000
      IF NEWEXTX > OLDEOFX AND XMAP(NEWEXTX) <> 0D THEN        <<01936>>14060000
         CLEARDISK(XMAP(NEWEXTX),NEWEXTO);                              14065000
                                                                        14070000
<< Clear any intervening allocated extents. >>                          14075000
                                                                        14080000
      WHILE (OLDEOFX := OLDEOFX+1) < NEWEXTX DO                         14085000
         IF XMAP(OLDEOFX) <> 0D THEN    << it exists - clear it >>      14090000
            CLEARDISK(XMAP(OLDEOFX),FCB'EXTSIZE);                       14095000
      END;    << new block allocated beyond EOF >>                      14100000
                                                                        14105000
   <<* * * Return parameters * * *>>                                    14110000
                                                                        14115000
   STX := NEWEXTSIZE-NEWEXTO;  << sectors avbl in extent >>             14120000
   TOS := CODE;                                                         14125000
   IF BLOCK >= OLDEOFBLK AND NOT FCB'VARIABLE                  <<04564>>14130000
      THEN CODE := 1         << Report EOF                  >> <<04564>>14135000
      ELSE CODE := 0;        << No EOF to report            >> <<04564>>14140000
   TOS := 0;              << for LDEV >>                                14145000
   TOS := XMAP(NEWEXTX);    << extent descriptor >>                     14150000
   TOS := EXTBASE := TOS & TASL(8) & DLSR(8); << strip ldev >> <<04653>>14155000
   BLOCK := TOS+DOUBLE(NEWEXTO);  << sector nr. of block >>             14160000
   LDEV := TOS;                 << LDEV of block >>                     14165000
                                                                        14170000
   IF TOS = 0 AND ACB'SPRSQ AND                                         14175000
       NEWEXTX > Z AND NEWEXTO >= NEWEXTSIZE/2 THEN                     14180000
                                                                        14185000
<< When reading a spoofle with squeezing requested, deletes extent      14190000
"Z" when we've read halfway into the next extent.  Runs with DB         14195000
at stack for DISKDEALLOC.  Since the spooler has exclusive access,      14200000
it isn't necessary to release and reacquire the FCB.  >>                14205000
                                                                        14210000
      BEGIN       << Halfway into new extent. >>                        14215000
      IF SQEEZE THEN                                                    14220000
         BEGIN           << Perform a squeeze. >>                       14225000
         IF DX = -1 THEN DX := EXCHANGEDB(0);   << to stack >>          14230000
         IF NOT ACB'EXCL  THEN A := GETSIR(FISIR);             <<04160>>14235000
         PUSH(S);                                                       14240000
         @FLAB := TOS+1;                                                14245000
         ASMB(ADDS 128);       << allot label buffer >>                 14250000
         LABELIOSQ(0);         << read file label >>                    14255000
         TOS := @FLEXTMAP;                                              14260000
         DPS0(Z) := 0D;        << clear label E-map entry >>            14265000
         DEL;                                                           14270000
         LABELIOSQ(1);         << rewrite file label >>                 14275000
         ASMB(SUBS 128);       << dealloc stack buffer >>               14280000
         IF NOT ACB'EXCL  THEN RELSIR(FISIR,A);                <<04160>>14285000
         X := DISKDEALLOC(FCB'EXTSIZE,FCB'EXTSIZE,%201,XMAP(Z));        14290000
$  IF X1 = ON                                                           14295000
         IF <> THEN FTROUBLE(468);    << if error >>                    14300000
$  IF                                                                   14305000
         XMAP(Z) := 0D;        << clear ext map entry >>                14310000
         TOS := EMAPADDR;                                               14315000
         TOS := TOS+Z&LSL(1);                                           14320000
         TOS := @XMAP(Z);                                               14325000
         TOS := 2;                                                      14330000
         ASMB(MTDS 4);                                                  14335000
         END           << perform squeeze >>                            14340000
      ELSE                                                              14345000
         BEGIN     << not squeezing yet >>                              14350000
         TOS := ACB'GSTW;                                      <<06511>>14355000
         TOS.(2:1) := 1;   << ACB'SPSQZ: indicate squeezing >>          14360000
         ACB'GSTW := TOS;                                      <<06511>>14365000
         XDDSPOOLINFO(0D,%1001,XDDEP);                                  14370000
         END;                                                           14375000
      END;        << new extent >>                                      14380000
                                                                        14385000
EXIT:                                                                   14390000
   IF DX <> -1 THEN EXCHANGEDB(DX);  << back to user buff >>            14395000
   UNLOCK'CB(0,FCBV);                      << release FCB >>   <<06511>>14400000
   RETURN 0                                                             14405000
   END;        << procedure FCONV'BLK >>                                14410000
$PAGE " FADJUSTCIRFILE "                                       <<06511>>14415000
$CONTROL SEGMENT=FILESYS1A  <<FADJUSTCIRFILE>>                 <<HM.00>>14420000
PROCEDURE FADJUSTCIRFILE(NUMRECORDS,ACBQ);                     <<HM.00>>14425000
                                                               <<HM.00>>14430000
   << Used by writers to correct file overflow.                  HM.00  14435000
     Input variables:                                            HM.00  14440000
         NUMRECORDS - number of records in the block             HM.00  14445000
         ACBQ       - caller's Q-rel ACB location >>           <<02076>>14450000
   VALUE NUMRECORDS,ACBQ;                                      <<HM.00>>14455000
                                                               <<HM.00>>14460000
   DOUBLE NUMRECORDS;                                          <<HM.00>>14465000
   INTEGER ACBQ;                                               <<HM.00>>14470000
   OPTION PRIVILEGED,UNCALLABLE;                               <<HM.00>>14475000
   BEGIN                                                       <<HM.00>>14480000
   INTEGER ARRAY FCB'(0:SIZEBFCB-1)=Q;  << must be 1st decl >> <<02076>>14485000
   DOUBLE FCBV;                                                <<06511>>14490000
BUILD'FCB;                                                     <<06511>>14495000
   DEFINE  ACB'FCB'DSTN  = AQ0(ACBQ+26)#,                      <<06511>>14500000
           ACB'FCB'ENTRY = AQ0(ACBQ+27)#;                      <<06511>>14505000
                                                               <<HM.00>>14510000
$  IF X0 = ON                                                  <<HM.00>>14515000
   IF MONOTHER THEN  <<MONITORING?>>                           <<HM.00>>14520000
      BEGIN                                                    <<HM.00>>14525000
      TOS := "FA"; TOS := "DJ"; TOS := "US"; TOS := "TC";      <<HM.00>>14530000
      TOS := "IR"; TOS := "FI"; TOS := "LE";                   <<HM.00>>14535000
      ASSEMBLE(ZERO);                                          <<HM.00>>14540000
      FTITLE(*,*,*,*);                                         <<HM.00>>14545000
      DEBUG                                                    <<HM.00>>14550000
      END;                                                     <<HM.00>>14555000
$  IF                                                          <<HM.00>>14560000
                                                               <<HM.00>>14565000
   <<* * * Get local copy of the FCB * * *>>                   <<02076>>14570000
                                                               <<HM.00>>14575000
   ACBQ := ACBQ-DELTAQ;    << get our ACB Q-rel address >>     <<02076>>14580000
   TOS := ACB'FCB'DSTN;    << Build double FCBV.            >> <<06511>>14585000
   TOS := ACB'FCB'ENTRY;                                       <<06511>>14590000
   FCBV := TOS;                                                <<06511>>14595000
   LOCK'CB(8,0,1,FCBV);                                        <<06511>>14600000
   TOS := SIZEBFCB;                                            <<02076>>14605000
   ASMB(MDS 1);                                                <<HM.00>>14610000
                                                               <<HM.00>>14615000
   FCB'START := FCB'START+1D;                                  <<02076>>14620000
   IF FCB'START >= FCB'FLIM/DBL(FCB'BLKFACT) THEN              <<HM.00>>14625000
      FCB'START := 0D;                                         <<02076>>14630000
   IF FCB'VARIABLE THEN FCB'END := FCB'END-1D;                 <<02076>>14635000
   FCB'EOF := FCB'EOF-NUMRECORDS;                              <<02076>>14640000
   S2 := S2-1;    << decrement addresses for move back >>      <<02076>>14645000
   TOS := TOS-1;                                               <<02076>>14650000
   ASMB(DXCH);                                                 <<HM.00>>14655000
   TOS := -SIZEBFCB;                                           <<02076>>14660000
   ASMB(MDS 5);                                                <<HM.00>>14665000
                                                               <<HM.00>>14670000
   <<* * * Unlock FCB * * *>>                                  <<02076>>14675000
                                                               <<HM.00>>14680000
   IF LOGICAL(TOS)                                             <<06511>>14685000
      THEN UNLOCK'CB(0,FCBV)         << Quick lock failed.  >> <<06511>>14690000
      ELSE PSEUDOENABLE;             << Quick lock succeeded>> <<06511>>14695000
   END;     << procedure FADJUSTCIRFILE >>                     <<02076>>14700000
$PAGE " TAPE PROCEDURES - SET'LPDT'BOT & CHECK'BOT "           <<06511>>14705000
PROCEDURE SET'LPDT'BOT(LDEV,VAL);                              <<02545>>14710000
VALUE LDEV,VAL; LOGICAL LDEV,VAL;                                       14715000
OPTION PRIVILEGED,UNCALLABLE;                                           14720000
                                                                        14725000
<< Set or reset Beginning-of-Tape bit in LPDT entry. >>                 14730000
                                                                        14735000
   BEGIN                                                                14740000
   DISABLE;                                                             14745000
   LPDT'BOT := VAL;                                                     14750000
   ENABLE;                                                              14755000
   END;      << procedure SET'LPDT'BOT >>                               14760000
                                                               <<06041>>14765000
LOGICAL PROCEDURE CHECK'BOT(LDEV);                             <<06041>>14770000
VALUE LDEV;                                                    <<06041>>14775000
INTEGER LDEV;                                                  <<06041>>14780000
                                                               <<97876>>14785000
OPTION PRIVILEGED, UNCALLABLE;                                 <<97876>>14790000
                                                               <<06041>>14795000
<< Returns TRUE if LDEV is at BOT, FALSE if not.            >> <<06041>>14800000
                                                               <<06041>>14805000
BEGIN                                                          <<06041>>14810000
DISABLE;                                                       <<06041>>14815000
CHECK'BOT := LOGICAL(LPDT'BOT);                                <<06041>>14820000
ENABLE;                                                        <<06041>>14825000
END;                                                           <<06041>>14830000
                                                               <<06041>>14835000
$PAGE " WRITE'DENSITY "                                        <<06511>>14840000
DOUBLE PROCEDURE WRITE'DENSITY(LDEV);                          <<02652>>14845000
   VALUE LDEV; INTEGER LDEV;                                   <<02570>>14850000
   OPTION PRIVILEGED,UNCALLABLE;                               <<02570>>14855000
                                                               <<02570>>14860000
COMMENT  << beginning of comment >>                            <<02570>>14865000
                                                               <<02570>>14870000
   This procedure sets the density of a multiple density       <<02570>>14875000
mag tape drive.  The procedure returns the double word         <<02652>>14880000
returned by ATTACHIO.  If the ATTACHIO was successful, the     <<02652>>14885000
procedure also clears the LPDT'BOT bit to take the burden off  <<02570>>14890000
of the calling procedure.  Thus, WRITE'DENSITY should only be  <<02570>>14895000
called if a write ATTACHIO call follows immediately.           <<02570>>14900000
                                                               <<02570>>14905000
NOTE:  1) The caller must only pass devices (LDEV) which are   <<02570>>14910000
          known to be mag. tape drives.  All other checks      <<02570>>14915000
          are handled internal to the procedure.               <<02570>>14920000
       2) DB may be anywhere when calling this procedure.      <<02570>>14925000
          Typically, it will be at the user's buffer.          <<02570>>14930000
       3) Because the ATTACHIO call is an infrequent event     <<02570>>14935000
          compared with other file system activity (it only    <<02570>>14940000
          occurs when a write function occurs at load point),  <<02570>>14945000
          the overhead of an EXCHANGEDB and a table lock is    <<02570>>14950000
          considered acceptable.                               <<02570>>14955000
                                                               <<02570>>14960000
<< end of comment >>;                                          <<02570>>14965000
                                                               <<02570>>14970000
BEGIN                                                          <<02570>>14975000
DOUBLE                                                         <<02652>>14980000
   RESULT = WRITE'DENSITY;  << Return value >>                 <<02652>>14985000
INTEGER                                                        <<02652>>14990000
   IO'STAT = RESULT,    << ATTACHIO status return >>           <<02652>>14995000
   IO'TLOG = RESULT+1;  << ATTACHIO transmission log >>        <<02652>>15000000
INTEGER                                                        <<02570>>15005000
   LDT'DENW,     << LDT entry density information >>           <<02570>>15010000
   DENW'INDEX,   << Index into LDT to get LDT'DENW >>          <<02570>>15015000
   NEW'TAPE,     << Save first REQUEST'DENSITY >>              <<02570>>15020000
   ATTIO'STAT,   << Holds ATTACHIO status return >>            <<02570>>15025000
   P2,           << Parameter 2 to ATTACHIO >>                 <<02570>>15030000
   OLDDB,                                                      <<02570>>15035000
   SAVESIR;                                                    <<02570>>15040000
EQUATE                                                         <<02570>>15045000
   P2'6250     = 0,     << P2 value for 6250 BPI >>            <<02570>>15050000
   P2'1600     = 1,     << P2 value for 1600 BPI >>            <<02570>>15055000
   P2'800      = 2,     << P2 value for 800 BPI             >> <<07284>>15060000
   DEN'FUNC    = 16,    << Density function of driver >>       <<02570>>15065000
   SUCCESSFUL  = 1,     << General status, successful >>       <<02570>>15070000
   TAPE'RETRY  = %21,   << Successfull tape retry.          >> <<R7925>>15075000
   PFAIL'ABORT = %63,   << Power fail abort status >>          <<02570>>15080000
   POWER'UP    = %213,  << Device powered up status >>         <<02570>>15085000
   NOT'AT'BOT  = %233;  << Device not at load point status >>  <<02570>>15090000
ARRAY                                                          <<07284>>15095000
   DENSITY'TO'P2'PARM(0:3)=PB := -1,P2'1600,P2'6250,P2'800;    <<07284>>15100000
                                                               <<02570>>15105000
                                                               <<02570>>15110000
   IO'STAT := SUCCESSFUL;  << Initialize return >>             <<02652>>15115000
                                                               <<02570>>15120000
   << Check to see that LDEV is an HP7976A at load point. >>   <<02570>>15125000
   IF (NOT'VARIABLE'DENSITY) OR LPDT'BOT = 0                   <<07284>>15130000
      THEN GO EXIT;                                            <<07284>>15135000
                                                               <<02570>>15140000
   OLDDB := EXCHANGEDB(0);                                     <<02570>>15145000
                                                               <<02570>>15150000
   << Get density information from LDT entry >>                <<02570>>15155000
   TOS := @LDT'DENW;                                           <<02570>>15160000
   TOS := LDT;                                                 <<02570>>15165000
   TOS := DENW'INDEX := LDEV*LDTENTRY + DENSITYW;              <<02570>>15170000
   TOS := 1;                                                   <<02570>>15175000
   ASSEMBLE( MFDS 4 );                                         <<02570>>15180000
                                                               <<02570>>15185000
<< Originally, there was code here to skip the ATTACHIO if   >><<02570>>15190000
<< (TAPE'DENSITY=REQUEST'DENSITY) was TRUE.  This will not   >><<02570>>15195000
<< work if a user is doing his own unlabelled tape reel      >><<02570>>15200000
<< management.  When the 2nd or later reel comes "on line",  >><<02570>>15205000
<< AVR does not occur because the drive is already owned.    >><<02570>>15210000
<< Therefore, TAPE'DENSITY will not reflect the density of   >><<02570>>15215000
<< the new tape on the drive, but the previous tape on the   >><<02570>>15220000
<< drive.  Therefore, the test is invalid and the ATTACHIO   >><<02570>>15225000
<< must always be done. >>                                     <<02570>>15230000
                                                               <<02570>>15235000
   IF REQUEST'DENSITY <> DEN'DEFAULT THEN                      <<07284>>15240000
      P2 := DENSITY'TO'P2'PARM(REQUEST'DENSITY)                <<07284>>15245000
   ELSE IF LPDT'SUBTYPE = HP7974 THEN                          <<07284>>15250000
      P2 := P2'1600   << The default for 7974 density.      >> <<07284>>15255000
   ELSE                                                        <<07284>>15260000
      P2 := P2'6250;  << The default for 7976 or 7978.      >> <<07284>>15265000
                                                               <<02570>>15270000
   << Retry set density if power problems >>                   <<02570>>15275000
   DO BEGIN                                                    <<02570>>15280000
      RESULT := ATTACHIO(LDEV,0,0,0,DEN'FUNC,0,0,P2,BFLAGS);   <<02652>>15285000
      ATTIO'STAT := IO'STAT.(8:8);                             <<02652>>15290000
      END                                                      <<02570>>15295000
   UNTIL (ATTIO'STAT <> POWER'UP) AND                          <<02570>>15300000
         (ATTIO'STAT <> PFAIL'ABORT);                          <<02570>>15305000
                                                               <<02570>>15310000
   IF ATTIO'STAT.(13:3) <> SUCCESSFUL AND                      <<R7925>>15315000
      ATTIO'STAT.(13:3) <> TAPE'RETRY THEN                     <<R7925>>15320000
      BEGIN                                                    <<02570>>15325000
      << If not at load point, then data structure got  >>     <<02570>>15330000
      << messed up.  Ignore it !!  Report other errors. >>     <<02570>>15335000
      IF ATTIO'STAT = NOT'AT'BOT THEN                          <<02652>>15340000
         IO'STAT.(8:8) := SUCCESSFUL;                          <<02652>>15345000
      END                                                      <<02570>>15350000
   ELSE                                                        <<02570>>15355000
      BEGIN   << Success >>                                    <<02570>>15360000
      IO'STAT.(8:8) := SUCCESSFUL;                             <<R7925>>15365000
      SAVESIR := GETSIR(LDTSIR);                               <<02570>>15370000
                                                               <<02570>>15375000
      NEW'TAPE := REQUEST'DENSITY; << Save new density >>      <<02570>>15380000
                                                               <<02570>>15385000
      << Get current density info from LDT >>                  <<02570>>15390000
      TOS := @LDT'DENW;                                        <<02570>>15395000
      TOS := LDT;                                              <<02570>>15400000
      TOS := DENW'INDEX;                                       <<02570>>15405000
      TOS := 1;                                                <<02570>>15410000
      ASSEMBLE( MFDS 4 );                                      <<02570>>15415000
                                                               <<02570>>15420000
      << Update tape density with new density >>               <<02570>>15425000
      TAPE'DENSITY := NEW'TAPE;                                <<02570>>15430000
                                                               <<02570>>15435000
      << Write it back >>                                      <<02570>>15440000
      TOS := LDT;                                              <<02570>>15445000
      TOS := DENW'INDEX;                                       <<02570>>15450000
      TOS := @LDT'DENW;                                        <<02570>>15455000
      TOS := 1;                                                <<02570>>15460000
      ASSEMBLE( MTDS 4 );                                      <<02570>>15465000
                                                               <<02570>>15470000
      RELSIR(LDTSIR,SAVESIR);                                  <<02570>>15475000
      END;                                                     <<02570>>15480000
                                                               <<02570>>15485000
   EXCHANGEDB(OLDDB);   << Put it back >>                      <<02570>>15490000
                                                               <<02570>>15495000
EXIT:                                                          <<02570>>15500000
   IF IO'STAT.(8:8) = SUCCESSFUL THEN                          <<02652>>15505000
      SET'LPDT'BOT(LDEV,0);   << Write will follow >>          <<02570>>15510000
                                                               <<02570>>15515000
END;   << of WRITE'DENSITY >>                                  <<02570>>15520000
$PAGE " IOMOVE - DEFINITIONS AND SUBROUTINES "                          15525000
$CONTROL SEGMENT = FILESYS1A  << IOMOVE >>                              15530000
                                                                        15535000
PROCEDURE IOMOVE(MODE,TARGET,TCOUNT);                                   15540000
   VALUE MODE,TCOUNT;                                                   15545000
                                                                        15550000
   << This procedure does all record I/O.                               15555000
                                                                        15560000
     Input variables:                                                   15565000
         MODE - I/O mode                                                15570000
            0  Input (FREADDIR)                                         15575000
            2  Control (spoolfile WRITE)                                15580000
            3  FOPEN   (      ..       )                                15585000
            4  FCLOSE  (      ..       )                                15590000
            %26 OR %36  FREADBACKWARD                                   15595000
          %10  FREADSEEK                                                15600000
          %20  Input (FREAD)                                            15605000
          %30  Input - no-wait I/O initiation (FREAD)                   15610000
          %40  Input - no-wait I/O completion (IOWAIT)                  15615000
          %40  RIO - delete active record.                              15620000
          %50  RIO - only return activity state (no data)               15625000
            1  Output (FWRITEDIR)                              <<DONTW  15630000
          %11  Write EOF - insure extents are initialized        FIXIT  15635000
          %21  Output (FWRITE)                                 <<DONTW  15640000
          %31  Output - no-wait I/O initiation (FWRITE)                 15645000
          %41  Output - no-wait I/O completion (IOWAIT)                 15650000
       >=%100  Output - FDEVICECONTROL function                <<CIPER  15655000
         TARGET - pointer to user's buffer                              15660000
         TCOUNT - transfer count (pos. words/neg. bytes)                15665000
                                                                        15670000
     All errors are indicated via ACBSTATUS, ACBLSTATE (EOF flag)       15675000
     and ACBERROR.  DB must be set to the data segment containing       15680000
     the user's buffer.  In order to permit direct rather than          15685000
     indexed addressing, the ACB is assumed to lie directly beneath     15690000
     the explicit parameters to IOMOVE; callers must not stack          15695000
     any data before calling IOMOVE.    >>                              15700000
                                                                        15705000
   INTEGER TCOUNT;                                                      15710000
   LOGICAL ARRAY TARGET;                                                15715000
   LOGICAL MODE;                                                        15720000
   OPTION PRIVILEGED,UNCALLABLE;                                        15725000
                                                                        15730000
BEGIN                                                                   15735000
                                                               <<04653>>15740000
<< The following EQUATEs are used to identIFy the "type" >>    <<04653>>15745000
<< of ATTACHIO IOMOVE is attempting to perform to the MPE>>    <<04653>>15750000
<< I/O system.  It will hopefully indicate sequential and>>    <<04653>>15755000
<< BUF/NOBUF states to ATTACHIO via FLAGS.(0:4).         >>    <<04653>>15760000
EQUATE BUF'FLUSH     = 9,   << FQUIESCEIO >>                   <<04653>>15765000
       NOBUF'SEQ     = 10,                                     <<04653>>15770000
       NOBUF'DIR     = 11,                                     <<04653>>15775000
       BUF'SEQ       = 12,                                     <<04653>>15780000
       BUF'DIR       = 13,                                     <<04653>>15785000
       NOBUF'KSAM    = 14,                                     <<04653>>15790000
       NOBUF'IMAGE   = 15;                                     <<04653>>15795000
                                                               <<04653>>15800000
                                                               <<04653>>15805000
EQUATE                                                         <<04321>>15810000
   MIN'MODE'FDEVICECONTROL = %100,                             <<06511>>15815000
   DQ                      = -63 ;  << Q-rel locn of ACB.   >> <<06511>>15820000
INTEGER ARRAY ACB(*) = Q - 63;      << Must be at Q-63!     >> <<06511>>15825000
BUILD'ACBNR;                                                   <<06511>>15830000
INTEGER DSTX = ACB +56;                                        <<06511>>15835000
                                                               <<04592>>15840000
DEFINE                                                         <<04592>>15845000
   FREADDIR'MODE        = (MODE  =   0)#,                      <<04592>>15850000
   FWRITEDIR'MODE       = (MODE  =   1)#,                      <<04592>>15855000
   FCONTROL'MODE        = (MODES =   2)#,                      <<04592>>15860000
   FOPEN'MODE           = (MODES =   3)#,                      <<04592>>15865000
   FCLOSE'MODE          = (MODES =   4)#,                      <<04592>>15870000
   FREADBACKWARD'MODE   = (MODE.(13:3) = 6)#,                  <<04700>>15875000
   FREADSEEK'MODE       = (MODE  = %10)#,                      <<04592>>15880000
   WRITE'EOF'MODE       = (MODE  = %11)#,                      <<04592>>15885000
   FREAD'MODE           = (MODE  = %20)#,                      <<04592>>15890000
   FWRITE'MODE          = (MODE  = %21)#,                      <<04592>>15895000
   RIO'DELETE'MODE      = (MODE  = %40)#,                      <<04592>>15900000
   RIO'ACTIVE'MODE      = (MODE  = %50)#;                      <<04592>>15905000
                                                                        15910000
DEFINE READ = NOT MODE#,                                                15915000
      WRITE = MODE#,                                           <<06039>>15920000
   DIRECT'ACCESS = FREADDIR'MODE OR FWRITEDIR'MODE#,           <<04590>>15925000
   EMPTY         = -1D#,                                       <<04566>>15930000
    NOWAIT = (INTEGER(MODE.(10:3)) > %2)#,                     <<00.SD>>15935000
    NOWAITCOMP = (MODE.(10:3) = %4)#;                          <<00.SD>>15940000
                                                                        15945000
<< Local variables [Q+]. T1 thru T6 must be first & contiguous. >>      15950000
                                                                        15955000
   INTEGER T1, T2, T3, T4, T5, T6;                                      15960000
      LOGICAL LT1 = T1;                                                 15965000
      LOGICAL LT2 = T2;                                                 15970000
      DOUBLE DT1T2 = T1;                                                15975000
      DOUBLE DT3T4 = T3;                                                15980000
      DOUBLE DT4T5 = T4;                                                15985000
      DOUBLE DT5T6 = T5;                                                15990000
      DOUBLE OLD'EOF = DT1T2,    << EOF's for FSET'EOF      >> <<04562>>15995000
             NEW'EOF = DT3T4;                                  <<04562>>16000000
                                                                        16005000
EQUATE BLKOFFSET = 6;    << @BLKIOQX - @T1 >>                           16010000
EQUATE MAX'WORD'TCOUNT = 16*1024-1; <<16K-1 max word TCOUNT >> <<04558>>16015000
                                                                        16020000
   << Current block header image [buffered access] >>                   16025000
                                                                        16030000
   INTEGER BLK'IOQX;                                                    16035000
   LOGICAL BLK'FLAGW;                                                   16040000
   DOUBLE BLK'IOCB, BLK'BLOCK, BLK'DADDR;                               16045000
   DOUBLE BLK'EXTBASE;   << extent base of current block >>    <<04653>>16050000
   LOGICAL BLK'EXTSIZE;  << extent size in sectors       >>    <<04653>>16055000
   LOGICAL BLK'DUMMY;    << * * * NOT CURRENTLY USED * * >>    <<04653>>16060000
      INTEGER BLK'LSTAT = BLK'IOCB;                                     16065000
      INTEGER BLK'TLOG  = BLK'IOCB+1;                                   16070000
                                                               <<04566>>16075000
      LOGICAL             << 16 bits log. for buffer algor. >> <<04566>>16080000
         BLK'IN,          << Block is already in a buffer?  >> <<04566>>16085000
      BUF'EMPTY;          << Used to find an empty buffer.  >> <<04566>>16090000
                                                                        16095000
   INTEGER BC;                                                          16100000
   INTEGER WC;                                                          16105000
   LOGICAL                                                     <<04557>>16110000
      STX          , << Sectors available in current extent.>> <<04557>>16115000
      SECTS'TRNSFRD; << Sectors trnsfrd, NOBUF, curr. xfer. >> <<04557>>16120000
   DOUBLE                                                      <<04557>>16125000
      FCB'CB'ADDR,   << FCB DST and offset in CB.           >> <<06511>>16130000
      FCB'STK'ADDR,  << FCB DST and offset in our stack.    >> <<06511>>16135000
      BLKS'TRNSFRD,  << Blocks trnsfrd. NOBUF, curr. xfer.  >> <<04557>>16140000
      RECS'TRNSFRD,  << Records trnsfrd, NOBUF, curr xfer.  >> <<04557>>16145000
      BLKS'FILE    , << Number of blocks left in the file.  >> <<04557>>16150000
      RECS'FILE    , <<  "  "   " records "   "   "    "    >> <<04557>>16155000
      WORDS'FILE   ; <<  "  "   " words   "   "   "    "    >> <<04557>>16160000
   INTEGER                                                     <<04557>>16165000
      PCBPT,                 << PCB offset of our PCB entry.>> <<06511>>16170000
      SECTS'TO'FILL,         << Fill sect. of short write.  >> <<04578>>16175000
      CORRECTION,            << Correction term for TLOG/CNT>> <<04578>>16180000
      RECS'FILE'0 = RECS'FILE;  << Number recs > int. word? >> <<04557>>16185000
                                                               <<04557>>16190000
   INTEGER WTT;           << words to xfer, this I/O >>                 16195000
   INTEGER CTT;           << chars to xfer, this I/O >>                 16200000
   LOGICAL                                                     <<04578>>16205000
      WTT'L = WTT,                                             <<04578>>16210000
      CTT'L = CTT;                                             <<04578>>16215000
   INTEGER                                                     <<04578>>16220000
      CHARS'TO'FILL,      << Short block read, fill in.     >> <<05009>>16225000
      VAR'WORD'CNT,       << Used for CHKVARBLK.            >> <<04578>>16230000
      SPEC'VAR'CNT,       << Second word of spec. var. rec. >> <<04578>>16235000
      VAR'REC'SIZE,                                            <<04578>>16240000
      NUM'VAR'BLKS;                                            <<04578>>16245000
   LOGICAL                                                     <<04578>>16250000
      BAD'VAR'BLK,                                             <<04578>>16255000
      END'OF'BLK,                                              <<04578>>16260000
      LOC,                   << General purpose buff. loc.  >> <<04578>>16265000
      CLEARTYPE;             << Clear blk with 0's or blanks>> <<04578>>16270000
   DOUBLE                                                      <<04578>>16275000
      NUM'VAR'RECS,                                            <<04578>>16280000
      NMAX;           << # of records left in the file.     >> <<04578>>16285000
DEFINE INFINITE = 1000000000D#;                                         16290000
   INTEGER CHAR'TRNSFRD;  << Characters transfered,this I/O.>> <<04578>>16295000
   LOGICAL CHAR'TRNSFRD'L = CHAR'TRNSFRD;                      <<04578>>16300000
   BYTE POINTER BTARGET;  << target byte pointer >>                     16305000
                                                                        16310000
   << Misc. file parameters >>                                          16315000
                                                                        16320000
   DOUBLE EXTBASE;    << current disc extent sector addr >>    <<04653>>16325000
   LOGICAL EXTSIZE;   << current disc extent size        >>    <<04653>>16330000
   DOUBLE FCEOF;          << EOF record nr. >>                          16335000
   INTEGER                                                     <<04567>>16340000
      RSIZE,              << Record size in words.          >> <<04567>>16345000
      FCONV'ERROR;        << FCONV'BLK error number.        >> <<04567>>16350000
   LOGICAL MR;            << multi-record access flag >>                16355000
   LOGICAL FIRST'WRITE;                                        <<04578>>16360000
   LOGICAL NEWEOF;        << EOF advanced? - disk only >>               16365000
   INTEGER EOFDELTA := 0;                                               16370000
   LOGICAL                                                     <<06039>>16375000
      FSOPEN'SPOOLF := FALSE,  << NOBUF spooler access?     >> <<06039>>16380000
      OUTPUT'SPOOLF := FALSE;  << Output spooler access?    >> <<06039>>16385000
   INTEGER NONDATARECORDS; << Msg files, # open/close recs>>   <<HM.00>>16390000
                                                                        16395000
   DOUBLE T1ADR;         << DST-rel addr of T1 vars >>                  16400000
      INTEGER STKDST=T1ADR;                                             16405000
      INTEGER Q'1'A =T1ADR+1;     << will be %100 > ACBOFST. >>         16410000
                                                                        16415000
   << ATTACHIO variables >>                                             16420000
                                                                        16425000
   INTEGER LDEV;          << LDEV of block >>                           16430000
   DOUBLE                                                      <<04566>>16435000
      IO'STATUS,          << Return status from ATTACHIO.   >> <<04566>>16440000
      DISKADR;            << Sector number of block.        >> <<04566>>16445000
   INTEGER P1 = DISKADR;  << sector nr. - first half >>                 16450000
   INTEGER P2 = DISKADR+1;  << sector nr. - second half >>              16455000
   INTEGER                                                     <<04578>>16460000
      ATTIO'COUNT,                                             <<04578>>16465000
      NOWAIT'IOQX   = IO'STATUS   , << No-wait I/O word 1   >> <<04578>>16470000
      NOWAIT'STATUS = IO'STATUS +1, << No-wait I/O word 2   >> <<04578>>16475000
      WAITIO'STATUS = IO'STATUS   , << Wait for I/O word 1  >> <<04578>>16480000
      WAITIO'TLOG   = IO'STATUS +1; << Wait for I/O word 2  >> <<04578>>16485000
   DEFINE                                                      <<04578>>16490000
      ERR'STAT     = WAITIO'STATUS.(8:8)#,                     <<04578>>16495000
      ATTIOFLAG'CRITVER = ATTIOFLAGS.(4:1)#,                   <<06961>>16500000
      ATTIOFLAG'SERIAL  = ATTIOFLAGS.(5:1)#,                   <<06961>>16505000
      ATTIOFLAG'CNTL    = ATTIOFLAGS.(0:4)#,                   <<06961>>16510000
      NOWAIT'COMP  = ATTIOFLAGS.(13:3)=0#,                     <<04578>>16515000
      WAITIO'COMP  = ATTIOFLAGS.(13:3)=1#;                     <<04578>>16520000
   LOGICAL                                                     <<04645>>16525000
      FCB'LOCKED,      << Used by FSET'EOF for quick lock.  >> <<06511>>16530000
      FLAGS,           << Used for ATTIOFLAGS for caching.  >> <<04653>>16535000
       RSIZE'BRU,          << RSIZE, Bytes, Rounded Up.     >> <<04644>>16540000
      ATTIOFLAGS,      << Last parameter to ATTACHIO.       >> <<04645>>16545000
      SHORT'BLOCK;     << TRUE if short block read MR.      >> <<04645>>16550000
                                                                        16555000
   << ACB buffer variables >>                                           16560000
                                                                        16565000
   INTEGER BUFDISP;    << PACB DST-rel buff addr >>                     16570000
                                                                        16575000
   INTEGER I,         << Block buffer in use >>                         16580000
           NUM'BUFS;  << number of buffers >>                  <<04566>>16585000
   INTEGER                                                     <<04578>>16590000
      BC'TRAIL'FILL   ,  << Trailing fill chars., spoolfle. >> <<04578>>16595000
      REC'OVERHEAD    ,  << Special spoolfile rec. overhead.>> <<04578>>16600000
      MODES           ,  << Spoolfile mode.                 >> <<04578>>16605000
      BLK'OVERHEAD    ,  << Special spoolfile blk. overhead.>> <<04578>>16610000
      DATASIZE        ;  << Words of data in block.         >> <<04578>>16615000
                                                                        16620000
   << Misc. file parameters >>                                          16625000
                                                                        16630000
   INTEGER BC'DATA'REC; << Data portion of var/undef.       >> <<04578>>16635000
   LOGICAL IMBED;     << 1 if imbed carriage control >>                 16640000
   INTEGER CCTL=IMBED;<< "  "    "      "       "    >>        <<04560>>16645000
   INTEGER FILL;      << fill word >>                                   16650000
   DOUBLE DBLKFACT;                                                     16655000
      INTEGER BLKFACT = DBLKFACT+1;                                     16660000
                                                                        16665000
   << Requested block variables >>                                      16670000
                                                                        16675000
   DOUBLE BLOCK;     << Block number >>                                 16680000
   INTEGER REC'PNTR; << Record position within block (words)>> <<04578>>16685000
   INTEGER RXB;      << record index in block, for RIO >>               16690000
INTEGER XI;              << ** for bug trap ** >>                       16695000
   INTEGER FILENUM;  << Used to set the AFT pointer.        >> <<06511>>16700000
   INTEGER POINTER AFT;                                        <<06511>>16705000
                                                                        16710000
EQUATE    << Misc. equates go here.                         >> <<04566>>16715000
   UNALLOC'EXT  =  -1,   << Return from FCONV'BLK.          >> <<04567>>16720000
   STUB'IOQX    =  -1,   << Stub IOQX for unalloc. extents. >> <<04567>>16725000
   NOT'FOUND    =  -1;   << Needed buffer has not been fnd. >> <<04566>>16730000
$PAGE                                                          <<04557>>16735000
<<  ****  Begin subroutines  ****  >>                                   16740000
                                                                        16745000
   SUBROUTINE ERREXIT(ERRNUM);                                          16750000
   VALUE ERRNUM; INTEGER ERRNUM;                                        16755000
      BEGIN                                                             16760000
      DEL;          << discard return address >>                        16765000
      ACB'ERROR := TOS;                                                 16770000
      ACB'STATUS := 0;     << force CCL >>                     <<01759>>16775000
      GO EXIT                                                           16780000
      END;                                                              16785000
                                                                        16790000
<< This subroutine sets the ATTACHIO flags for NOBUF I/O >>    <<04653>>16795000
SUBROUTINE FIX'ATTACHIO'FLAGS;                                 <<04653>>16800000
BEGIN                                                          <<04653>>16805000
                                                               <<04653>>16810000
ATTIOFLAGS := UFLAGS CAT NOT NOWAIT (15:15:1);                 <<04653>>16815000
ATTIOFLAG'CRITVER := ACB'QUIESCE;                              <<06961>>16820000
ATTIOFLAG'SERIAL  := ACB'SERIALIO;                             <<06961>>16825000
<< Determine IF this is a KSAM, IMAGE, seq or direct file >>   <<04653>>16830000
IF FREAD'MODE OR FWRITE'MODE THEN                              <<04653>>16835000
  ATTIOFLAG'CNTL := NOBUF'SEQ << FREAD or FWRITE >>            <<06961>>16840000
ELSE                                                           <<04653>>16845000
  BEGIN  << We are dealing with a direct file of some sort >>  <<04653>>16850000
  ATTIOFLAG'CNTL := NOBUF'DIR;                                 <<06961>>16855000
  IF DSTX <> 0 THEN  << I/O is not to user's stack         >>  <<04653>>16860000
    BEGIN                                                      <<04653>>16865000
    IF DADB0 = "KSAM" THEN                                     <<04653>>16870000
      ATTIOFLAG'CNTL := NOBUF'KSAM ELSE                        <<06961>>16875000
    IF DADB0 = "IMAG" THEN                                     <<04653>>16880000
      ATTIOFLAG'CNTL := NOBUF'IMAGE;                           <<06961>>16885000
    END;                                                       <<04653>>16890000
  END;  << of dealing with direct files >>                     <<04653>>16895000
END;  << of subroutine FIX'ATTACHIO'FLAGS >>                   <<04653>>16900000
                                                               <<04653>>16905000
   SUBROUTINE GET2WORDS;                                                16910000
<< Fetches two words at R and R+1 from ACB buffer to T1 and T2. >>      16915000
      BEGIN                                                             16920000
      TOS := T1ADR;                                                     16925000
      TOS := ACBM'PACBV'DSTN;                                  <<06511>>16930000
      TOS := REC'PNTR + BUFDISP;                               <<04578>>16935000
      TOS := 2;                                                         16940000
      MOVE'DS'5;                                                        16945000
      END;                                                              16950000
                                                                        16955000
   SUBROUTINE GETBLKPARMS;                                              16960000
<< Copies block buffer header words for block I from PACB               16965000
   to Q+ local storage.  >>                                             16970000
      BEGIN                                                             16975000
      XI := I;            << ** set bug trap  ** >>                     16980000
      TOS := T1ADR;                                                     16985000
      TOS := TOS+BLKOFFSET;    << @ block header buffer >>              16990000
      TOS := ACBM'PACBV'DSTN;                                  <<06511>>16995000
      TOS := ACBX'PACBOFFSET+SIZEACB+I*(BLKBUFDISP+ACB'BSIZE); <<06511>>17000000
      TOS := BLKBUFDISP;     << nr. words in header >>                  17005000
      MOVE'DS'1;                                                        17010000
      BUFDISP := TOS;     << ACB buffer address >>                      17015000
      ASMB(DDEL,DEL);                                                   17020000
      END;                                                              17025000
                                                                        17030000
   SUBROUTINE PUTBLKPARMS;                                              17035000
<< Posts local storage image for block I to block buffer header         17040000
   in PACB.   >>                                                        17045000
      BEGIN                                                             17050000
      IF XI <> I THEN FTROUBLE(51);  << ** caught bug ** >>             17055000
      TOS := ACBM'PACBV'DSTN;                                  <<06511>>17060000
      TOS := ACBX'PACBOFFSET+SIZEACB+I*(BLKBUFDISP+ACB'BSIZE); <<06511>>17065000
      TOS := T1ADR;                                                     17070000
      TOS := TOS+BLKOFFSET;                                             17075000
      TOS := BLKBUFDISP;     << nr. words in header >>                  17080000
      MOVE'DS'5;                                                        17085000
      END;                                                              17090000
$PAGE                                                          <<04557>>17095000
   DOUBLE SUBROUTINE FSET'EOF(EOFREC,CURR'VAR'BLK);            <<06169>>17100000
   VALUE EOFREC,CURR'VAR'BLK;                                  <<06169>>17105000
   DOUBLE EOFREC,CURR'VAR'BLK;                                 <<06169>>17110000
                                                               <<04562>>17115000
   <<*******************************************************>> <<04562>>17120000
   << Advances EOF in the FCB if needed.  Update EOF on ev- >> <<04562>>17125000
   << ery write to a variable length file.  Used to obtain  >> <<04562>>17130000
   << EOF pointer on a read also.  For foriegn discs, return>> <<04562>>17135000
   << size of the disc. Updates the EOF block number for    >> <<06169>>17140000
   << variable length files.  All the LOCK'CB stuff is done >> <<06511>>17145000
   << for speed, please leave it be.                        >> <<06511>>17150000
   <<*******************************************************>> <<04562>>17155000
                                                               <<04562>>17160000
   BEGIN                                                       <<04562>>17165000
   NEW'EOF := EOFREC;                                          <<04562>>17170000
   IF ACB'FCB = 0D THEN                                        <<06511>>17175000
      OLD'EOF := DISCSIZE(LDEV)                                <<04562>>17180000
   ELSE                                                        <<04562>>17185000
      BEGIN                                                    <<04562>>17190000
      LOCK'CB(8,0,1,ACB'FCB); ! Get EOF to OLD'EOF, Q+1.       <<06511>>17195000
      FCB'CB'ADDR := DS1;     ! Save FCB address from CB.      <<06511>>17200000
      FCB'STK'ADDR := DS3;    ! Save stack EOF address.        <<06511>>17205000
      TOS := TOS + XEOF;      ! Add EOF offset into FCB addr.  <<06511>>17210000
      TOS := 2;               ! Move double word EOF.          <<06511>>17215000
      MOVE'DS'5;              ! EOF is now at Q+1, in OLD'EOF. <<06511>>17220000
      FCB'LOCKED := TOS;      ! Tells us if we got quick lock. <<06511>>17225000
      IF NEW'EOF > OLD'EOF OR ACB'VARIABLE AND NOT READ THEN   <<04562>>17230000
         BEGIN                                                 <<04562>>17235000
         TOS := FCB'CB'ADDR;  ! FCB, CB DST and offset.        <<06511>>17240000
         TOS := TOS + XEOF;   ! Add EOF offset into FCB.       <<06511>>17245000
         TOS := FCB'STK'ADDR; ! Address and DST of OLD'EOF.    <<06511>>17250000
         TOS := TOS + 2;      ! Get to NEW'EOF, at Q+3.        <<06511>>17255000
         TOS := 2;            ! EOF, of course, is a double.   <<06511>>17260000
         MOVE'DS'5;           ! Update EOF with NEW'EOF.       <<06511>>17265000
                                                               <<04562>>17270000
         <<*************************************************>> <<04562>>17275000
         << For variable length files, store the current    >> <<04562>>17280000
         << block number in FCBEND.                         >> <<04562>>17285000
         <<*************************************************>> <<04562>>17290000
                                                               <<04562>>17295000
         IF ACB'VARIABLE THEN                                  <<06511>>17300000
            BEGIN                                              <<06511>>17305000
            DT1T2 := CURR'VAR'BLK; ! Store in Q+1 for MDS.     <<06511>>17310000
            TOS := FCB'CB'ADDR;    ! FCB, CB DST and offset.   <<06511>>17315000
            TOS := TOS + XEND;     ! Add offset to FCBEND.     <<06511>>17320000
            TOS := FCB'STK'ADDR;   ! DST and offset to Q+1.    <<06511>>17325000
            TOS := 2;              ! Size of move.             <<06511>>17330000
            MOVE'DS'5;             ! Off it goes to the FCB.   <<06511>>17335000
            END;                                               <<06511>>17340000
         END;                                                  <<04562>>17345000
      IF FCB'LOCKED                                            <<06511>>17350000
         THEN UNLOCK'CB(0,ACB'FCB)                             <<06511>>17355000
         ELSE PSEUDOENABLE;                                    <<06511>>17360000
      END;                                                     <<04562>>17365000
   FSET'EOF := OLD'EOF; << Return value for READ.           >> <<04562>>17370000
   END;                                                        <<04562>>17375000
$PAGE                                                          <<04557>>17380000
   LOGICAL SUBROUTINE GETARTWORD;                                       17385000
      BEGIN                                                             17390000
      TOS := T1ADR;                                                     17395000
      TOS := ACBM'PACBV'DSTN;                                  <<06511>>17400000
      TOS := BUFDISP+DATASIZE+RXB/16;                                   17405000
      TOS := 1;                                                         17410000
      MOVE'DS'5;            << fetch bitmap word to T1 >>               17415000
      X := RXB MOD 16;      << return bit index in X >>                 17420000
      GETARTWORD := T1;                                                 17425000
      END;                                                              17430000
                                                                        17435000
   SUBROUTINE PUTARTWORD(VAL);                                          17440000
   VALUE VAL; INTEGER VAL;                                              17445000
      BEGIN                                                             17450000
      T1 := VAL;       << bitmap to be stored >>                        17455000
      TOS := ACBM'PACBV'DSTN;                                  <<06511>>17460000
      TOS := BUFDISP+DATASIZE+RXB/16;                                   17465000
      TOS := T1ADR;                                                     17470000
      TOS := 1;                                                         17475000
      MOVE'DS'5;       << move from T1 to ART area >>                   17480000
      BLK'DIRTY := 1;                                                   17485000
      END;                                                              17490000
                                                               <<06511>>17495000
                                                               <<06511>>17500000
SUBROUTINE CLEAR'CURR'BUF;                                     <<04567>>17505000
                                                               <<04567>>17510000
<<**********************************************************>> <<04567>>17515000
<< Clear the current buffer with fill characters.  This is  >> <<04567>>17520000
<< used when reading from an un-allocated extent. RIO files >> <<04567>>17525000
<< always fill w / 0's so that the ART shows no active recs.>> <<04567>>17530000
<<**********************************************************>> <<04567>>17535000
                                                               <<04567>>17540000
BEGIN                                                          <<04567>>17545000
                                                               <<04567>>17550000
IF ACB'RIO                                                     <<04567>>17555000
   THEN T1 := 0                                                <<04567>>17560000
   ELSE T1 := FILL;                                            <<04567>>17565000
TOS := ACBM'PACBV'DSTN;  << DST # of buffer.                >> <<06511>>17570000
TOS := BUFDISP;          << DST offset to current buffer.   >> <<04567>>17575000
TOS := T1ADR;            << DST and offset of fill char.    >> <<04567>>17580000
TOS := 1;                                                      <<04567>>17585000
MOVE'DS'3;               << Stuff fill in 1st. word.        >> <<04567>>17590000
TOS := ACBM'PACBV'DSTN;                                        <<06511>>17595000
TOS := BUFDISP;          << Propigate from fill on to end.  >> <<04567>>17600000
TOS := ACB'BSIZE - 1;                                          <<04567>>17605000
MOVE'DS'5;               << Propigate that there fill!      >> <<04567>>17610000
                                                               <<04567>>17615000
END;                                                           <<04567>>17620000
                                                               <<04567>>17625000
$PAGE                                                          <<06511>>17630000
SUBROUTINE STUFF'IOQX(IOQX);                                   <<04567>>17635000
VALUE IOQX;INTEGER IOQX;                                       <<04567>>17640000
                                                               <<04567>>17645000
<<**********************************************************>> <<04567>>17650000
<< Stuffs the IOQX into the correct word of the AFT.  Used  >> <<04567>>17655000
<< for no-wait, unbuffered I/O.                             >> <<04567>>17660000
<<**********************************************************>> <<04567>>17665000
                                                               <<04567>>17670000
BEGIN                                                          <<04567>>17675000
                                                               <<04567>>17680000
FILENUM := ACB'FNUM;   ! For use by SETAFT define.             <<06511>>17685000
IF GLOBAL'FILENUM THEN                                         <<06511>>17690000
   BEGIN               ! Global AFT, go to global AFT DST      <<06511>>17695000
   EXCHANGEDB(GLOBAL'AFT'DSTN);                                <<06511>>17700000
   @AFT := \FILENUM\ * AFTENTRY;                               <<06511>>17705000
   END                                                         <<06511>>17710000
ELSE                                                           <<06511>>17715000
   BEGIN                                                       <<06511>>17720000
   IF DSTX <> 0 THEN EXCHANGEDB(0);                            <<06511>>17725000
   SETAFT;             ! Set to AFT in the stack.              <<06511>>17730000
   END;                                                        <<06511>>17735000
AFTIOQX := IOQX;                                               <<06511>>17740000
EXCHANGEDB(DSTX);      ! Back to users buffer.                 <<06511>>17745000
END;                                                           <<04567>>17750000
                                                               <<06511>>17755000
SUBROUTINE CLEAR'NOBUFF;                                       <<04567>>17760000
                                                               <<04567>>17765000
<<**********************************************************>> <<04567>>17770000
<< Clear the users buffer in the no-buff case with fill     >> <<04567>>17775000
<< characters.  This is used when reading from an un-allo-  >> <<04567>>17780000
<< cated extent no-buff.  FCONV'BLK does not allocate the   >> <<04567>>17785000
<< extent, thus saving much time and disc space!  RIO files >> <<04567>>17790000
<< always fill w / 0's so that the ART shows no active recs.>> <<04567>>17795000
<<**********************************************************>> <<04567>>17800000
                                                               <<04567>>17805000
BEGIN                                                          <<04567>>17810000
                                                               <<04567>>17815000
IF ACB'RIO                                                     <<04567>>17820000
   THEN T1 := 0                                                <<04567>>17825000
   ELSE T1 := FILL;                                            <<04567>>17830000
                                                               <<04567>>17835000
IF TCOUNT < 0 THEN                                             <<04567>>17840000
   BEGIN                   << Byte count, use MOVE bytes.   >> <<04567>>17845000
   @BTARGET := @TARGET * 2;                                    <<04567>>17850000
   BTARGET(0) := BYTE(T1);                                     <<04567>>17855000
   MOVE BTARGET(1) := BTARGET(0), (CTT-1);                     <<04567>>17860000
   CHAR'TRNSFRD := -CTT;   << Negative byte TLOG.           >> <<04578>>17865000
   END                                                         <<04567>>17870000
ELSE                                                           <<04567>>17875000
   BEGIN                   << Word count, use MOVE words.   >> <<04567>>17880000
   TARGET(0) := T1;                                            <<04567>>17885000
   MOVE TARGET(1) := TARGET(0), (WTT-1);                       <<04567>>17890000
   CHAR'TRNSFRD := WTT;    << Positive word TLOG.           >> <<04578>>17895000
   END;                                                        <<04567>>17900000
                                                               <<04567>>17905000
<<**********************************************************>> <<04567>>17910000
<< Now, if we are going no-wait I/O, we must kludge the     >> <<04567>>17915000
<< IOQX in the AFT.  We place a negative number in IOQX.    >> <<04567>>17920000
<< IOWAIT will recognize this as a stub and process it as   >> <<04567>>17925000
<< successful when called by the user at a later time.      >> <<04567>>17930000
<<**********************************************************>> <<04567>>17935000
                                                               <<04567>>17940000
IF NOWAIT THEN                                                 <<04567>>17945000
   BEGIN                                                       <<04567>>17950000
   ACB'TLOG := CHAR'TRNSFRD;<< Save TLOG for later.         >> <<04578>>17955000
   STUFF'IOQX(STUB'IOQX);  << Place -1 kludge in AFT.       >> <<04567>>17960000
   ACB'NOWAITMODE := 0;    << No-wait READ.                 >> <<04567>>17965000
   GO SETX;                << Claim successful read.        >> <<04567>>17970000
   END;                                                        <<04567>>17975000
                                                               <<04567>>17980000
END;                                                           <<04567>>17985000
$PAGE                                                          <<04557>>17990000
LOGICAL SUBROUTINE CHKVARBLK;                                  <<04578>>17995000
                                                               <<04578>>18000000
<<**********************************************************>> <<04578>>18005000
<< On NOBUF read or write, validate variable record struc-  >> <<04578>>18010000
<< ture within block(s) and count records.                  >> <<04578>>18015000
<<   Output variables:                                      >> <<04578>>18020000
<<      CHKVARBLK -  TRUE of a bad variable structure found.>> <<04578>>18025000
<<                   FALSE if A-OK.                         >> <<04578>>18030000
<<      NUM'VAR'RECS - The number of records read this xfer.>> <<04578>>18035000
<<      VAR'WORD'CNT - The number of words read this xfer,  >> <<04578>>18040000
<<                     this will be rounded up to the near- >> <<04578>>18045000
<<                     est block multiple.                  >> <<04578>>18050000
<<**********************************************************>> <<04578>>18055000
                                                               <<04578>>18060000
BEGIN                                                          <<04578>>18065000
NUM'VAR'RECS := 0D;                                            <<04578>>18070000
NUM'VAR'BLKS := 0;                                             <<04578>>18075000
VAR'WORD'CNT := 0;                                             <<04578>>18080000
BAD'VAR'BLK := FALSE;                                          <<05014>>18085000
                                                               <<04578>>18090000
IF OUTPUT'SPOOLF AND READ THEN                                 <<06039>>18095000
   BEGIN    << Spoofle FREAD, get record number from blk.   >> <<06039>>18100000
   TOS := TARGET(ACB'BSIZE -2);  << High order word.        >> <<06039>>18105000
   TOS := TARGET(ACB'BSIZE -1);  << Low  order word.        >> <<06039>>18110000
   ACB'FPTR := TOS;              << Set file pointer.       >> <<06039>>18115000
   END;                                                        <<06039>>18120000
                                                               <<04578>>18125000
WHILE NUM'VAR'RECS < NMAX AND VAR'WORD'CNT < WTT AND           <<04578>>18130000
      NOT BAD'VAR'BLK DO                                       <<04578>>18135000
   BEGIN                                                       <<04578>>18140000
   NUM'VAR'BLKS := NUM'VAR'BLKS + 1;                           <<04578>>18145000
   IF OUTPUT'SPOOLF AND WRITE THEN                             <<06039>>18150000
      BEGIN    << Spoofle FWRITE, put record into block.    >> <<06039>>18155000
      TOS := ACB'FPTR+NUM'VAR'RECS;                            <<06039>>18160000
      TARGET((ACB'BSIZE * NUM'VAR'BLKS) - 1) := TOS;           <<06039>>18165000
      TARGET(X - 1) := TOS;  << Low then high order words.  >> <<06039>>18170000
      END;                                                     <<06039>>18175000
   END'OF'BLK := FALSE;                                        <<05014>>18180000
   DO BEGIN                                                    <<04578>>18185000
      VAR'REC'SIZE := TARGET(VAR'WORD'CNT);  << Byte count. >> <<04578>>18190000
      IF VAR'REC'SIZE = -1                                     <<04578>>18195000
         THEN END'OF'BLK := TRUE      << End of block, OK   >> <<04578>>18200000
      ELSE IF VAR'REC'SIZE < 0 OR VAR'REC'SIZE > ACB'RSIZE     <<04578>>18205000
         THEN BAD'VAR'BLK := TRUE     << Invalid byte count!>> <<04578>>18210000
      ELSE IF ACB'SPECVAR AND                                  <<06039>>18215000
              VAR'REC'SIZE > INT(TARGET(VAR'WORD'CNT+1)) + 8   <<04578>>18220000
         THEN BAD'VAR'BLK := TRUE  << Byte cnts don't jive. >> <<04578>>18225000
      ELSE                                                     <<04578>>18230000
         BEGIN                                                 <<04578>>18235000
         << # of words in record, including count word.     >> <<04578>>18240000
         VAR'REC'SIZE := ((VAR'REC'SIZE+1)/2)+1;               <<04578>>18245000
         VAR'WORD'CNT := VAR'WORD'CNT + VAR'REC'SIZE;          <<04578>>18250000
         << Check for overflow.  User must read a valid blk.>> <<04578>>18255000
         IF VAR'WORD'CNT > NUM'VAR'BLKS * ACB'BSIZE OR         <<04578>>18260000
            VAR'WORD'CNT + 1 > WTT                             <<04578>>18265000
            THEN BAD'VAR'BLK := TRUE;  <<    Overflow       >> <<04578>>18270000
         NUM'VAR'RECS := NUM'VAR'RECS + 1D;                    <<04578>>18275000
         END;                                                  <<04578>>18280000
      END                                                      <<04578>>18285000
   UNTIL BAD'VAR'BLK OR END'OF'BLK;                            <<04578>>18290000
                                                               <<04578>>18295000
   << Now jump to the beginning of the next block .         >> <<04578>>18300000
   VAR'WORD'CNT := NUM'VAR'BLKS * ACB'BSIZE;                   <<04578>>18305000
   END;                                                        <<04578>>18310000
                                                               <<04578>>18315000
CHKVARBLK := BAD'VAR'BLK;                                      <<04578>>18320000
END;                                                           <<04578>>18325000
$PAGE                                                          <<04557>>18330000
                                                                        18335000
   LOGICAL SUBROUTINE WAYT (REPORT);                                    18340000
                                                               <<04590>>18345000
   <<*******************************************************>> <<04590>>18350000
   << Waits for completion of the I/O request against the   >> <<04590>>18355000
   << current buffer, as specified by the BUFDISP pointer.  >> <<04590>>18360000
   << If the I/O completes unsuccessfully, it is optionally >> <<04590>>18365000
   << indicated by the result.                              >> <<04590>>18370000
   <<                                                       >> <<04590>>18375000
   <<   Input parameters:                                   >> <<04590>>18380000
   <<       REPORT - Report I/O error flag                  >> <<04590>>18385000
   <<          FALSE - Ignore all I/O errors                >> <<04590>>18390000
   <<          TRUE - Report all errors except End-of-Tape  >> <<04590>>18395000
   <<                 and recovered tape parity I/O errors. >> <<04590>>18400000
   <<                                                       >> <<04590>>18405000
   <<   Output value:                                       >> <<04590>>18410000
   <<       WAYT - I/O error flag                           >> <<04590>>18415000
   <<          FALSE - OK                                   >> <<04590>>18420000
   <<          TRUE - reportable I/O error                  >> <<04590>>18425000
   <<*******************************************************>> <<04590>>18430000
                                                               <<04590>>18435000
      VALUE REPORT;                                                     18440000
      LOGICAL REPORT;                                                   18445000
      BEGIN                                                             18450000
      IF NOWAIT'COMP AND BLK'IOQX <> 0 THEN                    <<04578>>18455000
         BEGIN          << I/O pending >>                               18460000
         IO'STATUS := WAITFORIO(BLK'IOQX);                     <<04578>>18465000
$  IF X1 = ON                                                           18470000
         IF <> THEN FTROUBLE(479);  << error >>                         18475000
$  IF                                                                   18480000
         BLK'IOCB := IO'STATUS;  << Save T-log and status >>   <<04578>>18485000
         BLK'IOQX := 0          << Clear IOQX >>                        18490000
         END;                                                           18495000
      BLK'IOCOMP := 0;      << Buffer clean and no I/O going >>         18500000
      ACB'STATUS := BLK'LSTAT;  << Report I/O status >>                 18505000
      IF ACB'STATUS <> 1 AND REPORT THEN                                18510000
         BEGIN                 << Error to report, maybe >>             18515000
         IF ACB'GSTATUS = 2 THEN                                        18520000
            BEGIN              << Hardware EOF. >>                      18525000
            ACB'EOFS := 3;                                              18530000
            ACB'EOF := 1;                                               18535000
            END;                                                        18540000
         ACB'ERROR := IOSTAT(ACB'STATUS);    << Convert error nr. >>    18545000
         IF (ACB'ERROR <> EOT LAND ACB'ERROR <> TAPERREC) OR   <<06038>>18550000
            (ACB'ERROR = TAPERREC LAND ACB'TAPEERROR    ) THEN <<06038>>18555000
            BEGIN                                                       18560000
            WAYT := TRUE;     << Report error >>                        18565000
            RETURN                                                      18570000
            END                                                         18575000
         END;         << error to report, maybe >>                      18580000
                                                                        18585000
   << I/O has been completed. If reading, pad the block with fill       18590000
     characters if it was short. >>                                     18595000
                                                                        18600000
      IF NOT BLK'IOOUT AND BLK'TLOG < DATASIZE                 <<06048>>18605000
           AND ACB'FIXED THEN                                  <<00630>>18610000
         BEGIN     << Pad short block read. >>                 <<00630>>18615000
         T1 := FILL;                                                    18620000
         TOS := ACBM'PACBV'DSTN;                               <<06511>>18625000
         TOS := BUFDISP+BLK'TLOG;    << @End of user buffer >>          18630000
         TOS := T1ADR;                                                  18635000
         TOS := 1;                                                      18640000
         MOVE'DS'3;     << stuff fill in first word >>                  18645000
         ASMB(DDUP, DECA);                                              18650000
         TOS := DATASIZE-BLK'TLOG-1;                                    18655000
         MOVE'DS'5;     << propagate fill >>                            18660000
         END;                                                           18665000
      ACB'BTFRCT := ACB'BTFRCT+1D;  << bump block transfer count >>     18670000
      PUTBLKPARMS;                                             <<04591>>18675000
      END;        << of subroutine WAYT >>                              18680000
$PAGE                                                          <<04590>>18685000
LOGICAL SUBROUTINE DONT'WAYT;                                  <<04590>>18690000
                                                               <<04590>>18695000
<<**********************************************************>> <<04590>>18700000
<< Check if the I/O request against the current buffer being>> <<04590>>18705000
<< investigated has completed.  This is done for all buffers>> <<04590>>18710000
<< with I/O pending when first entering IOMOVE on buffered  >> <<04590>>18715000
<< reads and writes to free valuable DRQ entries.  This is  >> <<04590>>18720000
<< done for disk files only.                                >> <<04590>>18725000
<<**********************************************************>> <<04590>>18730000
                                                               <<04590>>18735000
BEGIN                                                          <<04590>>18740000
DONT'WAYT := FALSE;           << Assume no error to report. >> <<04590>>18745000
IF BLK'IOQX <> 0 THEN                                          <<04590>>18750000
   BEGIN                      << There is indeed I/O pending>> <<04590>>18755000
   IO'STATUS := IOSTATUS(BLK'IOQX);                            <<04590>>18760000
   IF = THEN                                                   <<04590>>18765000
      BEGIN                   << I/O completed, clean up    >> <<04590>>18770000
      BLK'IOCB := IO'STATUS;  << Save T-log and status.     >> <<04590>>18775000
      BLK'IOQX := 0;          << All done!                  >> <<04590>>18780000
      BLK'IOCOMP := 0;        << Clean buffer, no I/O pend. >> <<04590>>18785000
      BLK'DONTWAIT := 1;      << Indicate DONT'WAIT I/O.    >> <<04590>>18790000
                                                               <<04590>>18795000
      <<****************************************************>> <<04590>>18800000
      << If reading, pad the block with fill characters if  >> <<04590>>18805000
      << it was short.                                      >> <<04590>>18810000
      <<****************************************************>> <<04590>>18815000
                                                               <<04590>>18820000
      IF NOT BLK'IOOUT AND BLK'TLOG < DATASIZE AND             <<04590>>18825000
         ACB'FIXED THEN                                        <<04590>>18830000
         BEGIN                                                 <<04590>>18835000
         T1 := FILL;               << Fill with Fill.       >> <<04590>>18840000
         TOS := ACBM'PACBV'DSTN;   << Buffer address.       >> <<06511>>18845000
         TOS := BUFDISP + BLK'TLOG;<< @END of read.         >> <<04590>>18850000
         TOS := T1ADR;             << Copy from T1.         >> <<04590>>18855000
         TOS := 1;                                             <<04590>>18860000
         MOVE'DS'3;                << Stuff fill word 1.    >> <<04590>>18865000
         TOS := ACBM'PACBV'DSTN;   << Fill from 1 on.       >> <<06511>>18870000
         TOS := BUFDISP + BLK'TLOG;                            <<04590>>18875000
         TOS := DATASIZE - BLK'TLOG - 1;                       <<04590>>18880000
         MOVE'DS'5;                << Propigate fill char.  >> <<04590>>18885000
         END;                                                  <<04590>>18890000
                                                               <<04590>>18895000
      ACB'BTFRCT := ACB'BTFRCT + 1D; << Bump blk exfer cnt. >> <<04590>>18900000
      PUTBLKPARMS;                   << Write updated head  >> <<04590>>18905000
      END;                                                     <<04590>>18910000
   END;                                                        <<04590>>18915000
                                                               <<04590>>18920000
END;                                                           <<04590>>18925000
$PAGE                                                          <<04590>>18930000
   SUBROUTINE STARTREAD(BLKNUM);                                        18935000
   VALUE BLKNUM; DOUBLE BLKNUM;                                         18940000
      << Called to start reading the specified block into the           18945000
     current buffer, as defined by the BUFDISP pointer.  >>             18950000
                                                                        18955000
      BEGIN                                                             18960000
      FCONV'ERROR := 0;                                        <<04567>>18965000
      IF ACB'ACCCL = DIRACC THEN                                        18970000
         BEGIN     << Disk >>                                           18975000
         FCONV'BLK(BLKNUM,DQ,0,0,0D,0D,0);                     <<06511>>18980000
         BLK'EXTSIZE := TOS;  << Save current extent size.  >> <<04653>>18985000
         BLK'EXTBASE := TOS;  << Save current extent base   >> <<04653>>18990000
         FCEOF := TOS;                                                  18995000
         DEL;          << STX >>                                        19000000
         FCONV'ERROR := TOS;     << Error nr. >>               <<04567>>19005000
         IF FCONV'ERROR > 0 THEN                               <<04567>>19010000
            BEGIN      << Some kind of error. >>                        19015000
            IF FCONV'ERROR <= 2 THEN                           <<04567>>19020000
               BEGIN   << Beyond EOF; don't read. >>                    19025000
               ASMB(DDEL,DEL);  << sector & LDEV >>                     19030000
               RETURN                                                   19035000
               END;                                                     19040000
            ACB'ERROR := FCONV'ERROR;   << Report error nr. >> <<04567>>19045000
            ACB'STATUS := 0;  << Clear I/O error nr. >>                 19050000
            GO PEXIT                                                    19055000
            END;       << some kind of error >>                         19060000
         LDEV := TOS;      << LDEV of requested record/block >>         19065000
         DISKADR := TOS;   << Sector number for ATTACHIO >>    <<06511>>19070000
         BLK'LDEV := LDEV;      << Logical device nr. >>       <<06511>>19075000
         BLK'DADDR := DISKADR; << Save in block header.     >> <<06511>>19080000
         END                                                            19085000
      ELSE                                                              19090000
         BEGIN      << Not disk >>                                      19095000
         IF ACB'DTYPE = MTAPE THEN SET'LPDT'BOT(LDEV,0);       <<02545>>19100000
         TOS := ACB'CTL&LSR(8);       << P1.(13:3) - EOF spec. >>       19105000
         TOS.(0:1) := ACB'INHIBCRLF;  << P1.(0:1) - inhibit CR/LF >>    19110000
         TOS := ACB'STOPCHAR&LSL(8);  << P2.(0:8) - stop character >>   19115000
         TOS.(12:1) := NOT ACB'ASCII; << ASCII/binary format >>         19120000
         P2 := TOS; P1 := TOS                                           19125000
         END;                                                           19130000
      BLK'BLOCK := BLKNUM;          << Block nr. >>                     19135000
      IF BLKNUM > ACB'HIBLK THEN ACB'HIBLK := BLKNUM;  << New high >>   19140000
      BLK'FLAGS := 1;          << Denote read in progress >>   <<04563>>19145000
                                                               <<04567>>19150000
      <<****************************************************>> <<04567>>19155000
      << If we are reading from an un-allocated extent,     >> <<04567>>19160000
      << clear the buffer and return.  FCONV'BLK will not   >> <<04567>>19165000
      << allocate the extent for this block.  This will im- >> <<04567>>19170000
      << prove performance and save disc space.             >> <<04567>>19175000
      <<****************************************************>> <<04567>>19180000
                                                               <<04567>>19185000
      IF ACB'ACCCL = DIRACC AND FCONV'ERROR = UNALLOC'EXT THEN <<04567>>19190000
         BEGIN                                                 <<04567>>19195000
         CLEAR'CURR'BUF;        << Clear buffer with fill.  >> <<04567>>19200000
         BLK'TLOG := ACB'BSIZE; << Transfered full amount.  >> <<04567>>19205000
         BLK'LSTAT := 1;        << Successful block "I/O".  >> <<04567>>19210000
         BLK'FLAGS := 0;        << No I/O in progress.      >> <<04567>>19215000
         BLK'IOQX  := 0;                                       <<04567>>19220000
         BLK'UNALLOCEXT := 1; << Indicate un-allocated ext. >> <<04625>>19225000
         PUTBLKPARMS;                                          <<04567>>19230000
         RETURN;                << Successful "I/O" return. >> <<04567>>19235000
         END;                                                  <<04567>>19240000
                                                               <<04567>>19245000
      <<****************************************************>> <<04567>>19250000
      << Normal case, do the ATTACHIO to read block.        >> <<04567>>19255000
      << Stack EXTENT parameter information for ATTACHIO &  >> <<04567>>19260000
      << indicate probable access type in FLAGS word.       >> <<04567>>19265000
      <<****************************************************>> <<04567>>19270000
                                                               <<04567>>19275000
RDAGIN:                                                                 19280000
      TOS := BLK'EXTBASE;                                      <<04653>>19285000
      TOS := BLK'EXTSIZE;                                      <<04653>>19290000
      ATTIOFLAG'CNTL := IF FREAD'MODE THEN BUF'SEQ             <<06961>>19295000
                                           ELSE BUF'DIR;       <<04653>>19300000
      IO'STATUS := ATTACHIO(LDEV,0,ACBM'PACBV'DSTN,BUFDISP,    <<06511>>19305000
           IF BLK'REVERSE THEN 13 ELSE 0,                               19310000
           ACB'BSIZE,P1,P2,ATTIOFLAGS);                                 19315000
      << Remove stacked EXTENT information                  >> <<04653>>19320000
      ASMB(DDEL,DEL);                                          <<04653>>19325000
      IF WAITIO'COMP THEN                                      <<04578>>19330000
         BEGIN     << Input has completed; check for EOF >>             19335000
         IF ERR'STAT = EOFSTAT AND LABEL'DEVICE  THEN          <<04578>>19340000
            BEGIN      << is next reel available? >>           <<02545>>19345000
            REELSWITCH(LDEV,0);                                <<02545>>19350000
            IF = THEN                                          <<02545>>19355000
               BEGIN      << Next reel has been mounted. >>    <<02545>>19360000
               ACB'BTFRCT := -1D;                              <<02545>>19365000
               GO RDAGIN;                                      <<02545>>19370000
               END                                             <<02545>>19375000
            ELSE IF < THEN WAITIO'STATUS := NAVLSTAT           <<04578>>19380000
            ELSE ACB'EOF := 1;      << Real EOF. >>            <<02545>>19385000
            END;                                               <<02545>>19390000
         BLK'IOCB := IO'STATUS;    << save status >>           <<04578>>19395000
         BLK'IOQX := 0;    << don't call WAITFORIO >>                   19400000
         END   << input completed. BLK'IOCOMP=1 to call FINISHREAD >>   19405000
      ELSE                                                              19410000
         BEGIN      << Input now in progress >>                         19415000
         << Ignore status and save IOQ Index.               >> <<04578>>19420000
         BLK'IOQX := NOWAIT'IOQX;                              <<04578>>19425000
         END;                                                           19430000
      PUTBLKPARMS;                                                      19435000
      END;   << of subroutine STARTREAD >>                              19440000
$PAGE                                                          <<04557>>19445000
   SUBROUTINE FINISHREAD(IO'PENDING);                          <<04590>>19450000
   VALUE IO'PENDING;LOGICAL IO'PENDING;                        <<04590>>19455000
                                                               <<04590>>19460000
   <<*******************************************************>> <<04590>>19465000
   << Waits for completin of a pending read operation.  If  >> <<04590>>19470000
   << and error occcured, the block buffer is marked empty  >> <<04590>>19475000
   << and the block pointer is advanced for serial I/O.     >> <<04590>>19480000
   << If the block has no I/O pending on it, then it could  >> <<04590>>19485000
   << have come from a prior completed pre-read.  Check the >> <<04590>>19490000
   << block status for errors.                              >> <<04590>>19495000
   << Input variables:                                      >> <<04590>>19500000
   <<     IO'PENDING -                                      >> <<04590>>19505000
   <<        TRUE    -  I/O is pending on this block, call  >> <<04590>>19510000
   <<                   WAYT to check the I/O status.       >> <<04590>>19515000
   <<        FALSE   -  I/O is not pending, check the stat- >> <<04590>>19520000
   <<                   us of the block and report any err- >> <<04590>>19525000
   <<                   ors that occured.  This could occur >> <<04590>>19530000
   <<                   if DONT'WAYT was called to complete >> <<04590>>19535000
   <<                   a pre-read.  The status of the I/O  >> <<04590>>19540000
   <<                   is not checked at that time.        >> <<04590>>19545000
   <<*******************************************************>> <<04590>>19550000
                                                               <<04590>>19555000
   BEGIN                                                       <<04590>>19560000
   IF NOT IO'PENDING THEN                                      <<04590>>19565000
      BEGIN                 << Block was from a pre-read.   >> <<04590>>19570000
      BLK'DONTWAIT := 0;    << Clear don't wait bit.        >> <<04590>>19575000
      IF BLK'LSTAT <> 1 THEN                                   <<04590>>19580000
         BEGIN              << An error occured on the blk. >> <<04590>>19585000
         ACB'STATUS := BLK'LSTAT;                              <<04590>>19590000
         ACB'ERROR  := IOSTAT(ACB'STATUS);                     <<04590>>19595000
         BLK'BLOCK  := -1D;                                    <<04590>>19600000
         GO PEXIT;          << NOW, report the ERROR!       >> <<04590>>19605000
         END;                                                  <<04590>>19610000
      END                                                      <<04590>>19615000
   ELSE                                                        <<04590>>19620000
      IF WAYT(1) THEN                                                   19625000
         BEGIN          << I/O error. Go to next block >>               19630000
         IF ACB'DTYPE=SDISC OR ACB'DTYPE=MTAPE THEN            <<00188>>19635000
            IF ACB'VARIABLE THEN  << Variable record format? >>         19640000
               ACB'BLK := ACB'BLK+1D                                    19645000
            ELSE                                                        19650000
               ACB'FPTR := (BLOCK+1D)*DBLKFACT;                         19655000
         BLK'BLOCK := -1D;  << mark buffer empty >>                     19660000
         GO PEXIT                                                       19665000
         END;       << of I/O error >>                                  19670000
   PUTBLKPARMS;                                                <<04590>>19675000
   END;          << of subroutine FINISHREAD >>                <<04590>>19680000
$PAGE                                                          <<04557>>19685000
   SUBROUTINE STARTWRITE;                                               19690000
      << Called when the block associated with the current              19695000
        buffer must be written to complete an I/O operation.            19700000
        The current buffer is that defined by the BUFDISP pointer. >>   19705000
                                                                        19710000
      BEGIN                                                             19715000
      IF ACB'ACCCL = DIRACC THEN                                        19720000
         BEGIN                                                          19725000
         DISKADR := BLK'DADDR;                                 <<06511>>19730000
         LDEV := BLK'LDEV;                                     <<06511>>19735000
         END                                                            19740000
      ELSE                                                              19745000
         BEGIN        << Not disk. Set up ATTIO params >>               19750000
         TOS := ACB'CTL;    << P1 - carriage control >>                 19755000
         TOS := ACB'LPCTL;  << P2.(14:2) - line & page control >>       19760000
         TOS.(13:1) := 1;   << allow tape write past EOT >>    <<02054>>19765000
         TOS.(12:1) := NOT ACB'ASCII;  << ASCII/binary format >>        19770000
         P2 := TOS; P1 := TOS                                           19775000
         END;                                                           19780000
      IF BLK'BLOCK > ACB'HIBLK THEN ACB'HIBLK := BLK'BLOCK;             19785000
      BLK'FLAGS := 5;      << Denote write in progress >>               19790000
      IF ACB'DTYPE = MTAPE AND                                 <<02652>>19795000
        (NOT (ACB'UNDEFINED) OR BC<>0) THEN                    <<02652>>19800000
         BEGIN     << Magtape and non-zero write request >>    <<02652>>19805000
         IO'STATUS := WRITE'DENSITY(LDEV);                     <<04578>>19810000
         IF ERR'STAT <> 1 THEN                                 <<04578>>19815000
            GO POST'IO;  << Skip write.  Post error. >>        <<02652>>19820000
         << OK continue with write.                         >> <<04578>>19825000
         END;                                                  <<02652>>19830000
                                                               <<04591>>19835000
      <<****************************************************>> <<04591>>19840000
      << When writing to serialio, we must back space one   >> <<04591>>19845000
      << block for each pre-read performed past the current >> <<04591>>19850000
      << block to properly position the head for the write. >> <<04591>>19855000
      << This number, ACB'TAPEDISP, is obtained in FWRITE   >> <<04591>>19860000
      << by calling FQUIESCE'IO to count the pre-reads.     >> <<04591>>19865000
      <<****************************************************>> <<04591>>19870000
                                                               <<04591>>19875000
      IF ACB'ACCCL = SERIALIO AND ACB'TAPEDISP > 0 THEN        <<04591>>19880000
         BEGIN  << Do Back Space Record for each pre-read.  >> <<04591>>19885000
         WHILE ACB'TAPEDISP > 0 DO                             <<04591>>19890000
            BEGIN                                              <<04591>>19895000
            IO'STATUS := ATTACHIO(LDEV,0,0,0,12,0,0,0,BFLAGS); <<04591>>19900000
            IF ERR'STAT <> 1 THEN                              <<04591>>19905000
               BEGIN        << Error on BSR, check status.  >> <<04591>>19910000
               ACB'ERROR := IOSTAT(WAITIO'STATUS);             <<04591>>19915000
               IF ACB'ERROR <> EOF AND ACB'ERROR <> EOT AND    <<04591>>19920000
                  ACB'ERROR <> TAPERREC                        <<04591>>19925000
                  THEN GO POST'IO;  << True error on BSR.   >> <<04591>>19930000
               END;                                            <<04591>>19935000
            ACB'TAPEDISP := ACB'TAPEDISP - 1;                  <<04591>>19940000
            END;                                               <<04591>>19945000
         ACB'HIBLK := BLK'BLOCK;                               <<04591>>19950000
         END;                                                  <<04591>>19955000
                                                               <<04591>>19960000
      << Determine how much to write.                       >> <<04578>>19965000
                                                               <<04578>>19970000
      IF ACB'FIXED OR ACB'ACCCL = DIRACC THEN                  <<04578>>19975000
         ATTIO'COUNT := ACB'BSIZE                              <<04578>>19980000
      ELSE IF ACB'UNDEFINED THEN                               <<04578>>19985000
         ATTIO'COUNT := -BC - CCTL << Include CCTL and data.>> <<06037>>19990000
      ELSE                                                     <<04578>>19995000
         ATTIO'COUNT := REC'PNTR + 1;                          <<04578>>20000000
                                                               <<04578>>20005000
                                                               <<04578>>20010000
      <<****************************************************>> <<04578>>20015000
      << Perform ATTACHIO write of buffer to device.  For   >> <<04578>>20020000
      << labeled tape or serial disc, we perform WAIT FOR   >> <<04578>>20025000
      << I/O and check the status now.  For all other files >> <<04578>>20030000
      << (unlabeled tape, disc, etc.), we do NOWAIT I/O.    >> <<04578>>20035000
      << Stack EXTENT parameter information for ATTACHIO &  >> <<04578>>20040000
      << indicate probable access type in FLAGS word.       >> <<04578>>20045000
      <<****************************************************>> <<04578>>20050000
                                                               <<04578>>20055000
      TOS := BLK'EXTBASE;                                      <<04653>>20060000
      TOS := BLK'EXTSIZE;                                      <<04653>>20065000
      ATTIOFLAG'CNTL := IF FWRITE'MODE THEN BUF'SEQ            <<06961>>20070000
                                           ELSE BUF'DIR;       <<04653>>20075000
      ATTIOFLAG'CRITVER := ACB'QUIESCE;                        <<06961>>20080000
      ATTIOFLAG'SERIAL  := ACB'SERIALIO;                       <<06961>>20085000
      IO'STATUS := ATTACHIO(LDEV,0,ACBM'PACBV'DSTN,BUFDISP,1,  <<06511>>20090000
                            ATTIO'COUNT,P1,P2,ATTIOFLAGS);     <<04578>>20095000
      << Remove stacked EXTENT information                  >> <<04653>>20100000
      ASMB(DDEL,DEL);                                          <<04653>>20105000
      IF WAITIO'COMP THEN                                      <<04578>>20110000
         BEGIN   << Output has completed. Check for EOT marker >>       20115000
         IF ERR'STAT = EOTSTAT AND LABEL'DEVICE  THEN          <<04578>>20120000
            BEGIN      << is next reel available? >>           <<02545>>20125000
            REELSWITCH(LDEV,1);                                <<02545>>20130000
            IF = THEN                                          <<02545>>20135000
               BEGIN       << Next reel mounted. >>            <<02545>>20140000
               ACB'BTFRCT := -1D;                              <<02545>>20145000
               WAITIO'STATUS := 1;    << No error >>           <<04578>>20150000
               END                                             <<02545>>20155000
            ELSE WAITIO'STATUS := NAVLSTAT;    << =REPLY 0. >> <<04591>>20160000
            END;                                               <<02545>>20165000
POST'IO:                                                       <<02652>>20170000
         BLK'IOCB:= IO'STATUS;        << save status >>        <<04578>>20175000
         END         << output has completed >>                         20180000
      ELSE                                                              20185000
         BEGIN                                                          20190000
         << Ignore status and save IOQ Index.                  <<04578>>20195000
         BLK'IOQX := NOWAIT'IOQX;                              <<04578>>20200000
         END;                                                           20205000
      PUTBLKPARMS;                                                      20210000
      END;          << of subroutine STARTWRITE >>                      20215000
$PAGE                                                          <<04578>>20220000
   SUBROUTINE REVERSEBUF(SIZE);                                         20225000
   VALUE SIZE; LOGICAL SIZE;                                   <<02076>>20230000
<< Used by FREADBACKWARD to reverse the data in the user's              20235000
buffer.  >>                                                             20240000
                                                                        20245000
      BEGIN                                                             20250000
      @BTARGET := @TARGET&LSL(1);                                       20255000
                                                               <<04578>>20260000
      LOC := 0;                                                <<04578>>20265000
      WHILE LOC < SIZE DO                                      <<04578>>20270000
         BEGIN                                                          20275000
         TOS := BTARGET(LOC);                                  <<04578>>20280000
         TOS := BTARGET(LOG(CTT)-1-LOC);                       <<04578>>20285000
         ASMB(XCH);                                            <<02076>>20290000
         BTARGET(X) := TOS;                                    <<02076>>20295000
         BTARGET(LOC) := TOS;                                  <<04578>>20300000
         LOC := LOC+1;                                         <<04578>>20305000
         END;                                                           20310000
      END;       << subroutine REVERSEBUF >>                            20315000
                                                               <<06511>>20320000
DOUBLE SUBROUTINE SCANVARBLOCK;                                <<HM.00>>20325000
   << Analyzes the block contained in the current buffer.        HM.00  20330000
                                                                 HM.00  20335000
     Returns - word 0 - buf seg relative addr of block delim     HM.00  20340000
               word 1 - # records in the block. >>             <<02072>>20345000
   BEGIN                                                       <<HM.00>>20350000
   << Scan block for block delimiter >>                        <<02072>>20355000
   TOS := T1ADR;    << set up for record scan >>               <<02072>>20360000
   TOS := ACBM'PACBV'DSTN;                                     <<06511>>20365000
   TOS := BUFDISP;                                             <<02072>>20370000
   DO                                                          <<HM.00>>20375000
      BEGIN       << scan next record >>                       <<02072>>20380000
      TOS := 1;                                                <<02072>>20385000
      ASMB(MDS 1);   << get the count or block delimiter >>    <<02072>>20390000
      IF T1 <> -1 THEN                                         <<HM.00>>20395000
         BEGIN    << Not a delimiter.  Skip over the record >> <<02072>>20400000
         S5 := S5+1;    << Bump block record count >>          <<02072>>20405000
         S2 := S2-1;    << Maintain MDS destination at T1 >>   <<02072>>20410000
         TOS := TOS+(T1+1)&LSR(1);                             <<02072>>20415000
         IF NOT (BUFDISP <= S0 <= BUFDISP+ACB'BSIZE) THEN      <<HM.00>>20420000
            ERREXIT(BADVARBLK);                                <<HM.00>>20425000
         END;                                                  <<HM.00>>20430000
      END UNTIL T1 = -1;                                       <<HM.00>>20435000
   S6 := TOS-1;    << Return delimiter address >>              <<02072>>20440000
   ASMB(DEL,DDEL);                                             <<HM.00>>20445000
   END;    << subroutine SCANVARBLOCK >>                       <<02072>>20450000
                                                               <<HM.00>>20455000
$PAGE                                                          <<04557>>20460000
SUBROUTINE ADJUSTCIRFILE;                                      <<HM.00>>20465000
   << Deletes the first block from the file. >>                <<02072>>20470000
   BEGIN                                                       <<HM.00>>20475000
   IF ACB'VARIABLE THEN                                        <<HM.00>>20480000
      BEGIN    << Must count records in the first block. >>    <<02072>>20485000
      ACB'BLK := ACB'BLK-1D;                                   <<02072>>20490000
      STARTREAD(0D);                                           <<HM.00>>20495000
      FINISHREAD(TRUE);                                        <<04590>>20500000
      TOS := SCANVARBLOCK;                                     <<02072>>20505000
      ASMB(ZROB);                                              <<HM.00>>20510000
      END                                                      <<HM.00>>20515000
   ELSE                                                        <<HM.00>>20520000
      TOS := DBLKFACT;                                         <<02072>>20525000
                                                               <<HM.00>>20530000
   << Adjust counters >>                                       <<02072>>20535000
   ACB'FPTR := ACB'FPTR-DS1;                                   <<02072>>20540000
   FADJUSTCIRFILE(*,DQ);       << adjust FCB >>                <<06511>>20545000
   BLOCK := BLOCK-1D;                                          <<02072>>20550000
                                                               <<HM.00>>20555000
   << Decrement block numbers in the buffers. >>               <<02072>>20560000
   PUTBLKPARMS;                                                <<HM.00>>20565000
   TOS := I;  I := 0;                                          <<02072>>20570000
   DO                                                          <<HM.00>>20575000
      BEGIN     << Adjust a buffer >>                          <<02072>>20580000
      GETBLKPARMS;                                             <<HM.00>>20585000
      IF BLK'BLOCK <> -1D THEN BLK'BLOCK := BLK'BLOCK-1D;      <<02049>>20590000
      PUTBLKPARMS;                                             <<HM.00>>20595000
      END UNTIL (I := I+1) > ACB'NUMBUFS;                      <<06511>>20600000
   I := TOS;                                                   <<02072>>20605000
   GETBLKPARMS;                                                <<HM.00>>20610000
   END;    << subroutine ADJUSTCIRFILE >>                      <<02072>>20615000
                                                               <<HM.00>>20620000
                                                               <<HM.00>>20625000
SUBROUTINE FINDFILEND;                                         <<HM.00>>20630000
  << Used on first write to a variable record file which was   <<02072>>20635000
  << opened with Append access.  Reads in last block and finds <<02072>>20640000
  << location of the next available record. >>                 <<02072>>20645000
   BEGIN                                                       <<HM.00>>20650000
   << Read in the last block written >>                        <<02072>>20655000
   I := 0;  GETBLKPARMS;                                       <<02072>>20660000
   STARTREAD(ACB'BLK);                                         <<HM.00>>20665000
   FINISHREAD(TRUE);                                           <<04590>>20670000
   TOS := SCANVARBLOCK;    << Find end of the data area >>     <<02072>>20675000
   DEL;            << discard nr. of records >>                <<02072>>20680000
   REC'PNTR := S0-BUFDISP;                                     <<04578>>20685000
   BUFDISP := TOS;                                             <<02072>>20690000
   END;    << subroutine FINDFILEND >>                         <<02072>>20695000
$PAGE " IOMOVE - UNBUFFERED "                                  <<HM.00>>20700000
<< * * * $$$$   Begin execution    $$$$ * * * >>               <<HM.00>>20705000
                                                               <<HM.00>>20710000
$  IF X0 = ON                                                           20715000
   IF MONOTHER THEN     << monitoring? >>                               20720000
      BEGIN                                                             20725000
      FTITLE("IOMO","VE  ",0D,0D);                                      20730000
      DEBUG                                                             20735000
      END;                                                              20740000
$  IF                                                                   20745000
                                                                        20750000
   <<* * * Initialize variables and check request * * *>>               20755000
                                                                        20760000
   PCBPT := CURPRC;                                            <<06511>>20765000
   STKDST := SPCBSTKDST;                                       <<06511>>20770000
   PUSH(DL,Q);                                                          20775000
   ASMB(XCH,SUB);            << DL-Q for Q-rel addressing >>            20780000
   ASMB(DUP,STAX);                                                      20785000
   X := TOS-AQM1(X);         << (a-Q) <== (DL-Q) - (DL-a) >>            20790000
   Q'1'A := 1-X;             << 1 - (a-Q) >>                            20795000
   IF ACB'SPXDDX <> 0                                          <<06039>>20800000
      THEN FSOPEN'SPOOLF := TRUE; << Spooler NOBUF access.  >> <<06039>>20805000
                                                               <<04578>>20810000
   <<*******************************************************>> <<04578>>20815000
   << TCOUNT cannot exceed 16K words since BC, used as a    >> <<04578>>20820000
   << positive byte count in BUFFERED files, would exceed   >> <<04578>>20825000
   << one integer word.  When using BC in the NOBUF case,   >> <<04578>>20830000
   << care must be taken to always use it as a logical!!!   >> <<04578>>20835000
   <<*******************************************************>> <<04578>>20840000
                                                               <<04578>>20845000
   IF TCOUNT > MAX'WORD'TCOUNT AND NOT ACB'INHIBITBUF          <<04143>>20850000
      THEN ERREXIT(BADTCOUNT);                                 <<04143>>20855000
                                                               <<04143>>20860000
   BC := IF TCOUNT < 0 THEN -TCOUNT ELSE TCOUNT&LSL(1);                 20865000
   WC := (BC+1)&LSR(1);                                                 20870000
   FILL := IF ACB'ASCII THEN "  " ELSE 0;  <<fill character>>           20875000
   NEWEOF := FALSE;                                                     20880000
   RSIZE := (ACB'RSIZE+1)&LSR(1);  << Rec. size (words) >>              20885000
   RSIZE'BRU := RSIZE * 2;  << Record size,Bytes Rounded Up >> <<04644>>20890000
   DBLKFACT := DOUBLE(ACB'BLKFACT);                                     20895000
   DATASIZE := IF NOT ACB'RIO THEN ACB'BSIZE  << words >>               20900000
               ELSE RSIZE*BLKFACT;                             <<00630>>20905000
   LDEV := ACB'DADDR;     << LDEV of device, in case not disk >>        20910000
   MR := ACB'MULTIREC;        << multi-record mode >>                   20915000
   IF NOT ACB'VARIABLE THEN                                             20920000
      BEGIN           << Non-variable record format >>                  20925000
      TOS := ACB'FPTR;     << record number >>                          20930000
      X := BLKFACT;        << blocking factor >>                        20935000
      DIVD;                                                             20940000
      RXB := S0;                                                        20945000
      REC'PNTR := TOS*RSIZE;      << record offset in block >> <<04578>>20950000
      BLOCK := TOS;        << quotient = block nr. >>                   20955000
      END                                                               20960000
   ELSE                                                                 20965000
      BEGIN         << Variable records >>                              20970000
      REC'PNTR := ACB'BUFUSED;                                 <<04578>>20975000
      BLOCK := ACB'BLK;                                                 20980000
      END;                                                              20985000
$PAGE                                                          <<04557>>20990000
   <<*******************************************************>> <<06039>>20995000
   <<                     UNBUFFERED                        >> <<06039>>21000000
   <<*******************************************************>> <<06039>>21005000
                                                               <<06039>>21010000
   IF ACB'INHIBITBUF THEN                                      <<06039>>21015000
   BEGIN                                                       <<06039>>21020000
                                                               <<06039>>21025000
   IF ACB'SPXDDX < 0                                           <<06039>>21030000
      THEN OUTPUT'SPOOLF := TRUE;  << Output spoolfle access>> <<06039>>21035000
                                                               <<06039>>21040000
   <<*******************************************************>> <<06039>>21045000
   <<                  READ - UNBUFFERED                    >> <<06039>>21050000
   <<*******************************************************>> <<06039>>21055000
                                                               <<06039>>21060000
   IF READ THEN                                                <<06039>>21065000
   BEGIN                                                       <<06039>>21070000
                                                                        21075000
   <<*******************************************************>> <<04578>>21080000
   << If no-wait completion, then IOWAIT has called us to   >> <<04578>>21085000
   << complete a no-wait I/O request.  Set the xfer counts  >> <<04578>>21090000
   << from the ACB'TLOG, which were set in IOWAIT when com- >> <<04578>>21095000
   << pleting the I/O, and complete the read.  The I/O stat->> <<04578>>21100000
   << us was set in IOWAIT and placed in ACB'STATUS.        >> <<04578>>21105000
   <<*******************************************************>> <<04578>>21110000
                                                               <<04578>>21115000
   IF NOWAITCOMP THEN                                                   21120000
      BEGIN      << No-wait I/O completion >>                           21125000
      CHAR'TRNSFRD := ACB'TLOG;                                <<04578>>21130000
      IF CHAR'TRNSFRD < 0                                      <<04578>>21135000
         THEN CTT := \CHAR'TRNSFRD\  << Positive characters.>> <<04578>>21140000
         ELSE CTT'L := CHAR'TRNSFRD'L * 2;                     <<04578>>21145000
      WTT'L := (CTT'L+1) / 2;       << Positive words.      >> <<04578>>21150000
      ACB'TLOG := 0;                                           <<01698>>21155000
      GO COMPREAD                                                       21160000
      END;                                                              21165000
                                                                        21170000
   ACB'TLOG := 0;                                                       21175000
   ACB'ERROR := 0;                                                      21180000
   ACB'STATUS := 0;                                                     21185000
   ACB'EOF := 0;                                                        21190000
   IF <> THEN GO SAYEOF;       << report prior EOF >>                   21195000
   IF ACB'ACCCL <> DIRACC THEN                                          21200000
      BEGIN            << Not disk. >>                                  21205000
      TOS := ACB'CTL&LSR(8);         << P1.(13:3) - EOF spec. >>        21210000
      TOS.(0:1) := ACB'INHIBCRLF;    << P1.(0:1) - inhibit CR/LF >>     21215000
      TOS := ACB'STOPCHAR&LSL(8);    << P2.(0:8) - stop char. >>        21220000
      IF ACB'DTYPE = TERMINAL THEN                                      21225000
         BEGIN                                                          21230000
         TOS.(9:1) := ACB'XMITCRLF;  << VIEW handshake >>      <<01790>>21235000
         TOS.(10:1) := ACB'TBLOCK;   << disable Block Mode >>           21240000
         TOS.(12:1) := ACB'BINARYIO  << 8-bit transfers >>              21245000
         END                                                            21250000
      ELSE        << not disk or terminal >>                            21255000
         TOS.(12:1) := NOT ACB'ASCII;  << ASCII/binary mode >>          21260000
      P2 := TOS; P1 := TOS;                                             21265000
      NMAX := INFINITE;                                                 21270000
      END;                                                              21275000
   IF WC > ACB'BSIZE AND NOT MR AND NOT (ACB'DTYPE=TERMINAL) THEN       21280000
      WC := ACB'BSIZE;      << limit to one block >>                    21285000
                                                                        21290000
   <<*******************************************************>> <<04578>>21295000
   <<  Each time through the Read LOOP, we will attempt to  >> <<04578>>21300000
   << read all of WTT.  However, the WTT will be lowered to >> <<04578>>21305000
   << the words left in the extent if reading accross multi->> <<04578>>21310000
   << ple extents and we will return here again to read from>> <<04578>>21315000
   << the next extent.                                      >> <<04578>>21320000
   <<*******************************************************>> <<04578>>21325000
                                                               <<04578>>21330000
                                                                        21335000
RLOOP:                                                                  21340000
   WTT := WC;        << try to read it all >>                           21345000
   SHORT'BLOCK := FALSE;  << Assume no short block read.    >> <<04645>>21350000
   IF ACB'ACCCL = DIRACC THEN                                           21355000
      BEGIN          << get LDEV and sector >>                          21360000
                                                               <<04578>>21365000
      <<****************************************************>> <<04578>>21370000
      << FCONV'BLK will return the following:  EOF record #,>> <<04578>>21375000
      << sectors available in the extent and the extent     >> <<04578>>21380000
      << address (LDEV and DISKADDR).                       >> <<04578>>21385000
      <<****************************************************>> <<04578>>21390000
                                                               <<04578>>21395000
      FCONV'ERROR := 0;                                        <<04567>>21400000
      FCONV'BLK(BLOCK,DQ,0,0,0D,0D,0);                         <<06511>>21405000
      EXTSIZE := TOS;                                          <<04653>>21410000
      EXTBASE := TOS;                                          <<04653>>21415000
      FCEOF := TOS;             << Record number of EOF.    >> <<04578>>21420000
      NMAX := FCEOF-ACB'FPTR;   << # of recs left in file.  >> <<04578>>21425000
      IF NMAX <= 0D THEN                                       <<04578>>21430000
         BEGIN  << No more data records left in the file. >>   <<02072>>21435000
         IF NOT ACB'MSGFILE OR NOT FCCHECKFILEND(DQ,BLOCK)     <<06511>>21440000
            THEN GO SAYEOF;                                    <<01750>>21445000
    << Copying msg file, block has only Close hdr records. >>  <<02072>>21450000
         END;                                                  <<01750>>21455000
      IF DS1 = 0D THEN S1 := 1;      << EOF if bad FLAB >>     <<02072>>21460000
      STX := TOS;     << sectors avbl in this extent >>                 21465000
      FCONV'ERROR := TOS;       << Error nr. >>                <<04567>>21470000
      IF FCONV'ERROR > 0  THEN                                 <<04567>>21475000
         BEGIN         << Error of some kind. >>                        21480000
         IF FCONV'ERROR <= 2 THEN GO SAYEOF  << beyond EOF >>  <<04567>>21485000
            ELSE ERREXIT(FCONV'ERROR);   << other error >>     <<04567>>21490000
         END;                                                           21495000
      LDEV := TOS;        << LDEV of requested block >>                 21500000
      DISKADR := TOS;     << sector nr. of requested block >>           21505000
      IF FREADSEEK'MODE THEN GO SETX;   << FPOINT exit      >> <<04592>>21510000
                                                               <<04557>>21515000
      <<****************************************************>> <<04557>>21520000
      << First, cut back word count to number of words left >> <<04557>>21525000
      << in the extent.  Next, for fixed and undefined files>> <<04557>>21530000
      << calculate the number of records left in the file.  >> <<04557>>21535000
      <<****************************************************>> <<04557>>21540000
                                                               <<04557>>21545000
      IF LOG(WTT/128) >= STX THEN WTT := STX*128;              <<04557>>21550000
      IF NOT ACB'VARIABLE THEN                                          21555000
         BEGIN                                                          21560000
         RECS'FILE := FCEOF-BLOCK*DBLKFACT;     << records  >> <<04557>>21565000
         IF RECS'FILE = 0D THEN FTROUBLE(60);   << EOF????? >> <<04557>>21570000
                                                               <<04557>>21575000
         <<*************************************************>> <<04557>>21580000
         << If the number of records is less than one inte- >> <<04557>>21585000
         << ger word, then it is possible that the word cnts>> <<04557>>21590000
         << are larger than the remaining words in the file.>> <<04557>>21595000
         << Therefore, cut back the word counts if needed.  >> <<04557>>21600000
         << For RIO, this number is obtained from the blocks>> <<04557>>21605000
         << rather than records because of the bit map words>> <<04557>>21610000
         << at the end of data records in the block.        >> <<04557>>21615000
         <<*************************************************>> <<04557>>21620000
                                                               <<04557>>21625000
         IF RECS'FILE'0 = 0 THEN                               <<04557>>21630000
            BEGIN                                              <<04557>>21635000
            IF ACB'RIO THEN                                    <<04557>>21640000
               BEGIN                                           <<04557>>21645000
               BLKS'FILE := (RECS'FILE+DBLKFACT-1D)/DBLKFACT;  <<04557>>21650000
               WORDS'FILE := BLKS'FILE * DBL(ACB'BSIZE);       <<04557>>21655000
               END                                             <<04557>>21660000
            ELSE                                               <<04557>>21665000
               WORDS'FILE := RECS'FILE * DBL(RSIZE);           <<04557>>21670000
                                                               <<04557>>21675000
            IF DBL(WTT) > WORDS'FILE THEN                      <<04557>>21680000
               BEGIN   << Cut back counts, can't read > EOF >> <<04557>>21685000
               WTT := INT(WORDS'FILE);                         <<04557>>21690000
               WC  := INT(WORDS'FILE);                         <<04557>>21695000
               END;                                            <<04557>>21700000
            END;                                               <<04557>>21705000
                                                               <<04557>>21710000
         END;                                                           21715000
      END      << get LDEV and sector >>                       <<02545>>21720000
   ELSE IF ACB'DTYPE = MTAPE AND NOT FREADBACKWARD'MODE THEN   <<04592>>21725000
      SET'LPDT'BOT(LDEV,0); << Magtape and not FREADBACKWARD >><<02652>>21730000
                                                                        21735000
   <<*******************************************************>> <<04578>>21740000
   << If the file has blocks ending on even sector bound-   >> <<04578>>21745000
   << ries, then the file is said to be "streamed" and the  >> <<04578>>21750000
   << read from the extent can be done with one ATTACHIO.   >> <<04578>>21755000
   << Otherwise, we must do multiple ATTACHIO's in sizes of >> <<04578>>21760000
   << a block so as not to read the ending block "garbage". >> <<04578>>21765000
   <<*******************************************************>> <<04578>>21770000
                                                               <<04578>>21775000
   IF WTT > ACB'BSIZE AND NOT ACB'STREAM AND NOT (ACB'DTYPE=TERMINAL)   21780000
     THEN WTT := ACB'BSIZE;  << max 1 blk unless terminal or strm MR >> 21785000
                                                                        21790000
READ'MORE'IN'EXTENT:                                           <<04578>>21795000
                                                               <<04578>>21800000
   <<*******************************************************>> <<04578>>21805000
   << Calculate positive characters to transfer.  If TCOUNT >> <<04578>>21810000
   << was sent as bytes, calculate CTT from TCOUNT in case  >> <<04578>>21815000
   << an odd byte count is requested.                       >> <<04578>>21820000
   <<*******************************************************>> <<04578>>21825000
                                                               <<04578>>21830000
   CTT'L := WTT'L * 2;                                         <<04578>>21835000
   IF 0 <= -TCOUNT <= CTT THEN CTT := -TCOUNT;                          21840000
                                                               <<04567>>21845000
   <<*******************************************************>> <<04567>>21850000
   << If we are reading from an un-allocated extent, simply >> <<04567>>21855000
   << fill the users buffer with fill characters. FCONV'BLK >> <<04567>>21860000
   << did not allocate the extent to save time and space.   >> <<04567>>21865000
   <<*******************************************************>> <<04567>>21870000
                                                               <<04567>>21875000
   IF ACB'ACCCL = DIRACC AND FCONV'ERROR = UNALLOC'EXT THEN    <<04567>>21880000
      BEGIN                                                    <<04567>>21885000
      CLEAR'NOBUFF;    << Clear the user's buffers.         >> <<04567>>21890000
      ACB'STATUS := 1; << Successful read.                  >> <<04567>>21895000
      GO COMPREAD;     << Complete the read, no ATTACHIO.   >> <<04567>>21900000
      END;                                                     <<04567>>21905000
                                                               <<04567>>21910000
REREAD:                                                                 21915000
                                                               <<04578>>21920000
   <<*******************************************************>> <<04578>>21925000
   << Perform the ATTACHIO read.  For no-wait I/O, we save  >> <<04578>>21930000
   << the IOQ indeX in the AFT and report a successful read.>> <<04578>>21935000
   << Stack EXTENT information for ATTACHIO.                >> <<04578>>21940000
   <<*******************************************************>> <<04578>>21945000
                                                               <<04578>>21950000
   TOS := EXTBASE;                                             <<04653>>21955000
   TOS := EXTSIZE;                                             <<04653>>21960000
   FIX'ATTACHIO'FLAGS;                                         <<04653>>21965000
   IO'STATUS := ATTACHIO(LDEV,0,DSTX,@TARGET,                  <<04578>>21970000
      IF FREADBACKWARD'MODE THEN 13 ELSE 0,                    <<04592>>21975000
      IF TCOUNT < 0 THEN -CTT ELSE WTT,                                 21980000
      P1,P2,ATTIOFLAGS);                                       <<04653>>21985000
   << Remove stacked EXTENT parameters                      >> <<04653>>21990000
   ASMB(DDEL,DEL);                                             <<04653>>21995000
   IF NOWAIT THEN                                                       22000000
      BEGIN          << We're starting a No-wait input. >>              22005000
      STUFF'IOQX(NOWAIT'IOQX);                                 <<04578>>22010000
      ACB'NOWAITMODE := 0;   << save I/O mode >>                        22015000
      GO SETX               << claim Read was successful >>             22020000
      END;        << start no-wait input >>                             22025000
                                                                        22030000
   <<*******************************************************>> <<04578>>22035000
   << The number of characters transfered, returned by      >> <<04578>>22040000
   << ATTACHIO, should always be the same as CTT (or WTT)   >> <<04578>>22045000
   << for disc files.  However, for tape files and other    >> <<04578>>22050000
   << devices, the transfer log could be less than the      >> <<04578>>22055000
   << desired amount (CTT or WTT).                          >> <<04578>>22060000
   <<*******************************************************>> <<04578>>22065000
                                                               <<04578>>22070000
   CHAR'TRNSFRD := WAITIO'TLOG;                                <<04578>>22075000
   ACB'STATUS := WAITIO'STATUS; << Save logical I/O status. >> <<04578>>22080000
   IF LABEL'DEVICE AND ACB'STATUS=EOFSTAT THEN                 <<03582>>22085000
      BEGIN       << Is next reel available? >>                <<02545>>22090000
      REELSWITCH(LDEV,0);                                      <<02545>>22095000
      IF = THEN                                                <<02545>>22100000
         BEGIN      << Next reel has been mounted. >>          <<02545>>22105000
         ACB'BTFRCT := -1D;                                    <<02545>>22110000
         GO REREAD;                                            <<02545>>22115000
         END                                                   <<02545>>22120000
      ELSE IF < THEN ACB'STATUS := NAVLSTAT;    << =REPLY 0 >> <<02545>>22125000
      END;                                                     <<02545>>22130000
                                                               <<04578>>22135000
COMPREAD:                                                               22140000
                                                               <<04578>>22145000
   <<*******************************************************>> <<04578>>22150000
   << Make Characters Transfered a positive byte count. The >> <<04578>>22155000
   << TLOG is returned from ATTACHIO as a negative byte     >> <<04578>>22160000
   << count or a positive word count.                       >> <<04578>>22165000
   <<*******************************************************>> <<04578>>22170000
                                                               <<04578>>22175000
   IF CHAR'TRNSFRD < 0                                         <<04578>>22180000
      THEN CHAR'TRNSFRD := \CHAR'TRNSFRD\                      <<04578>>22185000
      ELSE CHAR'TRNSFRD'L := CHAR'TRNSFRD'L * 2;               <<04578>>22190000
                                                               <<04578>>22195000
   IF FREADBACKWARD'MODE THEN REVERSEBUF(CTT/2);               <<04592>>22200000
                                                               <<04578>>22205000
   <<*******************************************************>> <<04578>>22210000
   << Check ATTACHIO status for error condition.  Do BREAK- >> <<04578>>22215000
   << MODE stuff, if needed or return proper FSERR.         >> <<04578>>22220000
   <<*******************************************************>> <<04578>>22225000
                                                               <<04578>>22230000
   IF ACB'STATUS <> 1 THEN                                              22235000
      BEGIN           << ATTACHIO error >>                              22240000
      IF ACB'STATUS = BREAKSTAT AND NOT ACB'NOWAIT THEN                 22245000
         BEGIN                                                          22250000
                                                                        22255000
         <<*************************************************>> <<04578>>22260000
         << User hit BREAK on his terminal.  By the time we >> <<04578>>22265000
         << get here, the terminal driver has called BREAK- >> <<04578>>22270000
         << JOB, which fired a pseudo-interrupt to call the >> <<04578>>22275000
         << CI.  The CI calls FBREAK, which calls LOC'ACB to>> <<04578>>22280000
         << shuffle the control block queue.  At this point,>> <<04578>>22285000
         << the CI is impeded because LOC'ACB hasn't com-   >> <<04578>>22290000
         << completed, since we have the PACB.              >> <<04578>>22295000
         <<*************************************************>> <<04578>>22300000
                                                                        22305000
         IF SPCBPTYPE' = CI'PIN THEN                           <<06511>>22310000
            BEGIN             << CI. Ignore break request  >>           22315000
            GO SETX        << make I/O look OK >>                       22320000
            END;                                                        22325000
                                                                        22330000
         <<*************************************************>> <<04578>>22335000
         << Release the PACB (setting Break mode) so that   >> <<04578>>22340000
         << the CI can read the terminal.                   >> <<04578>>22345000
         <<*************************************************>> <<04578>>22350000
                                                                        22355000
         ACB'BREAK := 1;                                                22360000
         IF = THEN ACB'SAVEEOFS := ACB'EOFS;                   <<06511>>22365000
         UNLOC'ACB(DQ,2);                                      <<06511>>22370000
                                                                        22375000
         <<*************************************************>> <<04578>>22380000
         << Re-request the PACB.  By now, the CI has it, but>> <<04578>>22385000
         << will keep it only during the FBREAK call.  How- >> <<04578>>22390000
         << ever, since we are not running the CI, LOC'ACB  >> <<04578>>22395000
         << will impede us in the low priority queue until  >> <<04578>>22400000
         << the CI sees :RESUME or :ABORT and calls FUNBREAK>> <<04578>>22405000
         << which will put our request back into the normal >> <<04578>>22410000
         << queue and unimpede us.  The FUNBREAK call spec- >> <<04578>>22415000
         << ifies whether to redo or abort the Read.        >> <<04578>>22420000
         <<*************************************************>> <<04578>>22425000
                                                                        22430000
         LOC'ACB(0,DQ,ACB'FNUM,%100000);                       <<06511>>22435000
         DEL;          << discard DSTX >>                               22440000
         IF NOT ACB'ABORTREAD THEN                                      22445000
            BEGIN             << re-do the read >>                      22450000
            DT1T2 := "READ";                                            22455000
            DT3T4 := " pen";                                            22460000
            DT5T6 := "ding";                                            22465000
            ATTACHIO(LDEV,0,STKDST,Q'1'A,1,-12,0,0,BFLAGS);             22470000
            ACB'TLOG := 0;     << clear xmit log >>                     22475000
            GO REREAD;                                                  22480000
            HELP;         << dummy call >>                              22485000
            END;             << re-do the read >>                       22490000
                                                                        22495000
         ACB'STATUS := EOFCODE  << Abort; simulate EOF >>               22500000
         END;         << broken terminal read >>                        22505000
                                                                        22510000
      <<****************************************************>> <<04578>>22515000
      << If an EOF was encounterd on the first READ, report >> <<04578>>22520000
      << it.  If encountered on a subsequent READ, report   >> <<04578>>22525000
      << the good data read so far, and save the EOF to re- >> <<04578>>22530000
      << port in the next FREAD.                            >> <<04578>>22535000
      <<****************************************************>> <<04578>>22540000
                                                                        22545000
      IF ACB'GSTATUS = EOFCODE THEN                                     22550000
         BEGIN          << EOF. >>                                      22555000
         IF ACB'TLOG <> 0 THEN                                          22560000
            BEGIN     << Report EOF later. >>                           22565000
            ACB'EOF := 1;                                               22570000
            GO SETX                                                     22575000
            END;                                                        22580000
SAYEOF:  ACB'EOFS := 3;     << EOF on $STDIN & $STDINX >>      <<01759>>22585000
SOFTEOF: ACB'STATUS := EOFCODE;                                <<01759>>22590000
         ACB'ERROR := EOF;                                     <<01759>>22595000
         GO EXIT;                                              <<01759>>22600000
         END;      << EOF >>                                            22605000
                                                                        22610000
      ACB'ERROR := IOSTAT(ACB'STATUS);    << Error nr. >>               22615000
      IF ACB'ERROR = SOFTABORT THEN                            <<06049>>22620000
         ACB'EOFS := 3;     << Force EOF on next read.      >> <<06049>>22625000
      IF ACB'ERROR <> TAPERREC AND ACB'ERROR <> EOL THEN GO EXIT        22630000
      END          << ATTACHIO error >>                                 22635000
   ELSE      << Successful I/O >>                                       22640000
                                                               <<04578>>22645000
      <<****************************************************>> <<04578>>22650000
      << Successfull I/O, check for :EOD condition.         >> <<04578>>22655000
      <<****************************************************>> <<04578>>22660000
                                                               <<04578>>22665000
      IF CHAR'TRNSFRD'L <> 0 AND ACB'CTL.(11:1) THEN           <<04578>>22670000
         BEGIN   << Non-CI job or session. Ck for log EOF. >>           22675000
                                                               <<04578>>22680000
         T1 := TARGET;                                                  22685000
         IF CHAR'TRNSFRD'L > 3  AND                            <<04578>>22690000
            (LT1 LAND %177737) = ":E" AND                      <<04578>>22695000
            (TARGET(1) LAND %157737) = "OD" THEN GO SAYEOF;    <<04578>>22700000
         IF NOT ACB'CTL AND (T1.(0:8) = ":") THEN                       22705000
            BEGIN        << ":" on $STDIN >>                            22710000
            ACB'EOFS := 1 LOR ACB'EOFS;                                 22715000
            GO SOFTEOF;                                        <<01759>>22720000
            END                                                         22725000
         END;        << check for logical EOF >>                        22730000
                                                                        22735000
   <<*******************************************************>> <<04578>>22740000
   << Calculate number of blocks read, this xfer and update >> <<04578>>22745000
   << BLOCK number and block transfer count.                >> <<04578>>22750000
   <<*******************************************************>> <<04578>>22755000
                                                               <<04578>>22760000
   BLKS'TRNSFRD := DBL( (WTT'L+ACB'BSIZE'L-1)/ACB'BSIZE'L );   <<04578>>22765000
   IF BLKS'TRNSFRD = 0D                                        <<04578>>22770000
      THEN BLKS'TRNSFRD := 1D;  << Claim one block read.    >> <<04578>>22775000
                                                               <<04578>>22780000
   BLOCK := BLOCK+BLKS'TRNSFRD;                                <<04578>>22785000
   ACB'BTFRCT := ACB'BTFRCT+BLKS'TRNSFRD; << Block xfer cnt >> <<04578>>22790000
                                                                        22795000
   <<*******************************************************>> <<04578>>22800000
   << For variable length files, check the block structure  >> <<04578>>22805000
   << of the blocks read and set record transfer count,     >> <<04578>>22810000
   << obtained in CHKVARBLK.                                >> <<04578>>22815000
   <<*******************************************************>> <<04578>>22820000
                                                               <<04578>>22825000
   IF ACB'VARIABLE THEN                                                 22830000
      BEGIN           << variable record format >>                      22835000
      ACB'BLK := BLKS'TRNSFRD+ACB'BLK;                         <<04578>>22840000
      << Check the variable structure.                      >> <<04578>>22845000
      IF CHKVARBLK THEN                                        <<04578>>22850000
         BEGIN                                                          22855000
         ACB'STATUS := 0;                                               22860000
         ERREXIT(BADVARBLK);                                            22865000
         END;                                                           22870000
      IF NOT ACB'MSGFILE THEN                                  <<01750>>22875000
         CHAR'TRNSFRD'L := LOG(VAR'WORD'CNT) * 2;              <<04578>>22880000
      RECS'TRNSFRD := NUM'VAR'RECS; << # of records xferedl.>> <<04578>>22885000
      END                                                               22890000
   ELSE                                                                 22895000
      BEGIN            << non-variable >>                               22900000
      << Number of records read, this xfer.                 >> <<04578>>22905000
      RECS'TRNSFRD := BLKS'TRNSFRD * DBLKFACT;                 <<04578>>22910000
      END;                                                              22915000
                                                               <<04578>>22920000
   << Update record pointer and transfer counts.            >> <<04578>>22925000
                                                               <<04578>>22930000
   ACB'FPTR := RECS'TRNSFRD+ACB'FPTR;   << next record nr.  >> <<04578>>22935000
   ACB'RTFRCT := RECS'TRNSFRD+ACB'RTFRCT; << Bump xfer cnt. >> <<04578>>22940000
                                                                        22945000
   <<*******************************************************>> <<04578>>22950000
   << The transfer count will never be less for a disk file,>> <<04578>>22955000
   << but could be short for tape and other device files.   >> <<04578>>22960000
   <<*******************************************************>> <<04578>>22965000
                                                               <<04578>>22970000
   CHARS'TO'FILL := CTT'L-CHAR'TRNSFRD'L;  << Need to fill? >> <<04578>>22975000
   IF ACB'FIXED AND CHARS'TO'FILL > 0 THEN                     <<04578>>22980000
      BEGIN         << pad short block with fill chars. >>              22985000
      SHORT'BLOCK := TRUE;                                     <<04645>>22990000
      @BTARGET := @TARGET&LSL(1);                                       22995000
      BTARGET(CHAR'TRNSFRD'L) := BYTE(FILL);                   <<04578>>23000000
      IF CHARS'TO'FILL > 1 THEN                                <<05009>>23005000
         MOVE BTARGET(CHAR'TRNSFRD'L+1) :=                     <<04578>>23010000
              BTARGET(CHAR'TRNSFRD'L),(CHARS'TO'FILL-1);       <<04578>>23015000
      << Round up to full records.                          >> <<04578>>23020000
      CHAR'TRNSFRD'L := CHAR'TRNSFRD'L + RSIZE'BRU - 1;        <<04644>>23025000
      CHAR'TRNSFRD'L :=                                        <<04578>>23030000
            CHAR'TRNSFRD'L-(CHAR'TRNSFRD'L MOD RSIZE'BRU);     <<04644>>23035000
      END;         << pad short block >>                                23040000
                                                               <<04645>>23045000
   <<*******************************************************>> <<04578>>23050000
   << Update transfer count and ACB transfer log.  CORREC-  >> <<04578>>23055000
   << TION term is negative byte count or a positive word.  >> <<04578>>23060000
   <<*******************************************************>> <<04578>>23065000
                                                               <<04578>>23070000
   IF TCOUNT < 0                                               <<04578>>23075000
      THEN CORRECTION := -CHAR'TRNSFRD                         <<04578>>23080000
      ELSE CORRECTION := CHAR'TRNSFRD'L&LSR(1); << Need LSR!>> <<04578>>23085000
   TCOUNT := TCOUNT-CORRECTION;                                <<04578>>23090000
   ACB'TLOG := CORRECTION+ACB'TLOG;                            <<04578>>23095000
                                                                        23100000
   <<*******************************************************>> <<04578>>23105000
   << For MR, continue reading if needed.  Terminals are    >> <<04578>>23110000
   << allowed only one ATTACHIO per read!                   >> <<04578>>23115000
   <<*******************************************************>> <<04578>>23120000
                                                               <<04578>>23125000
   IF MR AND NOT (ACB'DTYPE=TERMINAL) THEN                              23130000
      BEGIN                                                             23135000
                                                               <<04578>>23140000
      <<****************************************************>> <<04578>>23145000
      << Calculate actual words transferred.  This should be>> <<04578>>23150000
      << the same for disc files but could be less for tape >> <<04578>>23155000
      << and other device files.                            >> <<04578>>23160000
      <<****************************************************>> <<04578>>23165000
                                                               <<04578>>23170000
      WTT'L := (CHAR'TRNSFRD'L+1) / 2;                         <<04578>>23175000
      @TARGET := @TARGET+WTT;       << update target addr. >>           23180000
      WC := WC-WTT;                 << update word count >>             23185000
                                                               <<04578>>23190000
      <<****************************************************>> <<04578>>23195000
      << If reading more than one blocks worth from the     >> <<04578>>23200000
      << file, then one of two things can happen.  If there >> <<04578>>23205000
      << is room left in the extent (than the file was not  >> <<04578>>23210000
      << streamed) then READ MORE IN EXTENT.  Otherwise,    >> <<04578>>23215000
      << read more in the next extent.  For device files,   >> <<04578>>23220000
      << simply go through the READ LOOP again.             >> <<04578>>23225000
      <<****************************************************>> <<04578>>23230000
                                                               <<04578>>23235000
      IF ACB'ACCCL=DIRACC THEN                                          23240000
         BEGIN    << bump disk address >>                               23245000
         NMAX := FCEOF-ACB'FPTR;                                        23250000
         IF <= THEN GO EXIT;   << at EOF, but data is good >>           23255000
         << Calculate number of sectors read, this transfer.>> <<04578>>23260000
         SECTS'TRNSFRD := (WTT'L + 127) / 128;                 <<04578>>23265000
         STX := STX - SECTS'TRNSFRD;   << Decrement sectors >> <<04578>>23270000
         DISKADR := DISKADR + DBL(SECTS'TRNSFRD); << Next . >> <<04578>>23275000
         IF WTT > WC THEN WTT := WC;   << last xfer is short >>         23280000
         IF WC > 0 AND STX > 0                                 <<04578>>23285000
            THEN GO READ'MORE'IN'EXTENT;                       <<04578>>23290000
         END;                                                           23295000
                                                               <<04645>>23300000
      <<****************************************************>> <<04645>>23305000
      << Disk files,start with next extent at RLOOP if WC>0.>> <<06039>>23310000
      << Non disk files, continue reading untill complete.  >> <<04645>>23315000
      << For tape files, we could have a short block read.  >> <<04645>>23320000
      << If so, and the remaining word count is less than a >> <<04645>>23325000
      << block, then don't read again because the user will >> <<04645>>23330000
      << lose the remaining data in the next block on subse->> <<04645>>23335000
      << quent reads.                                       >> <<04645>>23340000
      <<****************************************************>> <<04645>>23345000
                                                               <<04645>>23350000
      IF WC > 0 AND NOT(SHORT'BLOCK LAND WC < ACB'BSIZE)       <<04645>>23355000
         THEN GO RLOOP;   << Go back, go back, go back!!!!! >> <<04645>>23360000
      END;      << MR >>                                                23365000
   END                                                                  23370000
$PAGE                                                          <<04578>>23375000
<<**********************************************************>> <<06039>>23380000
<<                 WRITE - UNBUFFERED                       >> <<06039>>23385000
<<**********************************************************>> <<06039>>23390000
ELSE                                                           <<06039>>23395000
   BEGIN                                                       <<06039>>23400000
                                                                        23405000
   <<*******************************************************>> <<04578>>23410000
   << IOWAIT has called us to complete the write on a no-   >> <<04578>>23415000
   << wait I/O request.  Set the transfer counts based on   >> <<04578>>23420000
   << ACB'TLOG, previously initialized in IOWAIT.  The I/O  >> <<04578>>23425000
   << status was placed in ACB'STATUS by IOWAIT also.       >> <<04578>>23430000
   <<*******************************************************>> <<04578>>23435000
                                                               <<04578>>23440000
   IF NOWAITCOMP THEN                                                   23445000
      BEGIN            << No-wait write completion >>                   23450000
      NEWEOF := ACB'NOWAITEOF;   << Restore EOF Advanced flag >>        23455000
      CHAR'TRNSFRD := ACB'TLOG;                                <<04578>>23460000
      << Obtain Words To Transfer count.                    >> <<04578>>23465000
      IF CHAR'TRNSFRD >= 0                                     <<04578>>23470000
         THEN WTT := CHAR'TRNSFRD     << Positive words.    >> <<04578>>23475000
         ELSE WTT := (\CHAR'TRNSFRD\+1)/2;                     <<04578>>23480000
      DISKADR := ACB'NOWAITDA;   << restore for FCLEAR, later >>        23485000
      LDEV := ACB'NOWAITLDEV;                                           23490000
      GO COMPWRITE                                                      23495000
      END;                                                              23500000
                                                                        23505000
   FIRST'WRITE := TRUE;    << Used for pre-spacing.         >> <<04578>>23510000
   ACB'TLOG := 0;                                                       23515000
   ACB'STATUS := 0;                                                     23520000
   ACB'ERROR := 0;                                             <<02076>>23525000
   NMAX := INFINITE;                                                    23530000
   IF ACB'ACCCL <> DIRACC THEN                                          23535000
      BEGIN           << non-disk >>                                    23540000
      LDEV := ACB'DADDR;    << LDEV of device >>                        23545000
      TOS := ACB'CTL;            << P1 - carriage control >>            23550000
      TOS := ACB'LPCTL;          << P2.(14:2) - line & page control >>  23555000
      TOS.(13:1) := 1;   << allow tape write past EOT >>       <<02054>>23560000
      IF ACB'DTYPE = TERMINAL THEN                                      23565000
         BEGIN                                                          23570000
         TOS.(12:1) := ACB'BINARYIO;  << 8-bit transfers >>             23575000
         TOS.(0:1) := ACB'QUIESCE;                                      23580000
         END                                                            23585000
      ELSE         << not disk or terminal >>                           23590000
         TOS.(12:1) := NOT ACB'ASCII;  << ASCII/binary mode >>          23595000
      P2 := TOS; P1 := TOS                                              23600000
      END;                                                              23605000
   IF WC > ACB'BSIZE AND ACB'DTYPE <> TERMINAL AND NOT MR THEN          23610000
      ERREXIT(BADTCOUNT);        << Ugh! Too much. >>                   23615000
                                                                        23620000
   <<*******************************************************>> <<04578>>23625000
   <<  The WTT count will be lowered to the maximum number  >> <<04578>>23630000
   << of words left in the extent on each pass through the  >> <<04578>>23635000
   << Write LOOP if we are writing a greater amount than    >> <<04578>>23640000
   << what is left in the present extent.                   >> <<04578>>23645000
   <<*******************************************************>> <<04578>>23650000
                                                               <<04578>>23655000
                                                                        23660000
WLOOP:                                                                  23665000
   WTT := WC;       << try to write it all >>                           23670000
   IF ACB'ACCCL = DIRACC THEN                                           23675000
      BEGIN           << get LDEV and sector >>                         23680000
                                                               <<04578>>23685000
      <<****************************************************>> <<04578>>23690000
      << Obtain disc address parameters from FCONV'BLK and  >> <<04578>>23695000
      << determine if we are writing beyond the file limit. >> <<04578>>23700000
      <<****************************************************>> <<04578>>23705000
                                                               <<04578>>23710000
      FCONV'BLK(BLOCK,DQ,MODE,0,0D,0D,0);                      <<06511>>23715000
      EXTSIZE := TOS;  << save current extent size >>          <<04653>>23720000
      EXTBASE := TOS;  << save current extent base >>          <<04653>>23725000
      FCEOF := TOS;                                                     23730000
      STX := TOS;     << sectors avbl in this extent >>                 23735000
      FCONV'ERROR := TOS;       << Error nr. >>                <<04578>>23740000
      IF FCONV'ERROR <> 0 THEN                                 <<04578>>23745000
         BEGIN       << Error of some kind. >>                          23750000
         IF FCONV'ERROR = 1 THEN                               <<04578>>23755000
            NEWEOF := TRUE   << Set EOF advanced flag >>                23760000
         ELSE IF FCONV'ERROR = 2 THEN                          <<04578>>23765000
            BEGIN                                                       23770000
ATFLIM:     ACB'ERROR := EOF;                                           23775000
            ACB'STATUS := EOFCODE;                                      23780000
            GO EXIT                                                     23785000
            END                                                         23790000
         ELSE      << other error >>                                    23795000
            ERREXIT(FCONV'ERROR);                              <<04578>>23800000
         END;                                                           23805000
      LDEV := TOS;     << LDEV of requested block >>                    23810000
      DISKADR := TOS;  << sector nr. of requested block >>              23815000
      IF WRITE'EOF'MODE THEN GO EXIT;                          <<04592>>23820000
      IF LOG(WTT&ASR(7)) >= STX THEN WTT := STX&LSL(7);                 23825000
      END;     << get LDEV and sector >>                                23830000
                                                                        23835000
   <<*******************************************************>> <<04578>>23840000
   <<   Terminal writes of length >  ACB'BSIZE  are  broken >> <<04578>>23845000
   << into multiple calls to  ATTACHIO, each of length ACB' >> <<04578>>23850000
   << BSIZE (except poss. the last).  The following  state- >> <<04578>>23855000
   << ment  makes  sure the  carriage  control parm is sent >> <<04578>>23860000
   << with the first call   if the terminal is in  prespace >> <<04578>>23865000
   << mode or   the last such call if in postspace mode.    >> <<04578>>23870000
   <<*******************************************************>> <<04578>>23875000
                                                               <<02310>>23880000
   IF ACB'DTYPE = TERMINAL THEN                                <<04578>>23885000
      IF ACB'LINECTL = 0 THEN   <<  Post spacing.           >> <<04578>>23890000
         BEGIN                                                 <<04578>>23895000
         IF WTT <= ACB'BSIZE    << Last write.              >> <<04644>>23900000
            THEN P1 := ACB'CTL  << Perform the CCTL func.   >> <<04578>>23905000
            ELSE P1 := %320;    << No CCLF.                 >> <<04578>>23910000
         END                                                   <<04578>>23915000
      ELSE                      << Pre spacing, bit is on.  >> <<04578>>23920000
         IF FIRST'WRITE         << First write.             >> <<04578>>23925000
            THEN P1 := ACB'CTL  << Perform the CCTL func.   >> <<04578>>23930000
            ELSE P1 := %320;    << No CCLF.                 >> <<04578>>23935000
                                                               <<04578>>23940000
   FIRST'WRITE := FALSE;        << Past the first write.    >> <<04578>>23945000
$PAGE                                                          <<04578>>23950000
   <<*******************************************************>> <<04578>>23955000
   << If the blocks end on even sector boundries, then the  >> <<04578>>23960000
   << file is said to be "streamed" and the write can be    >> <<04578>>23965000
   << completed for this extent with a single ATTACHIO.     >> <<04578>>23970000
   << Otherwise, the ATTACHIO's will be done in sizes of a  >> <<04578>>23975000
   << block since the blocks are not on sector boundries.   >> <<04578>>23980000
   <<*******************************************************>> <<04578>>23985000
                                                               <<04578>>23990000
   IF WTT > ACB'BSIZE AND NOT ACB'STREAM THEN                           23995000
      WTT := ACB'BSIZE;   << limit to one block unless streamed >>      24000000
                                                               <<04578>>24005000
WRITE'MORE'IN'EXTENT:                                          <<04578>>24010000
                                                               <<04578>>24015000
   <<*******************************************************>> <<04578>>24020000
   << Calculate positive characters to transfer.  If TCOUNT >> <<04578>>24025000
   << was sent as bytes, then calculate CTT from TCOUNT in  >> <<04578>>24030000
   << case an odd byte count has been requested.            >> <<04578>>24035000
   <<*******************************************************>> <<04578>>24040000
                                                               <<04578>>24045000
   CTT'L := WTT'L * 2;                                         <<04578>>24050000
   IF 0 <= -TCOUNT <= CTT THEN CTT := -TCOUNT;                          24055000
                                                               <<04578>>24060000
   <<*******************************************************>> <<04578>>24065000
   << Check users buffer to insure that the data has the    >> <<04578>>24070000
   << correct formats and structures for message or variable>> <<04578>>24075000
   << files before being written to disk.                   >> <<04578>>24080000
   <<*******************************************************>> <<04578>>24085000
                                                               <<04578>>24090000
   IF ACB'MSGFILE THEN                                         <<HM.00>>24095000
      BEGIN    << Insure that the block has correct format >>  <<02072>>24100000
      TOS:=FCHECKMSGBLOCK(TARGET,WTT);                         <<HM.00>>24105000
      IF < THEN ERREXIT(BADVARBLK);                            <<HM.00>>24110000
      NONDATARECORDS := TOS; ASMB(ZERO,XCH);                   <<04578>>24115000
      NUM'VAR'RECS := TOS;                                     <<06043>>24120000
      END                                                      <<HM.00>>24125000
   ELSE IF ACB'VARIABLE THEN                                   <<HM.00>>24130000
      BEGIN                                                             24135000
      IF CHKVARBLK                                             <<04578>>24140000
         THEN ERREXIT(BADVARBLK);                              <<04578>>24145000
      IF ACB'ACCCL=DIRACC THEN NEWEOF := TRUE; << EOF Advanced flag >>  24150000
      END;                                                              24155000
                                                                        24160000
   IF ACB'DTYPE = MTAPE AND CTT <> 0 THEN                      <<02652>>24165000
      BEGIN     << Magtape and non-zero write request >>       <<02652>>24170000
      IO'STATUS := WRITE'DENSITY(LDEV);                        <<04578>>24175000
      IF ERR'STAT <> 1 THEN                                    <<04578>>24180000
         BEGIN                                                 <<02652>>24185000
         << Ignore transmission log and save logical status.>> <<04578>>24190000
         ACB'STATUS := WAITIO'STATUS;                          <<04578>>24195000
         GO COMPWRITE;        << Skip write.  Report error. >> <<02652>>24200000
         END;                                                  <<02652>>24205000
      << A-OK, continue with write.                        >>  <<04578>>24210000
      END;                                                     <<02652>>24215000
                                                               <<04578>>24220000
   <<*******************************************************>> <<04578>>24225000
   << Perform the ATTACHIO write.  For no-wait I/O, stuff   >> <<04578>>24230000
   << the IOQ indeX into the AFT and report no error.       >> <<04578>>24235000
   << Stack file EXTENT parameters on TOS for ATTACHIO.     >> <<04578>>24240000
   <<*******************************************************>> <<04578>>24245000
                                                               <<04578>>24250000
      TOS := EXTBASE;                                          <<04653>>24255000
      TOS := EXTSIZE;                                          <<04653>>24260000
      << Fix FLAGS word for ATTACHIO >>                        <<04653>>24265000
      FIX'ATTACHIO'FLAGS;                                      <<04653>>24270000
   IO'STATUS := ATTACHIO(LDEV,0,DSTX,@TARGET,                  <<04578>>24275000
      IF ACB'DTYPE=SDISC THEN MODE ELSE 1,                              24280000
      IF TCOUNT < 0 THEN -CTT ELSE WTT,                                 24285000
      P1,P2,ATTIOFLAGS);                                       <<04578>>24290000
                                                               <<04578>>24295000
      << Remove stacked EXTENT parameters >>                   <<04653>>24300000
      ASMB(DDEL,DEL);                                          <<04653>>24305000
   IF NOWAIT THEN                                                       24310000
      BEGIN    << We began a no-wait write. Save IOQX in AFT >>         24315000
      STUFF'IOQX(NOWAIT'IOQX);                                 <<04578>>24320000
      ACB'NOWAITEOF := NEWEOF;   << save EOF advanced flag >>           24325000
      ACB'NOWAITMODE := 1;       << save I/O mode >>                    24330000
      ACB'NOWAITDA := DISKADR;                                          24335000
      ACB'NOWAITLDEV := LDEV;                                           24340000
      GO SETX            << claim I/O was successful >>                 24345000
      END;    << start no-wait write >>                                 24350000
                                                                        24355000
   <<*******************************************************>> <<04578>>24360000
   << Update the appropriate counts based on the trans-     >> <<04578>>24365000
   << mission log returned by ATTACHIO.  This TLOG should   >> <<04578>>24370000
   << be the same as the requested counts for all files ex- >> <<04578>>24375000
   << cept when hitting EOT on a tape file.                 >> <<04578>>24380000
   <<*******************************************************>> <<04578>>24385000
                                                               <<04578>>24390000
   TCOUNT := TCOUNT-WAITIO'TLOG;<< Decrement count. >>         <<04578>>24395000
   ACB'TLOG := WAITIO'TLOG+ACB'TLOG;  << update xmit log >>    <<04578>>24400000
   ACB'STATUS := WAITIO'STATUS;   << save logical I/O status>> <<04578>>24405000
   IF LABEL'DEVICE AND ACB'STATUS = EOTSTAT THEN               <<03582>>24410000
      BEGIN        << Is next reel available? >>               <<02545>>24415000
      REELSWITCH(LDEV,1);                                      <<02545>>24420000
      IF = THEN                                                <<02545>>24425000
         BEGIN        << Next reel mounted. >>                 <<02545>>24430000
         ACB'BTFRCT := -1D;                                    <<02545>>24435000
         ACB'STATUS := 1;    << No error >>                    <<02545>>24440000
         END                                                   <<02545>>24445000
      ELSE ACB'STATUS := NAVLSTAT;     << =REPLY 0. >>         <<02545>>24450000
      END;                                                     <<02545>>24455000
                                                               <<04578>>24460000
   <<*******************************************************>> <<04578>>24465000
   << To complete the write, check the ATTACHIO status re-  >> <<04578>>24470000
   << turned  and convert it to an FSERR if necessary.      >> <<04578>>24475000
   <<*******************************************************>> <<04578>>24480000
                                                               <<04578>>24485000
COMPWRITE:                                                              24490000
   IF ACB'STATUS <> 1 THEN                                              24495000
      BEGIN         << ATTACHIO reports error >>                        24500000
      IF ACB'GSTATUS = EOFCODE THEN                                     24505000
         BEGIN             << File limit encountered. >>                24510000
         ACB'EOFS := 3;                                                 24515000
         ACB'EOF := 1                                                   24520000
         END;                                                           24525000
      ACB'ERROR := IOSTAT(ACB'STATUS);      << error nr. >>             24530000
      IF ACB'ERROR <> EOT AND ACB'ERROR <> TAPERREC THEN GO EXIT        24535000
      END;         << ATTACHIO error >>                                 24540000
                                                                        24545000
   <<*******************************************************>> <<04578>>24550000
   << Calculate the number of blocks written this transfer. >> <<04578>>24555000
   << If WTT is not a multiple of the block size, EOFDELTA  >> <<04578>>24560000
   << is set to the word remainder of the un-written block  >> <<04578>>24565000
   << portion for calculating EOF and amounts to clear.     >> <<04578>>24570000
   <<*******************************************************>> <<04578>>24575000
                                                               <<04578>>24580000
   BLKS'TRNSFRD := DBL( (WTT'L+ACB'BSIZE'L-1) / ACB'BSIZE'L);  <<04578>>24585000
   IF BLKS'TRNSFRD = 0D                                        <<04578>>24590000
      THEN BLKS'TRNSFRD := 1D;  << Claim one block write.   >> <<04578>>24595000
   EOFDELTA := WTT MOD ACB'BSIZE;                              <<04578>>24600000
                                                               <<04578>>24605000
   << Update BLOCK number and block transfer count.         >> <<04578>>24610000
                                                               <<04578>>24615000
   BLOCK := BLOCK + BLKS'TRNSFRD;                              <<04578>>24620000
   ACB'BTFRCT := ACB'BTFRCT + BLKS'TRNSFRD;                    <<04578>>24625000
                                                               <<04578>>24630000
   <<*******************************************************>> <<04578>>24635000
   << Calculate/obtain number of records transfered.  CHK-  >> <<04578>>24640000
   << VARBLK calculated num. of records for variable files. >> <<04578>>24645000
   <<*******************************************************>> <<04578>>24650000
                                                               <<04578>>24655000
   IF ACB'VARIABLE THEN                                                 24660000
      BEGIN                                                             24665000
      ACB'BLK := BLKS'TRNSFRD + ACB'BLK;                       <<04578>>24670000
      IF ACB'MSGFILE THEN                                      <<HM.00>>24675000
         FCUPDATEWRITE(DQ,NONDATARECORDS);                     <<06511>>24680000
      RECS'TRNSFRD := NUM'VAR'RECS; << # of recs, this xfer >> <<04578>>24685000
      END                                                               24690000
   ELSE                                                                 24695000
      BEGIN          << non-variable >>                                 24700000
      << Calculate the # of recs xfered, fixed or undef.    >> <<04578>>24705000
      RECS'TRNSFRD := BLKS'TRNSFRD * DBLKFACT;                 <<04578>>24710000
      END;                                                              24715000
                                                               <<04578>>24720000
   <<*******************************************************>> <<04578>>24725000
   << Update record transfer count, file pointer and TARGET >> <<04578>>24730000
   << address and word count.                               >> <<04578>>24735000
   <<*******************************************************>> <<04578>>24740000
                                                               <<04578>>24745000
   ACB'FPTR := RECS'TRNSFRD + ACB'FPTR;                        <<04578>>24750000
   ACB'RTFRCT := RECS'TRNSFRD + ACB'RTFRCT;                    <<04578>>24755000
   @TARGET := @TARGET+WTT;       << update target addr. >>              24760000
   WC := WC-WTT;                 << update word count >>                24765000
                                                               <<04578>>24770000
   <<*******************************************************>> <<04578>>24775000
   << If we are writing more than one blocks worth to a     >> <<04578>>24780000
   << file, then one of two things can happen.  If there is >> <<04578>>24785000
   << room  left  in  the extent (then  the file was not    >> <<04578>>24790000
   << streamed), then WRITE'MORE'IN'EXTENT. Otherwise, write>> <<04578>>24795000
   << more in the next extent. For device files, just do    >> <<04578>>24800000
   << another ATTACHIO to the device.                       >> <<04578>>24805000
   <<*******************************************************>> <<04578>>24810000
                                                               <<04578>>24815000
   IF ACB'ACCCL=DIRACC THEN                                             24820000
      BEGIN                                                             24825000
      SECTS'TRNSFRD := (WTT'L + 127) / 128;                    <<04578>>24830000
      STX := STX - SECTS'TRNSFRD;                              <<04578>>24835000
      << Update disc address for next block read.           >> <<04578>>24840000
      DISKADR := DISKADR + DBL(SECTS'TRNSFRD);                 <<04578>>24845000
      IF STX > 0 AND WC > 0 THEN                                        24850000
         BEGIN   << Xfer was limited by block size. >>         <<01690>>24855000
         IF WTT > WC THEN WTT := WC;   << last xfer is short >>         24860000
         GO WRITE'MORE'IN'EXTENT;                              <<04578>>24865000
         END;                                                           24870000
      IF WC > 0 THEN                                           <<01690>>24875000
         BEGIN      << Transfer more in next extent. >>        <<01690>>24880000
         FSET'EOF(ACB'FPTR,ACB'BLK-1D);                        <<06169>>24885000
         GO WLOOP;                                             <<01690>>24890000
         END;                                                  <<01690>>24895000
      END;                                                              24900000
   IF WC > 0 THEN GO WLOOP;                                             24905000
                                                                        24910000
   <<*******************************************************>> <<04578>>24915000
   << Covert EOFDELTA to records and update EOF, subtracing >> <<04578>>24920000
   << EOFDELTA to account for partial block write.  Clear   >> <<04578>>24925000
   << remaining sectors in the block for partial write.     >> <<04578>>24930000
   <<*******************************************************>> <<04578>>24935000
                                                               <<04578>>24940000
                                                                        24945000
   IF ACB'ACCCL=DIRACC THEN                                             24950000
      BEGIN         << check for EOF advanced >>                        24955000
      IF EOFDELTA <> 0 THEN EOFDELTA := BLKFACT-                        24960000
         (EOFDELTA+RSIZE-1)/RSIZE;    << records to end of blk >>       24965000
      IF < THEN EOFDELTA := 0;                                          24970000
      FSET'EOF(ACB'FPTR-DOUBLE(EOFDELTA),ACB'BLK-1D);          <<06169>>24975000
      IF NEWEOF THEN   << Did EOF advance into new block? >>            24980000
         BEGIN     << Yes. Clear partial block >>                       24985000
         SECTS'TO'FILL := ACB'BSIZE/128-(WTT+127)/128;         <<04578>>24990000
         IF > THEN                                                      24995000
            BEGIN          << partial block >>                          25000000
                                                               <<04450>>25005000
            << Want to clear all RIO files with zeroes to   >> <<04450>>25010000
            << clear the ART.                               >> <<04450>>25015000
                                                               <<04450>>25020000
            IF ACB'RIO OR (NOT ACB'ASCII)                      <<04578>>25025000
               THEN CLEARTYPE := FALSE    << Clear with 0's >> <<04578>>25030000
               ELSE CLEARTYPE := TRUE;    << Blanks.        >> <<04578>>25035000
            X := FCLEAR(CLEARTYPE,LDEV,DISKADR,SECTS'TO'FILL); <<04578>>25040000
                                                               <<04578>>25045000
$  IF X1 = ON                                                           25050000
            IF <> THEN FTROUBLE(478);  << error >>                      25055000
$  IF                                                                   25060000
            END;                                                        25065000
         END;        << EOF advanced >>                                 25070000
      END;     << check for EOF advanced >>                             25075000
   END;   << write request >>                                           25080000
                                                                        25085000
      END       << Unbuffered >>                                        25090000
$PAGE " IOMOVE - BUFFERED "                                    <<06039>>25095000
<<**********************************************************>> <<06039>>25100000
<<                        BUFFERED                          >> <<06039>>25105000
<<  Initialize parameters and check request.                >> <<06039>>25110000
<<**********************************************************>> <<06039>>25115000
                                                                        25120000
ELSE                                                           <<06039>>25125000
   BEGIN                                                       <<06039>>25130000
                                                                        25135000
   ACB'TLOG := 0;                                                       25140000
   ACB'ERROR := 0;                                                      25145000
   ACB'STATUS := 0;                                                     25150000
   IF ACB'FPTR < 0D THEN ERREXIT(BADRECNO);                    <<02068>>25155000
   IF ACB'SPECVAR THEN                                                  25160000
      BEGIN        << Special variable format. >>                       25165000
      MODES := IF MODE >= MIN'MODE'FDEVICECONTROL              <<04321>>25170000
               THEN MODE ELSE MODE.(13:3);                     <<04321>>25175000
      MODE.(13:3) := IF MODES <> 0 THEN 1 ELSE 0;                       25180000
      BLK'OVERHEAD := 8;     << block overhead (bytes) >>      <<04578>>25185000
      REC'OVERHEAD := 8;     << record overhead (bytes) >>     <<04578>>25190000
      END                                                               25195000
   ELSE                                                                 25200000
      BEGIN        << Not special variable. >>                          25205000
      MODE.(13:2) := 0;         << no-op >>                             25210000
      MODES := MODE.(15:1);                                             25215000
      BLK'OVERHEAD := 4;                                       <<04578>>25220000
      REC'OVERHEAD := 0;                                       <<04578>>25225000
      END;                                                              25230000
   MR := IF ACB'SPOOLED THEN ACB'SPAOPT.AOPMULTIRECF                    25235000
      ELSE ACB'MULTIREC;  << Buffered MR for spooling only.  >>         25240000
   NUM'BUFS := ACB'NUMBUFS+1;   << number of buffers >>        <<04566>>25245000
                                                               <<04578>>25250000
   <<*******************************************************>> <<04578>>25255000
   << For labeled tape and serial disc only, ATTIOFLAGS sig->> <<04578>>25260000
   << nify to do WAIT FOR I/O for all buffered I/O.  For all>> <<04578>>25265000
   << other files, ATTIOFLAGS signify to do NOWAIT I/O for  >> <<04578>>25270000
   << all buffers.  The top 4 bits are equal to 1 to signi- >> <<04578>>25275000
   << by that the request is from the file system.          >> <<04578>>25280000
   <<*******************************************************>> <<04578>>25285000
                                                               <<04578>>25290000
   ATTIOFLAGS := IF ACB'DTYPE=SDISC OR LABEL'DEVICE            <<03582>>25295000
      THEN BFLAGS ELSE UFLAGS;                                          25300000
                                                                        25305000
   <<*******************************************************>> <<04578>>25310000
   << MRLOOP is used when writing MR to a spoolfile.  We    >> <<04578>>25315000
   << break the write into record size pieces and continue  >> <<04578>>25320000
   << to write until done.  This is how a spoolfile can be  >> <<04578>>25325000
   << written MR, even though it is a buffered file.        >> <<04578>>25330000
   <<*******************************************************>> <<04578>>25335000
                                                               <<04578>>25340000
MRLOOP:                                                                 25345000
   IF READ THEN                                                         25350000
                                                                        25355000
   <<*******************************************************>> <<04578>>25360000
   <<              BUFFERED READ REQUEST                    >> <<04578>>25365000
   << First, determine if we are attempting to read beyond  >> <<04578>>25370000
   << the current end of file pointer.                      >> <<04578>>25375000
   <<*******************************************************>> <<04578>>25380000
                                                                        25385000
RIOREAD:                                                                25390000
   BEGIN                                                                25395000
   IF ACB'ACCCL = DIRACC AND ACB'FPTR >= FSET'EOF(0D,0D) THEN  <<06169>>25400000
      BEGIN           << Report EOF. >>                                 25405000
      ACB'EOF := 1;                                                     25410000
      ACB'STATUS := EOFCODE;                                   <<01910>>25415000
      ACB'ERROR := EOF;                                        <<01910>>25420000
      IF RIO'ACTIVE'MODE THEN ACB'ERROR := INACT;              <<04592>>25425000
      GO EXIT;                                                 <<01910>>25430000
      END;                                                              25435000
                                                                        25440000
   <<*******************************************************>> <<04578>>25445000
   << Truncate the read request to the files record size if >> <<04578>>25450000
   << greater.  For normal variable, the next record will   >> <<04578>>25455000
   << determine how much we are reading.                    >> <<04578>>25460000
   <<*******************************************************>> <<04578>>25465000
                                                               <<04578>>25470000
   IF NOT ACB'VARIABLE THEN                                             25475000
      BEGIN           << Non-variable record format >>                  25480000
      IF BC > ACB'RSIZE THEN                                            25485000
         BC := ACB'RSIZE;  << Truncate request to rec. size >>          25490000
      END                                                               25495000
   ELSE                                                                 25500000
      BEGIN           << Variable length records >>                     25505000
      IF ACB'SPOOLED AND BC > (ACB'SPREC+ACB'SPCCTL)           <<06511>>25510000
         THEN BC := ACB'SPREC;                                 <<06511>>25515000
      END;                                                     <<06511>>25520000
   BC'TRAIL'FILL := 0;                                         <<04578>>25525000
                                                                        25530000
   <<*******************************************************>> <<04566>>25535000
   << Search buffers for block to be read.  If we're lucky, >> <<04566>>25540000
   << it is already in (or coming into) a buffer from a pre->> <<04566>>25545000
   << read or prior read or write to the block.  Start pre- >> <<04566>>25550000
   << reads on all empty buffers on the first FREAD after   >> <<04566>>25555000
   << opening the file (FULLBUFFS false).  The DONT'WAYT    >> <<07286>>25560000
   << call to free up DRQ entries was commented out for per->> <<07286>>25565000
   << formance reasons with MPE-V and because the number of >> <<07286>>25570000
   << DRQ's was increased a lot.  Maybe some day we will    >> <<07286>>25575000
   << need it again.                                        >> <<07286>>25580000
   <<*******************************************************>> <<04566>>25585000
                                                                        25590000
   BLK'IN    := NOT'FOUND; << Clear block found flag        >> <<04566>>25595000
   BUF'EMPTY := NOT'FOUND; << Clear empty buffer flag.      >> <<04566>>25600000
   I := ACB'CURRBUF;       << Current buffer number.        >> <<04566>>25605000
   DO << For each and every buffer for the file.            >> <<04566>>25610000
      BEGIN                                                    <<04566>>25615000
      GETBLKPARMS;                                             <<04566>>25620000
      IF BLOCK = BLK'BLOCK                                     <<04566>>25625000
         THEN BLK'IN := I  << We found the needed block!    >> <<04566>>25630000
      ELSE IF BLK'BLOCK = EMPTY AND FREAD'MODE AND NOT ACB'EOF <<04592>>25635000
         THEN STARTREAD(ACB'HIBLK+1D);<< Pre-read on blk.   >> <<07286>>25640000
     !ELSE IF BLK'IOPEND AND ACB'ACCCL = DIRACC                <<07286>>25645000
     !   THEN DONT'WAYT;              << Clear DRQ entry    >> <<07286>>25650000
                                                               <<04566>>25655000
      IF BLOCK = BLK'BLOCK                                     <<04566>>25660000
         THEN BLK'IN := I  << Pre-read found the needed blk.>> <<04566>>25665000
      ELSE IF BLK'BLOCK = EMPTY AND BLK'IN = NOT'FOUND AND     <<04566>>25670000
              BUF'EMPTY = NOT'FOUND                            <<04566>>25675000
         THEN BUF'EMPTY := I;  << Use 1st. empty buffer.    >> <<04566>>25680000
                                                               <<04566>>25685000
      I := (I + 1) MOD NUM'BUFS;                               <<04566>>25690000
      END                                                      <<04566>>25695000
   UNTIL I=ACB'CURRBUF OR BLK'IN<>NOT'FOUND AND ACB'FULLBUFFS; <<07286>>25700000
                                                               <<07286>>25705000
                                                               <<04563>>25710000
   IF FREAD'MODE               ! If reading sequentially, then <<07286>>25715000
      THEN ACB'FULLBUFFS := 1; ! indicate buffers full.        <<07286>>25720000
                                                               <<07286>>25725000
   <<*******************************************************>> <<04563>>25730000
   << If the block that we need is not already in a buffer, >> <<04563>>25735000
   << then use an empty buffer.  If there are no empty buf- >> <<04563>>25740000
   << fers, then use the next buffer after the current,     >> <<04563>>25745000
   << writing out the old block first if dirty.             >> <<04563>>25750000
   <<*******************************************************>> <<04563>>25755000
                                                               <<04563>>25760000
   IF BLK'IN = NOT'FOUND THEN                                  <<04563>>25765000
      BEGIN                   << Block is not in buffers.   >> <<04563>>25770000
      IF BUF'EMPTY = NOT'FOUND THEN << Empty buffer avail?  >> <<04590>>25775000
         BEGIN                                                 <<04590>>25780000
         IF DIRECT'ACCESS                                      <<04590>>25785000
            THEN I := (ACB'CURRBUF + 1) MOD NUM'BUFS           <<04590>>25790000
            ELSE I := ACB'CURRBUF;                             <<04590>>25795000
         END                                                   <<04590>>25800000
      ELSE                                                     <<04590>>25805000
         I := BUF'EMPTY;       << Empty  buffer             >> <<04590>>25810000
      GETBLKPARMS;                                             <<04563>>25815000
      IF BLK'IOCOMP = 2                                        <<04563>>25820000
         THEN STARTWRITE;     << Write out dirty block.     >> <<04563>>25825000
      IF BLK'IOPEND                                            <<04563>>25830000
         THEN WAYT(0);        << Complete I/O of buffer.    >> <<04563>>25835000
      STARTREAD(BLOCK);       << Begin to read buffer in.   >> <<04563>>25840000
      ACB'HIT := 0;           << For MMSTAT call.           >> <<06958>>25845000
      END                                                      <<04563>>25850000
   ELSE                                                        <<04563>>25855000
      BEGIN                   << Block is in buffers.       >> <<04563>>25860000
      I := BLK'IN;                                             <<04563>>25865000
      GETBLKPARMS;                                             <<04563>>25870000
      ACB'HIT := 1;           << For MMSTAT call.           >> <<06958>>25875000
      END;                                                     <<04563>>25880000
                                                                        25885000
   <<*******************************************************>> <<04578>>25890000
   << We now have the block that we need in buffer # I,     >> <<04578>>25895000
   << wait for it to come in if I/O pending on the block.   >> <<04578>>25900000
   <<*******************************************************>> <<04578>>25905000
                                                                        25910000
GBK:                                                                    25915000
   ACB'CURRBUF := I;          << Current buffer nr. >>                  25920000
   IF FREADSEEK'MODE THEN GO SETX;                             <<04592>>25925000
   IF BLK'IOPEND THEN                                          <<04590>>25930000
      FINISHREAD(TRUE)      << Wait for I/O, check stat.    >> <<04590>>25935000
   ELSE IF BLK'DONTWAIT THEN                                   <<04590>>25940000
      FINISHREAD(FALSE);    << Dont Wait comp., check stat. >> <<04590>>25945000
                                                                        25950000
   <<*******************************************************>> <<04578>>25955000
   <<   #### RIO ####    #### RIO ####    #### RIO ####     >> <<04578>>25960000
   <<*******************************************************>> <<04578>>25965000
                                                                        25970000
   IF ACB'RIO THEN                                                      25975000
      BEGIN                                                             25980000
                                                               <<04578>>25985000
      <<****************************************************>> <<04578>>25990000
      << For FREADDIR, return an error if the current rec-  >> <<04578>>25995000
      << ord is not active, but still return the record.    >> <<04578>>26000000
      <<****************************************************>> <<04578>>26005000
                                                               <<04578>>26010000
      IF FREADDIR'MODE THEN                                    <<04592>>26015000
         BEGIN             << FREADDIR >>                               26020000
         TOS := GETARTWORD;                                             26025000
         ASMB(TBC 0,X);                                                 26030000
         IF = THEN ACB'ERROR := INACT;                                  26035000
         END                                                            26040000
                                                               <<04578>>26045000
      <<****************************************************>> <<04578>>26050000
      << For FREAD, find the first active record.  If non-  >> <<04578>>26055000
      << available in the current block, then increment the >> <<04578>>26060000
      << BLOCK number and try the next block.               >> <<04578>>26065000
      <<****************************************************>> <<04578>>26070000
                                                               <<04578>>26075000
      ELSE IF FREAD'MODE THEN                                  <<04592>>26080000
         BEGIN             << FREAD >>                                  26085000
SRCH:    TOS := GETARTWORD;                                             26090000
         TOS := TOS LAND (-1)&LSR(X);                                   26095000
         ASMB(SCAN);         << find first act. rec. >>                 26100000
         DEL;                                                           26105000
         RXB := RXB.(0:12)&LSL(4)+X;                                    26110000
         IF X = 16 THEN                                                 26115000
            BEGIN     << No active record in this bitmap. >>            26120000
            IF RXB < BLKFACT THEN GO SRCH;                              26125000
            REC'PNTR := RXB := 0; << No active recs. in blk.>> <<04578>>26130000
            BLOCK := BLOCK+1D;                                          26135000
            ACB'FPTR := BLOCK*DBLKFACT;                                 26140000
            GO RIOREAD;      << try next block. >>                      26145000
            END                                                         26150000
         ELSE                                                           26155000
                                                               <<04578>>26160000
            <<**********************************************>> <<04578>>26165000
            << Found an active record, set file pointer and >> <<04578>>26170000
            << buffer record pointer.                       >> <<04578>>26175000
            <<**********************************************>> <<04578>>26180000
                                                               <<04578>>26185000
            BEGIN       << Got a live one. >>                           26190000
            ACB'FPTR := BLOCK*DBLKFACT+DOUBLE(RXB);                     26195000
            REC'PNTR := RXB*RSIZE;                             <<04578>>26200000
            END                                                         26205000
         END          << FREAD >>                                       26210000
                                                               <<04578>>26215000
      <<****************************************************>> <<04578>>26220000
      << For FDELETE, deactivate the record and exit.       >> <<04578>>26225000
      <<****************************************************>> <<04578>>26230000
                                                               <<04578>>26235000
      ELSE IF RIO'DELETE'MODE THEN                             <<04592>>26240000
         BEGIN             << FDELETE >>                                26245000
         TOS := GETARTWORD;                                             26250000
         ASMB(TRBC 0,X);    << de-activate record >>                    26255000
         IF <> THEN PUTARTWORD(*) ELSE ACB'ERROR := INACT;              26260000
         ACB'STATUS := 1;    << return CCE >>                           26265000
         GO PEXIT                                                       26270000
         END                                                            26275000
                                                               <<04578>>26280000
      <<****************************************************>> <<04578>>26285000
      << Check active state of current record and return.   >> <<04578>>26290000
      <<****************************************************>> <<04578>>26295000
                                                               <<04578>>26300000
      ELSE IF RIO'ACTIVE'MODE THEN                             <<04592>>26305000
         BEGIN     << return activity state >>                          26310000
         TOS := GETARTWORD;                                             26315000
         ASMB(TBC 0,X);                                                 26320000
         IF = THEN ACB'ERROR := INACT;                                  26325000
         GO EXIT;                                                       26330000
         END;                                                           26335000
      END;          << RIO >>                                           26340000
                                                                        26345000
   <<*******************************************************>> <<04578>>26350000
   << For variable length records, deblock the record.  Jump>> <<04578>>26355000
   << to the next block if end of block flag is found in the>> <<04578>>26360000
   << byte count.  Check for bad variable block structure.  >> <<04578>>26365000
   <<*******************************************************>> <<04578>>26370000
                                                                        26375000
   BC'DATA'REC := ACB'RSIZE;      << data chars in record >>   <<04578>>26380000
   IF ACB'VARIABLE THEN                                                 26385000
      BEGIN         << Variable read request >>                         26390000
      GET2WORDS;     << fetch char cnts to T1-T2 >>                     26395000
      BC'DATA'REC := T1;            << rec char cnt >>         <<04578>>26400000
      IF BC'DATA'REC = -1 THEN                                 <<04578>>26405000
         BEGIN  << Block has no data records. Flush it. >>     <<01898>>26410000
         BLOCK := ACB'BLK := ACB'BLK+1D;                       <<01898>>26415000
         GO RIOREAD;                                           <<01750>>26420000
         END;                                                  <<01750>>26425000
      REC'PNTR := REC'PNTR + 1;  << Skip over byte count    >> <<04578>>26430000
      IF BC'DATA'REC < 0 OR                                    <<04578>>26435000
         BC'DATA'REC >= (ACB'BSIZE-REC'PNTR)*2 THEN            <<04578>>26440000
         ERREXIT(BADVARBLK);                                            26445000
                                                               <<04578>>26450000
      <<****************************************************>> <<04578>>26455000
      << For spoolfile records, determine the actual size of>> <<04578>>26460000
      << the data portion and determine the amount of trail->> <<04578>>26465000
      << ing fill needed to fill at the end of the record.  >> <<04578>>26470000
      << Also, REC'PNTR is updated to point past header.    >> <<04578>>26475000
      <<****************************************************>> <<04578>>26480000
                                                               <<04578>>26485000
      IF ACB'SPECVAR THEN                                               26490000
         BEGIN      << T2 is original record char count. >>             26495000
         BC'DATA'REC := BC'DATA'REC - REC'OVERHEAD;            <<04578>>26500000
         IF NOT ACB'SPOOLED OR ACB'SPFOPT.FOPFORMATF <> 0 THEN          26505000
            IF BC > T2 THEN BC := T2;  << reduce large request >>       26510000
         IF BC > BC'DATA'REC                                   <<04578>>26515000
            THEN BC'TRAIL'FILL := BC - BC'DATA'REC;            <<04578>>26520000
         REC'PNTR := REC'PNTR + REC'OVERHEAD/2;                <<04606>>26525000
         END;         << special variable >>                            26530000
      IF BC > BC'DATA'REC                                      <<04578>>26535000
         THEN BC := BC'DATA'REC;  << Reduce large request.  >> <<04578>>26540000
                                                               <<04578>>26545000
      <<****************************************************>> <<04578>>26550000
      << MOVE spoolfile record's trailing fill into the     >> <<04578>>26555000
      << users target buffer.                               >> <<04578>>26560000
      <<****************************************************>> <<04578>>26565000
                                                               <<04578>>26570000
      IF BC'TRAIL'FILL > 0 THEN                                <<04578>>26575000
         BEGIN        << Regenerate trailing fill characters >>         26580000
         TOS := @TARGET*2 + BC'DATA'REC; << byte address >>    <<04578>>26585000
         ASMB(DUP,INCB);                                                26590000
         BPS0 := FILL;                                                  26595000
         MOVE * := * ,(BC'TRAIL'FILL-1);                       <<04578>>26600000
         END                                                            26605000
      END      << variable read request >>                              26610000
                                                                        26615000
   <<*******************************************************>> <<04578>>26620000
   << For undefined files, determine byte count of record   >> <<04578>>26625000
   << from block transmission log.                          >> <<04578>>26630000
   <<*******************************************************>> <<04578>>26635000
                                                               <<04578>>26640000
   ELSE IF ACB'UNDEFINED THEN                                           26645000
      BEGIN          << "Undefined" record format >>                    26650000
      IF BLK'TLOG < 0                                          <<04578>>26655000
         THEN BC'DATA'REC := \BLK'TLOG\   << Positive bytes >> <<04578>>26660000
         ELSE BC'DATA'REC := BLK'TLOG * 2;                     <<04578>>26665000
      IF BC > BC'DATA'REC                                      <<04578>>26670000
         THEN BC := BC'DATA'REC;   << Block was short.      >> <<04578>>26675000
      END;                                                              26680000
                                                                        26685000
   <<*******************************************************>> <<04578>>26690000
   << Check for logical EOF.  ACB'CTL specifies nature of   >> <<04578>>26695000
   << caller and what kind of EOF he expects.  See FREAD    >> <<04578>>26700000
   << for more details.                                     >> <<04578>>26705000
   <<*******************************************************>> <<04578>>26710000
                                                                        26715000
   GET2WORDS;             << fetch first 2 words to T1-T2 >>            26720000
   IF ACB'CTL.(11:1) THEN                                               26725000
      BEGIN            << Non-CI job or session. >>                     26730000
      IF BC'DATA'REC > 0 THEN                                  <<04578>>26735000
         BEGIN                                                          26740000
         IF BC'DATA'REC >= 4 AND (LT1 LAND %177737) = ":E"     <<04578>>26745000
             AND (LT2 LAND %157737) = "OD" THEN                         26750000
            BEGIN          << Super colon >>                            26755000
                         << EOF both $STDIN & $STDINX >>       <<04578>>26760000
            ACB'EOFS := %(2)11;                                <<04578>>26765000
            ACB'EOF := 1;                                               26770000
            ACB'STATUS := EOFCODE;                                      26775000
            ACB'ERROR := EOF;                                           26780000
            BC := 0;     << for 0 TLOG >>                      <<01790>>26785000
            GO XCOMP                                                    26790000
            END;                                                        26795000
                                                                        26800000
         <<*************************************************>> <<04565>>26805000
         << If encountering a ":" on input, then set EOF. If>> <<04565>>26810000
         << reading more than one byte, then leave the file >> <<04565>>26815000
         << pointer as it is for the next read.  Otherwise, >> <<04565>>26820000
         << continue as if a complete read.                 >> <<04565>>26825000
         <<*************************************************>> <<04565>>26830000
                                                               <<04565>>26835000
         IF NOT ACB'CTL AND (T1.(0:8) = ":") THEN                       26840000
            BEGIN       << ":" on $STDIN >>                             26845000
                         << EOF on $STDIN >>                   <<04578>>26850000
            ACB'EOFS := 1 LOR ACB'EOFS;                        <<04578>>26855000
            ACB'EOF := 1;                                               26860000
            ACB'STATUS := EOFCODE;                                      26865000
            ACB'ERROR := EOF;                                           26870000
            IF BC'DATA'REC > 1                                 <<04578>>26875000
               THEN GO PEXIT;  << Leave file pointer alone. >> <<04565>>26880000
            BC := 0;                                           <<01790>>26885000
            GO XCOMP                                                    26890000
            END                                                         26895000
         END                                                            26900000
      END;     << non-CI job or session >>                              26905000
                                                               <<04578>>26910000
   <<*******************************************************>> <<04578>>26915000
   << Set up MDS parameters for data transfer from ACB buf- >> <<04578>>26920000
   << fer to users buffer.                                  >> <<04578>>26925000
   <<*******************************************************>> <<04578>>26930000
                                                                        26935000
   TOS := DSTX;     << User buffer DST nr. >>                           26940000
   IF = THEN                                                            26945000
      BEGIN         << User buffer in his stack. >>                     26950000
      TOS := TOS+STKDST;      << Stack DST nr. >>                       26955000
      TOS := @TARGET+ACBX'DBOFFSET; << Segment rel addr.    >> <<06511>>26960000
      END                                                               26965000
   ELSE          << User buffer in his extra data segment. >>           26970000
      TOS := @TARGET;         << user buffer DST-rel offset >>          26975000
   TOS := ACBM'PACBV'DSTN;    << ACB buffer DST nr. >>         <<06511>>26980000
   TOS := BUFDISP+REC'PNTR;    << ACB buf locn >>              <<04578>>26985000
   TOS := (BC+1)&LSR(1);      << word count >>                          26990000
                                                                        26995000
   <<*******************************************************>> <<04578>>27000000
   << Save the last word of the users buffer in case we need>> <<04578>>27005000
   << to deal with an odd byte count.                       >> <<04578>>27010000
   <<*******************************************************>> <<04578>>27015000
                                                                        27020000
   X := S0-1;                                                           27025000
   IF X >= 0 THEN <<Make sure save word is in buffer>>        <<*0bnd*>>27030000
      T3 := TARGET(X);                                        <<*0bnd*>>27035000
                                                                        27040000
   <<*******************************************************>> <<04578>>27045000
   << Deblock data from ACB buffer to user's buffer.        >> <<04578>>27050000
   <<*******************************************************>> <<04578>>27055000
                                                                        27060000
   MOVE'DS'5;             << Move to user's buffer >>                   27065000
                                                                        27070000
   <<*******************************************************>> <<04578>>27075000
   << Handle odd byte read.  Restore the extra byte in the  >> <<04578>>27080000
   << user's buffer.                                        >> <<04578>>27085000
   <<*******************************************************>> <<04578>>27090000
                                                                        27095000
   IF LOGICAL(BC) THEN TARGET(X).(8:8) := T3;                           27100000
   ACB'STATUS := 1;    << Set to OK I/O status >>              <<01720>>27105000
                                                               <<01720>>27110000
XCOMP:                                                         <<01720>>27115000
                                                               <<04578>>27120000
   <<*******************************************************>> <<04578>>27125000
   << Update record pointer to point past record that was   >> <<04578>>27130000
   << just read in.                                         >> <<04578>>27135000
   <<*******************************************************>> <<04578>>27140000
                                                               <<04578>>27145000
   REC'PNTR := REC'PNTR + (BC'DATA'REC +1)/2;                  <<04578>>27150000
                                                                        27155000
   <<*******************************************************>> <<04578>>27160000
   << If we are reading the last record in the block, then  >> <<04578>>27165000
   << reuse the buffer, flushing it out first if it was dir->> <<04578>>27170000
   << ty and doing an anticipitory read of the next block   >> <<04578>>27175000
   << into the buffer.                                      >> <<04578>>27180000
   <<*******************************************************>> <<04578>>27185000
                                                               <<04578>>27190000
                                                                        27195000
   GET2WORDS;          << only need one, actually >>                    27200000
   IF FREAD'MODE AND                                           <<06511>>27205000
       (REC'PNTR >= BLK'TLOG) OR ACB'UNDEFINED OR              <<04578>>27210000
       ACB'VARIABLE AND T1 = -1 THEN                                    27215000
      BEGIN      << Re-use the buffer - anticipatory read. >>           27220000
      ACB'CURRBUF := (ACB'CURRBUF + 1) MOD NUM'BUFS;           <<04590>>27225000
      IF BLK'IOCOMP = 2 THEN                                            27230000
         BEGIN          << old buffer dirty; write it out. >>           27235000
         STARTWRITE;                                                    27240000
         WAYT(0);                                                       27245000
         END;                                                           27250000
      IF NOT ACB'EOF THEN STARTREAD(ACB'HIBLK+1D);                      27255000
      IF ACB'VARIABLE THEN                                              27260000
         BEGIN     << Insure start at block boundary >>                 27265000
         ACB'BLK := ACB'BLK+1D;                                         27270000
         REC'PNTR := 0;                                        <<04578>>27275000
         END                                                            27280000
      ELSE                                                              27285000
         ACB'FPTR := (BLOCK+1D)*DBLKFACT-1D;                            27290000
      END         << re-use the buffer >>                               27295000
   END        << of read request >>                                     27300000
$PAGE                                                          <<04578>>27305000
   <<*******************************************************>> <<06039>>27310000
   <<                WRITE - BUFFERED                       >> <<06039>>27315000
   <<*******************************************************>> <<06039>>27320000
   ELSE                                                        <<06039>>27325000
   BEGIN                                                       <<06039>>27330000
   IMBED := ACB'CARRIAGE LAND MODES=1 LAND (ACB'CTL <> 1);              27335000
   BC'TRAIL'FILL := 0;                                         <<04578>>27340000
                                                               <<04578>>27345000
   <<*******************************************************>> <<04578>>27350000
   << For fixed and undefined disc files, check if we are   >> <<04578>>27355000
   << attempting to write past the file limit.              >> <<04578>>27360000
   <<*******************************************************>> <<04578>>27365000
                                                               <<04578>>27370000
   IF NOT ACB'VARIABLE THEN                                             27375000
      BEGIN          << Non-variable record format >>                   27380000
      IF ACB'ACCCL=DIRACC AND ACB'FCB <> 0D AND                <<06511>>27385000
         ACB'FPTR >= GETFCB'INFO(ACB'FCB,XFLIM)                <<01961>>27390000
          AND NOT ACB'CIRFILE THEN GO ATFLIM;                  <<01961>>27395000
      IF (BC+CCTL) > ACB'RSIZE THEN                            <<04560>>27400000
         BEGIN     << Specified byte count > max. record size. >>       27405000
         IF NOT MR THEN ERREXIT(BADTCOUNT);                             27410000
         BC := ACB'RSIZE-CCTL    << Truncate request >>        <<04560>>27415000
         END                                                            27420000
      END           << non-variable >>                                  27425000
   ELSE                                                                 27430000
                                                               <<04578>>27435000
      <<****************************************************>> <<04578>>27440000
      << If we are appending to a variable length file,     >> <<04578>>27445000
      << FINDFILEND sets REC'PNTR to point past the last    >> <<04578>>27450000
      << record in the file.  The last block number was set >> <<04578>>27455000
      << when opening the file in SETACB.                   >> <<04578>>27460000
      <<****************************************************>> <<04578>>27465000
                                                               <<04578>>27470000
      BEGIN          << Variable length records >>                      27475000
      IF ACB'RTFRCT = 0D AND ACB'FPTR <> 0D THEN FINDFILEND;   <<HM.00>>27480000
                                                               <<04578>>27485000
      <<****************************************************>> <<04578>>27490000
      << Check for oversized variable writes.               >> <<04578>>27495000
      << For spoolfiles, the FORMS message sent with the    >> <<04813>>27500000
      << spoolfile FOPEN mode may be larger than the record >> <<04813>>27505000
      << size specified.  Also, FDEVICECONTROL writes may   >> <<04813>>27510000
      << also be larger than the record size.               >> <<04813>>27515000
      <<****************************************************>> <<04578>>27520000
                                                               <<04578>>27525000
      IF ACB'SPOOLED AND                                                27530000
         BC > (ACB'SPREC+ACB'SPCCTL) AND NOT FOPEN'MODE THEN   <<06511>>27535000
         BEGIN               << Oversize spoolout request. >>           27540000
         IF NOT MR THEN ERREXIT(BADTCOUNT);                             27545000
         BC := ACB'SPREC                                                27550000
         END;                                                           27555000
      IF BC > (ACB'RSIZE-BLK'OVERHEAD-REC'OVERHEAD-CCTL) THEN  <<04813>>27560000
         BEGIN          << Oversize request. >>                         27565000
         IF NOT MR THEN ERREXIT(BADTCOUNT);                             27570000
         BC := ACB'RSIZE-BLK'OVERHEAD-REC'OVERHEAD-CCTL;       <<04578>>27575000
         END;                                                           27580000
      END;            << variable length records >>                     27585000
                                                               <<06511>>27590000
   <<*******************************************************>> <<04578>>27595000
   << For a special variable write, we truncate all trailing>> <<04578>>27600000
   << blanks and do not transfer these blanks to the spool- >> <<04578>>27605000
   << file.  However, we save how many blanks we truncated  >> <<04578>>27610000
   << for the special spoolfile byte count located in the   >> <<04578>>27615000
   << spoolfile record header.                              >> <<04578>>27620000
   <<*******************************************************>> <<04578>>27625000
                                                                        27630000
   IF ACB'SPECVAR AND (BC > 1) AND ACB'ASCII AND                        27635000
       (ACB'LINECTL = 0) AND (ACB'CTL <> %320) THEN                     27640000
      BEGIN         << Genuine transfer >>                              27645000
      BC'TRAIL'FILL := BC;                                     <<04578>>27650000
      TOS := @TARGET&LSL(1)+BC-1;                                       27655000
      IF BPS0 = BYTE(FILL.(8:8)) THEN                                   27660000
         BEGIN        << Truncate trailing fill chars. >>               27665000
         ASMB(DUP,DECB);                                                27670000
         IF * <> * ,(2-BC),0 THEN TOS := -TOS;                          27675000
         BC := TOS+1;       << nr. chars remaining >>                   27680000
         DEL                << discard source addr >>                   27685000
         END;                                                           27690000
      DEL;            << discard byte pointer or target addr >>         27695000
      BC'TRAIL'FILL := BC'TRAIL'FILL - BC;                     <<04578>>27700000
      END;          << genuine transfer >>                              27705000
                                                                        27710000
   <<*******************************************************>> <<04578>>27715000
   << Check to see if the variable length record to write   >> <<04578>>27720000
   << will fit in the current block.  If not, flush the     >> <<04578>>27725000
   << buffer and advance the block variables.               >> <<04578>>27730000
   <<*******************************************************>> <<04578>>27735000
                                                               <<04578>>27740000
   IF ACB'VARIABLE THEN                                                 27745000
      BEGIN     << Variable record; check for fit. >>                   27750000
      T1 := REC'PNTR + (BC+BLK'OVERHEAD+REC'OVERHEAD+CCTL+1)/2;<<04578>>27755000
      IF T1 > DATASIZE THEN                                    <<04578>>27760000
         BEGIN      << Oops! New record won't fit in block. >>          27765000
         I := ACB'CURRBUF;     << Current buffer nr. >>                 27770000
         GETBLKPARMS;                                                   27775000
         ACB'CURRBUF := (ACB'CURRBUF + 1) MOD NUM'BUFS;        <<04590>>27780000
         IF BLK'IOCOMP = 2 THEN STARTWRITE;   << write if dirty >>      27785000
         ACB'BLK := BLOCK := BLOCK+1D;                         <<02049>>27790000
         ACB'BUFUSED := 0;                                     <<04592>>27795000
         REC'PNTR := 0;   << init. record pointer >>           <<04578>>27800000
         END;                                                           27805000
      END;     << variable >>                                           27810000
                                                                        27815000
                                                                        27820000
   <<*******************************************************>> <<04566>>27825000
   << Search buffers for correct block or for an empty      >> <<04566>>27830000
   << buffer to use.  Do no wait I/O on all buffers with    >> <<04566>>27835000
   << I/O pending to free valuable DRQ entries.             >> <<04566>>27840000
   <<*******************************************************>> <<04566>>27845000
                                                               <<04566>>27850000
   BLK'IN := NOT'FOUND;        << Clear block in flag.      >> <<04566>>27855000
   BUF'EMPTY := NOT'FOUND;     << Clear empty buf. fnd flag >> <<04566>>27860000
                                                                        27865000
   I := ACB'CURRBUF;     << Current buffer nr. >>                       27870000
   DO BEGIN << Until needed buffer is found or none avail.  >> <<06046>>27875000
      GETBLKPARMS;                                                      27880000
                                                               <<04590>>27885000
      <<****************************************************>> <<04590>>27890000
      << If the block we want is in, indicate so and call   >> <<04590>>27895000
      << WAYT if I/O pending to wait for block.  If a DONT' >> <<04590>>27900000
      << WAYT completed the I/O for the block, then check   >> <<04590>>27905000
      << the status for it now.  The DONT'WAYT call was     >> <<07286>>27910000
      << commented out for performance reasons.  Maybe some >> <<07286>>27915000
      << day we may need it.                                >> <<07286>>27920000
      <<****************************************************>> <<04590>>27925000
                                                               <<04590>>27930000
      IF BLOCK = BLK'BLOCK THEN                                         27935000
         BEGIN    << Buffer has (or will have) correct block. >>        27940000
         IF BLK'IOPEND AND WAYT(1) THEN                        <<04590>>27945000
            GO PEXIT                                           <<04590>>27950000
         ELSE IF BLK'DONTWAIT THEN                             <<04590>>27955000
            BEGIN  << Dont Wait completion, check status.   >> <<04590>>27960000
            BLK'DONTWAIT := 0;                                 <<04590>>27965000
            IF BLK'LSTAT <> 1 THEN                             <<04590>>27970000
               BEGIN  << An error occured on a pre-read.    >> <<04590>>27975000
               ACB'STATUS := BLK'LSTAT;                        <<04590>>27980000
               ACB'ERROR  := IOSTAT(ACB'STATUS);               <<04590>>27985000
               GO PEXIT;                                       <<04590>>27990000
               END;                                            <<04590>>27995000
            END;                                               <<04590>>28000000
         BLK'IN := I;          << Buffer has our block!     >> <<04566>>28005000
         END                                                   <<04566>>28010000
     !ELSE IF BLK'IOPEND AND ACB'ACCCL = DIRACC THEN           <<07286>>28015000
     !   DONT'WAYT             << Check if I/O completed.   >> <<07286>>28020000
      ELSE IF BLK'BLOCK = EMPTY AND BLK'IN = NOT'FOUND AND     <<04566>>28025000
              BUF'EMPTY = NOT'FOUND                            <<04566>>28030000
        THEN BUF'EMPTY := I;   << Use 1st. empty buffer.    >> <<04566>>28035000
      I := (I+1) MOD NUM'BUFS     << next block >>             <<04566>>28040000
      END                                                      <<04566>>28045000
   UNTIL I = ACB'CURRBUF OR BLK'IN <> NOT'FOUND;               <<06308>>28050000
                                                               <<06308>>28055000
                                                                        28060000
   <<*******************************************************>> <<04563>>28065000
   << If no buffer contains the needed block, then use an   >> <<04563>>28070000
   << empty buffer.  If none available, use the next buffer >> <<04563>>28075000
   << after the current  and bring in the needed block      >> <<04563>>28080000
   << into that buffer, writing it out first if dirty.      >> <<04563>>28085000
   <<*******************************************************>> <<04563>>28090000
                                                               <<04563>>28095000
   IF BLK'IN = NOT'FOUND THEN                                  <<04563>>28100000
      BEGIN                   << Block is not in any buffer >> <<04563>>28105000
      IF BUF'EMPTY = NOT'FOUND THEN << Empty buffer avail?  >> <<04590>>28110000
         BEGIN                                                 <<04590>>28115000
         IF DIRECT'ACCESS                                      <<04590>>28120000
            THEN I := (ACB'CURRBUF + 1) MOD NUM'BUFS           <<04590>>28125000
            ELSE I := ACB'CURRBUF;                             <<04590>>28130000
         END                                                   <<04590>>28135000
      ELSE                                                     <<04590>>28140000
         I := BUF'EMPTY;       << Empty  buffer             >> <<04590>>28145000
      GETBLKPARMS;                                             <<04563>>28150000
      IF BLK'IOCOMP = 2                                        <<04563>>28155000
         THEN STARTWRITE;     << Write out dirty buffer     >> <<04563>>28160000
      IF BLK'IOPEND AND WAYT(BLK'IOOUT)                        <<04563>>28165000
         THEN GO PEXIT;       << Report I/O error on block  >> <<04563>>28170000
      ACB'HIT := 0;           << For MMSTAT call.           >> <<06958>>28175000
      END                                                      <<04563>>28180000
   ELSE                                                        <<04563>>28185000
                                                               <<04625>>28190000
      <<****************************************************>> <<04625>>28195000
      << Otherwise, the block is already in the buffer.  If,>> <<04625>>28200000
      << by some small chance the block was from a read of  >> <<04625>>28205000
      << an unallocated extent, then call FCONV'BLK to al-  >> <<04625>>28210000
      << locate the extent.  Otherwise, skip the initiali-  >> <<04625>>28215000
      << zation stuff and complete the write.               >> <<04625>>28220000
      <<****************************************************>> <<04625>>28225000
                                                               <<04625>>28230000
      BEGIN                                                    <<04625>>28235000
      ACB'HIT := 1;           << For MMSTAT call.           >> <<06958>>28240000
      I := BLK'IN;                                             <<04625>>28245000
      GETBLKPARMS;                                             <<04625>>28250000
      IF NOT BLK'UNALLOCEXT                                    <<04625>>28255000
         THEN GO BLOCKW;      << Block is ready for write.  >> <<04625>>28260000
      END;                                                     <<04563>>28265000
                                                                        28270000
   <<*******************************************************>> <<04578>>28275000
   << Buffer is now empty and set for a new block.  If only >> <<04578>>28280000
   << one record per block, then we only need to post the   >> <<04578>>28285000
   << new block number and block disc address.              >> <<04578>>28290000
   <<*******************************************************>> <<04578>>28295000
                                                                        28300000
   IF ACB'CIRFILE AND ACB'CIROVERFLOW                          <<06048>>28305000
      THEN ADJUSTCIRFILE;                                      <<06048>>28310000
   BLK'BLOCK := -1D;     << Denote buffer empty >>             <<02049>>28315000
   BLK'FLAGS := 0;            << Nothing doing! Start fresh.>> <<04625>>28320000
   IF ACB'ACCCL = DIRACC THEN                                           28325000
      BEGIN      << Disk >>                                             28330000
      FCONV'BLK(BLOCK,DQ,MODE,0,0D,0D,0);                      <<06511>>28335000
      BLK'EXTSIZE := TOS;  << Save current extent size      >> <<04653>>28340000
      BLK'EXTBASE := TOS;  << Save current extent base      >> <<04653>>28345000
      FCEOF := TOS;                                                     28350000
      DEL;        << STX >>                                             28355000
      X := TOS;     << Error nr. >>                                     28360000
      IF <> THEN                                                        28365000
         BEGIN      << Some kind of error. >>                           28370000
         IF X = 1 THEN NEWEOF := TRUE   << Beyond prior EOF >>          28375000
         ELSE IF X = 2 THEN                                    <<HM.00>>28380000
            BEGIN     << Beyond file limit >>                  <<02072>>28385000
            IF ACB'CIRFILE THEN                                <<HM.00>>28390000
               BEGIN    << delete the first block >>           <<02072>>28395000
               ASMB(DEL,DDEL);                                 <<HM.00>>28400000
               ACB'CIROVERFLOW := 1;  << for future writes >>  <<02072>>28405000
               ADJUSTCIRFILE;                                  <<HM.00>>28410000
               FCONV'BLK(BLOCK,DQ,1,0,0D,0D,0);                <<06511>>28415000
               BLK'EXTSIZE := TOS;<< Save curr. extent size.>> <<04653>>28420000
               BLK'EXTBASE := TOS;<< Save curr. extent base.>> <<04653>>28425000
               FCEOF := TOS; DEL; X := TOS;                    <<02072>>28430000
               IF X > 2 THEN                                   <<HM.00>>28435000
                  BEGIN    << file error >>                    <<02072>>28440000
                  ACB'ERROR := X;                              <<02072>>28445000
                  ACB'STATUS := 0;                             <<02072>>28450000
                  GO PEXIT;                                    <<HM.00>>28455000
                  END;                                         <<HM.00>>28460000
               END                                             <<HM.00>>28465000
            ELSE                                               <<HM.00>>28470000
               BEGIN       << Beyond file limit >>             <<HM.00>>28475000
               IF ACB'SPOOLED  << Special message for spool >> <<06047>>28480000
                  THEN ACB'ERROR := SPOOLMAXSSECT              <<06047>>28485000
                  ELSE ACB'ERROR := EOF;                       <<06047>>28490000
               ACB'STATUS := EOFCODE;                          <<HM.00>>28495000
               ACB'EOF := 1;                                   <<HM.00>>28500000
               GO PEXIT                                        <<HM.00>>28505000
               END;                                            <<HM.00>>28510000
            END                                                <<HM.00>>28515000
         ELSE                                                           28520000
            BEGIN       << Other error >>                               28525000
            ACB'ERROR := X;   << Report error nr. >>                    28530000
            ACB'STATUS := 0;  << Clear I/O error nr. >>                 28535000
            GO PEXIT                                                    28540000
            END                                                         28545000
         END;      << some kind of error >>                             28550000
      LDEV := TOS;      << LDEV of requested record/block.  >> <<06511>>28555000
      DISKADR := TOS;   << Sector number for ATTACHIO.      >> <<06511>>28560000
      BLK'LDEV := LDEV; << Save LDEV number in block.       >> <<06511>>28565000
      BLK'DADDR := DISKADR;                                    <<06511>>28570000
      IF WRITE'EOF'MODE THEN GO PEXIT;                         <<04592>>28575000
                                                               <<04578>>28580000
      <<****************************************************>> <<04578>>28585000
      << If the blocking factor is greater than 1, then the >> <<04578>>28590000
      << block needs to be cleared if we havn't been in it  >> <<04578>>28595000
      << before (if we are writing beyond the current EOF). >> <<04578>>28600000
      <<****************************************************>> <<04578>>28605000
                                                               <<04578>>28610000
      IF BLKFACT > 1  << or RIO? >> THEN                                28615000
         BEGIN         << check for new block >>                        28620000
         IF NEWEOF THEN     << Beyond EOF block? >>                     28625000
            BEGIN   << Yes, start new block. Initialize buffer >>       28630000
            T1 := FILL;                                                 28635000
            TOS := ACBM'PACBV'DSTN; << Dest. is ACB buffer. >> <<06511>>28640000
            TOS := BUFDISP;                                             28645000
            TOS := T1ADR;                                               28650000
            TOS := 1;                                                   28655000
            MOVE'DS'3;           << put fill in ACB buffer >>           28660000
            ASMB(DDUP,DECA);                                            28665000
            TOS := DATASIZE-1;   << words left to fill >>               28670000
            MOVE'DS'5;           << propagate fill word >>              28675000
                                                                        28680000
            IF ACB'RIO THEN                                             28685000
               BEGIN   << Clear Active Record Table >>         <<00630>>28690000
               T1 := 0;                                                 28695000
               TOS := ACBM'PACBV'DSTN; << Dest. is ACB buff.>> <<06511>>28700000
               TOS := BUFDISP+DATASIZE;                                 28705000
               TOS := T1ADR;                                            28710000
               TOS := 1;                                                28715000
               MOVE'DS'3;           << put fill in ACB buffer >>        28720000
               ASMB(DDUP,DECA);                                         28725000
               TOS := ACB'BSIZE-DATASIZE-1;   << words left to fill >>  28730000
               MOVE'DS'5;           << propagate fill word >>           28735000
               END;                                            <<00630>>28740000
                                                               <<06957>>28745000
            ASMB(DZRO,INCA); TOS := ACB'BSIZE;                          28750000
            BLK'IOCB := TOS;      <<Pseudo IOCB=OK, blk size>>          28755000
            BLK'IOQX := TOS       <<Pseudo IOQX=0>>                     28760000
            END       << start new block >>                             28765000
                                                               <<04578>>28770000
         <<*************************************************>> <<04578>>28775000
         << Otherwise, we are accessing an old block.  Read >> <<04578>>28780000
         << the block into the ACB buffer.                  >> <<04578>>28785000
         <<*************************************************>> <<04578>>28790000
                                                               <<04578>>28795000
         ELSE          << Add to old block >>                           28800000
            BEGIN      << Read block to be modified. >>                 28805000
            << Stack EXTENT parameter information for ATTACHIO <<04653>>28810000
            << and indicate probable access type in FLAGS word <<04653>>28815000
            IF FWRITE'MODE                                     <<04653>>28820000
               THEN FLAGS := BFLAGS CAT BUF'SEQ (0:12:4)       <<04653>>28825000
               ELSE FLAGS := BFLAGS CAT BUF'DIR (0:12:4);      <<04653>>28830000
            TOS := BLK'EXTBASE;                                <<04653>>28835000
            TOS := BLK'EXTSIZE;                                <<04653>>28840000
            BLK'IOCB := ATTACHIO(LDEV,0,ACBM'PACBV'DSTN,       <<06511>>28845000
                        BUFDISP,0,ACB'BSIZE,P1,P2,FLAGS);      <<06511>>28850000
            << Remove the EXTENT parms on TOS               >> <<04653>>28855000
            ASMB(DDEL,DEL);                                    <<04653>>28860000
            IF BLK'LSTAT <> 1 THEN                                      28865000
               BEGIN            << Read error. >>                       28870000
               ACB'STATUS := BLK'LSTAT;                                 28875000
               ACB'ERROR := IOSTAT(ACB'STATUS);                         28880000
               GO PEXIT                                                 28885000
               END;                                                     28890000
            BLK'FLAGS := 0;    << Denote read completed >>              28895000
            END   << read block to be modified >>                       28900000
         END;    << check for new block >>                              28905000
      END;   << Disk >>                                                 28910000
   IF BLOCK > ACB'HIBLK THEN ACB'HIBLK := BLOCK;               <<06957>>28915000
   BLK'BLOCK := BLOCK;      << It's been validated >>          <<02049>>28920000
                                                               <<04578>>28925000
   <<*******************************************************>> <<04578>>28930000
   << For spoolfile records, place special record pointer   >> <<04578>>28935000
   << into the last two words of the spoolfile block.  This >> <<04578>>28940000
   << is done so that the blocks can be easily scanned to   >> <<04578>>28945000
   << find a particular spoolfile record number.            >> <<04578>>28950000
   <<*******************************************************>> <<04578>>28955000
                                                               <<04578>>28960000
   IF ACB'SPECVAR THEN                                                  28965000
      BEGIN         << Put record number at end. >>                     28970000
      DT1T2 := ACB'FPTR;                                                28975000
      TOS := ACBM'PACBV'DSTN;                                  <<06511>>28980000
      TOS := BUFDISP+ACB'BSIZE-2;                                       28985000
      TOS := T1ADR;                                                     28990000
      TOS := 2;                                                         28995000
      MOVE'DS'5;                                                        29000000
      END;                                                              29005000
                                                                        29010000
   <<*******************************************************>> <<04578>>29015000
   << The needed block is now in the buffer.  Move the rec- >> <<04578>>29020000
   << cord from the ACB buffer into the users buffer. The   >> <<04578>>29025000
   << ACB buffer address (DST and displacement) is on TOS   >> <<04578>>29030000
   << for most of what follows.                             >> <<04578>>29035000
   <<*******************************************************>> <<04578>>29040000
                                                               <<04578>>29045000
                                                                        29050000
BLOCKW:                                                                 29055000
   IF WRITE'EOF'MODE THEN GO PEXIT;                            <<04592>>29060000
   TOS := ACBM'PACBV'DSTN; << Set ACB buffer dest. address. >> <<06511>>29065000
   TOS := BUFDISP+REC'PNTR;                                    <<04578>>29070000
                                                                        29075000
   <<*******************************************************>> <<04578>>29080000
   << Prepare and post byte counts for variable file.       >> <<04578>>29085000
   << For spoolfiles, we must set up the special record,    >> <<04578>>29090000
   << with both byte counts and the ATTACHIO parameters.    >> <<04578>>29095000
   <<*******************************************************>> <<04578>>29100000
                                                               <<04578>>29105000
                                                                        29110000
   IF ACB'VARIABLE THEN                                                 29115000
      BEGIN                                                             29120000
      TOS := T1ADR;                                                     29125000
      T1 := BC+REC'OVERHEAD+CCTL; << Insert rec char cnt. >>   <<04578>>29130000
      IF ACB'SPECVAR THEN                                               29135000
         BEGIN        << Special variable format >>                     29140000
         T2 := BC+BC'TRAIL'FILL + CCTL;  << orig. char cnt.>>  <<04593>>29145000
         T3 := MODES;                << spool control >>                29150000
         T4 := IF IMBED THEN 1 ELSE ACB'CTL;  << P1 >>                  29155000
         TOS := ACB'LPCTL;                                              29160000
         TOS.(12:1) := NOT ACB'ASCII;                                   29165000
         T5 := TOS;                        << P2 >>                     29170000
         IF MODES >= MIN'MODE'FDEVICECONTROL THEN              <<04321>>29175000
            DT4T5 := ACB'P1P2;    << Set by FDEVICECONTROL. >> <<06511>>29180000
         TOS := 5;                                                      29185000
         END   << special variable >>                                   29190000
      ELSE                                                              29195000
         TOS := 1;                                                      29200000
      REC'PNTR := REC'PNTR + S0; << Skip over header.          <<04578>>29205000
      MOVE'DS'3;   << leave ACB buf addr on TOS >>                      29210000
      END;       << variable >>                                         29215000
                                                                        29220000
   <<*******************************************************>> <<04578>>29225000
   << Now, set the current buffer number and declare the    >> <<04578>>29230000
   << block to be "dirty".                                  >> <<04578>>29235000
   <<*******************************************************>> <<04578>>29240000
                                                               <<04578>>29245000
   ACB'CURRBUF := I;    << Set current buffer nr. >>                    29250000
   BLK'DIRTY := 1;      << Set buffer modified flag >>                  29255000
                                                                        29260000
   <<*******************************************************>> <<06511>>29265000
   << Get parameters for data transfer.  Do not perform any >> <<06511>>29270000
   << transfer if the byte count is 0.                      >> <<06511>>29275000
   <<*******************************************************>> <<06511>>29280000
                                                               <<06511>>29285000
   IF BC > 0 THEN                                              <<06511>>29290000
      BEGIN                                                    <<06511>>29295000
      IF DSTX = 0 THEN      << User buffer in his stack?    >> <<06511>>29300000
         BEGIN                                                 <<06511>>29305000
         TOS := STKDST;     << Stack DST nr.                >> <<06511>>29310000
         TOS := @TARGET+ACBX'DBOFFSET;                         <<06511>>29315000
         END                                                   <<06511>>29320000
      ELSE                                                     <<06511>>29325000
         BEGIN                                                 <<06511>>29330000
         TOS := DSTX;       << Extra data segment DST.      >> <<06511>>29335000
         TOS := @TARGET;    << User buffer offset.          >> <<06511>>29340000
         END;                                                  <<06511>>29345000
                                                               <<06511>>29350000
      <<****************************************************>> <<06511>>29355000
      << Now move the data from the users buffer to the ACB >> <<06511>>29360000
      << buffer.                                            >> <<06511>>29365000
      <<****************************************************>> <<06511>>29370000
                                                               <<06511>>29375000
      TOS := (BC+1)/2;    << Total word count.              >> <<06511>>29380000
      T1 := TARGET(S0-1); << Save last word of user buffer. >> <<06511>>29385000
      IF LOG(BC)          << Stuff fill for odd byte count. >> <<06511>>29390000
         THEN TARGET(X).(8:8) := FILL;                         <<06511>>29395000
      MOVE'DS'3;          << Move data from user's buffer.  >> <<06511>>29400000
      TARGET(X) := T1;    << Restore last word of buffer.   >> <<06511>>29405000
      END;                                                     <<06511>>29410000
                                                                        29415000
   <<*******************************************************>> <<04578>>29420000
   << To imbed the carriage control byte, shift all the data>> <<04578>>29425000
   << in the buffer record one byte right and place CCTL at >> <<04578>>29430000
   << the first byte of the record.                         >> <<04578>>29435000
   <<*******************************************************>> <<04578>>29440000
                                                               <<04578>>29445000
   IF IMBED THEN                                                        29450000
      BEGIN         << Imbed carriage control byte >>                   29455000
      EXCHANGEDB(ACBM'PACBV'DSTN);  << to ACB buffer.       >> <<06511>>29460000
      TOS := S0&LSL(1);     << current byte address >>                  29465000
      IF LOG(BC) THEN TOS := TOS-1   << one byte too far >>             29470000
      ELSE                                                              29475000
         BEGIN                                                          29480000
         S1 := S1+1;    << will be current word posn >>                 29485000
         BPS0(1) := BYTE(FILL);                                         29490000
         END;                                                           29495000
      ASMB(DUP,DECA);                                                   29500000
      MOVE * := *,(-BC),2;  << Shift right one byte >>                  29505000
      BPS0 := ACB'CTL;      << Insert carriage control byte >>          29510000
      DEL;                                                              29515000
      EXCHANGEDB(DSTX)      << back to user's buffer >>                 29520000
      END;       << imbed car control >>                                29525000
                                                                        29530000
   <<*******************************************************>> <<04578>>29535000
   << Place block terminator after record for variable. For >> <<04578>>29540000
   << fixed or undefined, propigate fill characters into the>> <<04578>>29545000
   << record for a write shorter than one record in length. >> <<04578>>29550000
   <<*******************************************************>> <<04578>>29555000
                                                               <<04578>>29560000
   IF ACB'VARIABLE THEN                                                 29565000
      BEGIN   << Put block terminator [-1] after record. >>             29570000
      T1 := -1;                                                         29575000
      TOS := T1ADR;                                                     29580000
      TOS := 1;                                                         29585000
      MOVE'DS'3;                                                        29590000
      END                                                               29595000
   ELSE      << ACB'FIXED Calculate WORD count to propigate.>> <<04560>>29600000
      BEGIN                                                    <<04560>>29605000
      T2 := (ACB'RSIZE+1)/2 - (CCTL+BC+1)/2;                   <<04560>>29610000
                                                               <<04560>>29615000
      IF T2 > 0 THEN                                           <<04560>>29620000
         BEGIN  << Fill short record out to standard size. >>  <<04560>>29625000
         T1 := FILL;                                           <<04560>>29630000
         TOS := T1ADR;                                         <<04560>>29635000
         TOS := 1;                                             <<04560>>29640000
         MOVE'DS'3;        << put fill in ACB buffer >>        <<04560>>29645000
         ASMB(DDUP,DECA);                                      <<04560>>29650000
         TOS := T2-1;      << words left to fill >>            <<04560>>29655000
         MOVE'DS'3;        << propagate fill word >>           <<04560>>29660000
         END;                                                  <<04560>>29665000
      END;                                                     <<04560>>29670000
                                                                        29675000
                                                                        29680000
   <<*******************************************************>> <<04578>>29685000
   << Delete ACB buffer DST and offset off of stack.  Then  >> <<04578>>29690000
   << update buffer record pointer and EOF.                 >> <<04578>>29695000
   <<*******************************************************>> <<04578>>29700000
                                                               <<04578>>29705000
   DDEL;                << Done with ACB buff addr. >>                  29710000
   IF ACB'FIXED                                                <<04578>>29715000
      THEN REC'PNTR := REC'PNTR + (ACB'RSIZE+1)/2              <<04578>>29720000
      ELSE REC'PNTR := REC'PNTR + (BC+CCTL+1)/2;               <<04578>>29725000
   IF ACB'ACCCL=DIRACC THEN                                    <<06169>>29730000
      FSET'EOF(ACB'FPTR+1D,ACB'BLK);                           <<06169>>29735000
                                                                        29740000
   <<*******************************************************>> <<04578>>29745000
   << For RIO, activate bit for record written in the ART.  >> <<04578>>29750000
   <<*******************************************************>> <<04578>>29755000
                                                                        29760000
   IF ACB'RIO THEN                                                      29765000
      BEGIN                                                             29770000
      TOS := GETARTWORD;                                                29775000
      ASMB(TSBC 0,X);      << set bit X -- activate >>                  29780000
      PUTARTWORD(*);                                                    29785000
      END;                                                              29790000
                                                                        29795000
   <<*******************************************************>> <<04578>>29800000
   << If we are writing to the last record in the block,    >> <<04578>>29805000
   << then start the write of the block to disc, verifying  >> <<04578>>29810000
   << the write if I/O has completed or the user has re-    >> <<04578>>29815000
   << quested verification of all output (FSETMODE bit 14). >> <<04578>>29820000
   <<*******************************************************>> <<04578>>29825000
                                                               <<04578>>29830000
   IF REC'PNTR >= DATASIZE OR ACB'UNDEFINED THEN               <<04578>>29835000
      BEGIN       << Buffer full; write it out. >>                      29840000
      ACB'CURRBUF := (ACB'CURRBUF + 1) MOD NUM'BUFS;           <<04590>>29845000
      STARTWRITE;                                                       29850000
      IF ACB'QUIESCE OR WAITIO'COMP THEN                       <<06048>>29855000
         BEGIN       << Verify output. >>                               29860000
         IF WAYT(1) THEN GO PEXIT  << I/O error. >>                     29865000
         END;                                                           29870000
      END;            << buffer was full >>                             29875000
   ACB'STATUS := 1;      << claim xfer was good >>             <<02071>>29880000
   END;   << of buffered write request >>                               29885000
$PAGE                                                          <<04578>>29890000
   <<*******************************************************>> <<04578>>29895000
   <<                                                       >> <<04578>>29900000
   <<          BUFFERED COMPLETION - READ AND WRITE         >> <<04578>>29905000
   <<                                                       >> <<04578>>29910000
   << Update the ACB transmission log, buffer record poin-  >> <<04578>>29915000
   << ter (used for variable files to keep track of where   >> <<04578>>29920000
   << we are in the block), file record pointer and record  >> <<04578>>29925000
   << transfer count.                                       >> <<04578>>29930000
   <<*******************************************************>> <<04578>>29935000
                                                                        29940000
   IF ACB'VARIABLE THEN BC := BC+BC'TRAIL'FILL;                <<04578>>29945000
   ACB'TLOG := ACB'TLOG+(IF TCOUNT < 0 THEN -BC                         29950000
      ELSE (BC+1)&LSR(1));     << +words or -bytes >>                   29955000
   ACB'BUFUSED := REC'PNTR;                                    <<04578>>29960000
   ACB'FPTR := ACB'FPTR+1D;       << Set file pointer >>                29965000
   ACB'RTFRCT := ACB'RTFRCT+1D;   << Bump transfer count >>             29970000
                                                               <<04578>>29975000
   <<*******************************************************>> <<04578>>29980000
   << If we are writing MR to a spoolfile, then we break the>> <<04578>>29985000
   << write up into record size pieces, continuing to write >> <<04578>>29990000
   << unil done.                                            >> <<04578>>29995000
   <<*******************************************************>> <<04578>>30000000
                                                               <<04578>>30005000
   IF MR THEN                                                           30010000
      BEGIN             << multi-block transfer. >>                     30015000
      @TARGET := @TARGET+(BC+1)&LSR(1);                                 30020000
      BC := TCOUNT-ACB'TLOG;  << Amt. left to do (+W/-B)>>              30025000
      BC := IF TCOUNT < 0 THEN -BC ELSE BC&LSL(1);  << +B >>            30030000
      IF BC <= 0 THEN GO PEXIT;     << MR done. >>                      30035000
      PUTBLKPARMS;                                                      30040000
      GO MRLOOP         << Get next block >>                            30045000
      END;                                                              30050000
                                                                        30055000
   TOS := ACB'SPXDDX;                                                   30060000
   IF <> AND (ACB'FPLOW LAND %77) = 0 THEN                              30065000
      XDDSPOOLINFO(ACB'FPTR,%21,PS0);  << line count >>                 30070000
   DEL;                                                                 30075000
                                                                        30080000
PEXIT:                                                                  30085000
   PUTBLKPARMS;                                                         30090000
   END;   << of buffered I/O >>                                         30095000
                                                                        30100000
EXIT:                                                                   30105000
   IF ACB'ERROR = TAPERREC THEN IF ACB'TAPEERROR THEN          <<02068>>30110000
     ACB'STATUS := PARERRSTAT     << CCL for recov err >>      <<02071>>30115000
      ELSE BEGIN                                               <<02071>>30120000
      ACB'ERROR := 0;      << Ignore recovered tape error. >>           30125000
SETX: ACB'STATUS := 1;                                                  30130000
      END;                                                              30135000
   TOS := ACB'ERROR;                                                    30140000
   ACB'ERROR := TOS;                                                    30145000
   END;         << procedure IOMOVE >>                                  30150000
                                                                        30155000
$PAGE " FQUIESCEIO "                                                    30160000
                                                               <<06511>>30165000
$CONTROL SEGMENT = FILESYS1A  << FQUIESCE'IO >>                         30170000
INTEGER PROCEDURE FQUIESCE'IO(MODE);                                    30175000
VALUE MODE; LOGICAL MODE;                                               30180000
                                                               <<04591>>30185000
<<**********************************************************>> <<04591>>30190000
<< This procedure completes all outstanding I/O against the >> <<04591>>30195000
<< file specified by the ACB.  If I/O is pending, then a    >> <<04591>>30200000
<< Wait takes place until its completion.  If a buffer is   >> <<04591>>30205000
<< dirty but not written, then it is written.               >> <<04591>>30210000
<<                                                          >> <<04591>>30215000
<<   Input variables:                                       >> <<04591>>30220000
<<       MODE - TRUE if searching for EOF (from tape).      >> <<04591>>30225000
<<              Used for Forward Space File, return when an >> <<04591>>30230000
<<              EOF is found on a pre-read.                 >> <<04591>>30235000
<<                                                          >> <<04591>>30240000
<<   Output variable:                                       >> <<04591>>30245000
<<       FQUIESCE'IO - Number of buffers quiesced.  This is >> <<04591>>30250000
<<                     used in some magnetic tape operations>> <<04591>>30255000
<<                     to concur the logical and physical   >> <<04591>>30260000
<<                     tape positions do to pre-reads. Eg.  >> <<04591>>30265000
<<                     when a Write is performed after any  >> <<04591>>30270000
<<                     number of pre-reads mispositioned the>> <<04591>>30275000
<<                     the head.                            >> <<04591>>30280000
<<                     If MODE is requested and EOF is hit, >> <<04591>>30285000
<<                     then -1 is returned as the value.    >> <<04591>>30290000
<< NOTE:  DB can be set anywhere upon entrance.             >> <<04591>>30295000
<<        The ACB MUST BE AT Q-62!!!!!  Do not stack any    >> <<04591>>30300000
<<        variables before calling this procedure!!!!!!!    >> <<04591>>30305000
<<        Also, use TOS for the return value so that the    >> <<04591>>30310000
<<        compiler does not leave any variables on TOS.     >> <<04591>>30315000
<<**********************************************************>> <<04591>>30320000
                                                               <<04591>>30325000
OPTION PRIVILEGED,UNCALLABLE;                                           30330000
BEGIN                                                                   30335000
   EQUATE  DQ = -62;  << Q-relative offset to ACB.          >> <<06511>>30340000
   INTEGER ARRAY ACB(*) = Q-62;                                         30345000
   BUILD'ACBNR;                                                <<06511>>30350000
                                                                        30355000
                                                                        30360000
   << Current block header image [buffered] at Q+1 >>                   30365000
                                                                        30370000
   INTEGER BLK'IOQX;                                                    30375000
   LOGICAL BLK'FLAGW;                                                   30380000
   DOUBLE BLK'IOCB, BLK'BLOCK, BLK'DADDR;                               30385000
   DOUBLE BLK'EXTBASE;  << EXTENT BASE OF CURRENT BLOCK >>     <<04653>>30390000
   LOGICAL BLK'EXTSIZE; << EXTENT SIZE OF CURRENT BLOCK >>     <<04653>>30395000
   LOGICAL BLK'DUMMY;   << * * CURRENTLY UNUSED * *     >>     <<04653>>30400000
      INTEGER BLK'LSTAT = BLK'IOCB;                                     30405000
      INTEGER BLK'TLOG  = BLK'IOCB+1;                                   30410000
                                                                        30415000
   INTEGER RESULT = FQUIESCE'IO;                                        30420000
   INTEGER PCBPT;                                              <<06511>>30425000
   INTEGER I;                                                           30430000
   INTEGER J;            << nr. of buffers >>                           30435000
   INTEGER LDEV;         << LDEV of block >>                            30440000
   DOUBLE DISKADR;       << sector nr. >>                               30445000
   INTEGER P1 = DISKADR;    << sector nr. - first half >>               30450000
   INTEGER P2 = DISKADR+1;  << sector nr. - second half >>              30455000
   INTEGER BUFDISP,FERR;                                       <<04591>>30460000
   DOUBLE BKHDADR;         << DST-rel addr of blk header image >>       30465000
      INTEGER STKDST=BKHDADR;                                           30470000
      INTEGER Q'1'A =BKHDADR+1;                                         30475000
   DOUBLE BLOCK;                                                        30480000
                                                               <<*7856>>30485000
   DOUBLE IO'STATUS;  << return status from attachio >>        <<*7856>>30490000
   LOGICAL IO'STATUS'L = IO'STATUS;                            <<*7856>>30495000
                                                               <<*7856>>30500000
   LOGICAL SUBTYPE;   << device subtype >>                     <<*7856>>30505000
   LOGICAL ARRAY DEV'STATUS(0:2) = Q;  << device status >>     <<*7856>>30510000
                                                               <<*7856>>30515000
   LOGICAL SPLIT'STACK;  << true iff in split stack mode >>    <<*7856>>30520000
   LOGICAL SAVE'DB;      << User's db saved >>                 <<*7856>>30525000
                                                               <<04653>>30530000
<< I/O type information for FLAGS.(0:4) of ATTACHIO >>         <<04653>>30535000
EQUATE BUF'FLUSH = 9;                                          <<04653>>30540000
                                                                        30545000
$  IF X0 = ON                                                           30550000
   IF MONOTHER THEN  << monitoring? >>                                  30555000
      BEGIN                                                             30560000
      FTITLE("FQUI","ESCE","IO  ",0D);                                  30565000
      DEBUG                                                             30570000
      END;                                                              30575000
$  IF                                                                   30580000
                                                                        30585000
   <<* * *  Initialize local variables  * * *>>                         30590000
                                                                        30595000
   IF ACB'MSGFILE AND (NOT ACB'COPY) THEN RETURN;              <<*7586>>30600000
   PCBPT := CURPRC;                                            <<06511>>30605000
   STKDST := SPCBSTKDST;                                       <<06511>>30610000
   PUSH(DL,Q);                                                          30615000
   ASMB(XCH,SUB);            << DL-Q for Q-rel addressing >>            30620000
   ASMB(DUP,STAX);                                                      30625000
   X := TOS-AQM1(X);         << (a-Q) <== (DL-Q) - (DL-a) >>            30630000
   Q'1'A := 1-X;             << 1 - (a-Q) >>                            30635000
                                                               <<06048>>30640000
   ACB'CIROVERFLOW := 0;     << Force FCONV'BLK of circular.>> <<06048>>30645000
   ACB'FULLBUFFS := 0;       << Indicate empty buffers.     >> <<07286>>30650000
   J := ACB'NUMBUFS +1;      << Number of buffers - J       >> <<06048>>30655000
   I := ACB'CURRBUF;         << Start with current buffer #.>> <<06048>>30660000
   IF ACB'ACCCL <> DIRACC THEN                                          30665000
      BEGIN                << Not disk. >>                              30670000
      LDEV := ACB'DADDR;     << LDEV of device >>                       30675000
      TOS := ACB'CTL;        << carriage control >>                     30680000
      TOS := ACB'LPCTL;      << line and page control >>                30685000
      TOS.(12:1) := NOT ACB'ASCII;   << ASCII/binary format >>          30690000
      TOS.(13:1) := 1;   << allow tape write past EOT >>       <<02054>>30695000
      P2 := TOS; P1 := TOS;                                             30700000
      ACB'EOF := 0;                                                     30705000
      IF <> THEN ASMB(NOP);     << for bug trap >>                      30710000
      <<************************************************>>     <<*7856>>30715000
      << If the device is a streaming device, quiesce   >>     <<*7856>>30720000
      << the drive and report any errors                >>     <<*7856>>30725000
      <<************************************************>>     <<*7856>>30730000
      SUBTYPE := LDEVTOSUBTYPE(LDEV);                          <<*7856>>30735000
      IF STREAMING'DEVICE THEN                                 <<*7856>>30740000
         BEGIN                                                 <<*7856>>30745000
            IF SPLIT'STACK THEN                                <<*7856>>30750000
            SAVE'DB := EXCHANGEDB(0);                          <<*7856>>30755000
         IO'STATUS := ATTACHIO(LDEV,0,0,@DEV'STATUS,           <<*7856>>30760000
                               CHECK'STATUS,3,0,4,BFLAGS);     <<*7856>>30765000
         IF SPLIT'STACK THEN                                   <<*7856>>30770000
            EXCHANGEDB(SAVE'DB);                               <<*7856>>30775000
         ACB'STATUS := IO'STATUS'L;                            <<*7856>>30780000
         IF ACB'STATUS <> 1 THEN                               <<*7856>>30785000
            BEGIN                                              <<*7856>>30790000
            FERR := IOSTAT(ACB'STATUS);                        <<*7856>>30795000
            IF FERR = EOF THEN                                 <<*7856>>30800000
               ACB'EOF := 1                                    <<*7856>>30805000
            ELSE                                               <<*7856>>30810000
               ACB'ERROR := FERR;                              <<*7856>>30815000
            END;  << attachio error >>                         <<*7856>>30820000
         END;  << streaming device >>                          <<*7856>>30825000
      END;                                                              30830000
                                                                        30835000
   <<* * *  Cycle through buffers  * * *>>                              30840000
                                                                        30845000
   DO BEGIN                                                             30850000
      TOS := BKHDADR;                                                   30855000
      TOS := ACBM'PACBV'DSTN;                                  <<06511>>30860000
      TOS := ACBX'PACBOFFSET+SIZEACB+I*(BLKBUFDISP+ACB'BSIZE); <<06511>>30865000
      TOS := BLKBUFDISP;     << nr. words in header >>                  30870000
      MOVE'DS'1;   << Copy buffer header to local storage. >>           30875000
      BUFDISP := TOS;    << ACB buffer address >>                       30880000
      ASMB(DDEL,DEL);                                                   30885000
      IF BLK'IOPEND THEN                                       <<01802>>30890000
         BEGIN     << Pending I/O to clean up. >>              <<01802>>30895000
         IF BLK'IOQX <> 0 THEN                                 <<01802>>30900000
            BEGIN         << I/O in progress >>                <<01802>>30905000
            BLK'IOCB := WAITFORIO(BLK'IOQX);  << await complete  SERIO>>30910000
$   IF X1 = ON                                                          30915000
            IF <> THEN FTROUBLE(480);  << error >>             <<01802>>30920000
$   IF                                                                  30925000
            END;                                               <<01802>>30930000
         GO BUMP                                                        30935000
         END                                                            30940000
      ELSE IF BLK'IOCOMP = 2 THEN                                       30945000
         BEGIN    << Buffer dirty and not yet written. >>               30950000
         IF ACB'ACCCL = DIRACC THEN                                     30955000
            BEGIN              << Disk. >>                              30960000
            DISKADR := BLK'DADDR;                              <<06511>>30965000
            LDEV := BLK'LDEV;                                  <<06511>>30970000
            END                                                <<02545>>30975000
         ELSE IF ACB'DTYPE = MTAPE THEN                        <<02652>>30980000
            BEGIN                                              <<02652>>30985000
            BLK'IOCB := WRITE'DENSITY(LDEV);                   <<02652>>30990000
            IF BLK'LSTAT.(8:8) <> 1 THEN                       <<02652>>30995000
               GO BUMP;  << Don't do write.  Report error. >>  <<02652>>31000000
            END;                                               <<02652>>31005000
         << Stack EXTENT parameters for ATTACHIO >>            <<04653>>31010000
         TOS := BLK'EXTBASE;                                   <<04653>>31015000
         TOS := BLK'EXTSIZE;                                   <<04653>>31020000
         BLK'IOCB := ATTACHIO(LDEV,0,ACBM'PACBV'DSTN,BUFDISP,1,<<06511>>31025000
            IF I = ACB'CURRBUF AND ACB'ACCCL <> DIRACC THEN             31030000
               ACB'BUFUSED+(IF ACB'VARIABLE THEN 1 ELSE 0)              31035000
            ELSE                                                        31040000
               ACB'BSIZE,                                               31045000
            P1,P2,BFLAGS CAT BUF'FLUSH (0:12:4)); << BLK wrt >><<04653>>31050000
         << Remove stacked EXTENT parameters >>                <<04653>>31055000
         ASMB(DDEL,DEL);                                       <<04653>>31060000
BUMP:    BLK'IOQX := 0;        << clear IOQX >>                <<01802>>31065000
         ACB'TLOG := BLK'TLOG;  << set transmission log >>              31070000
         ACB'STATUS := BLK'LSTAT;                              <<00483>>31075000
         IF ACB'GSTATUS = 1 THEN                               <<*8073>>31080000
            ACB'BTFRCT := ACB'BTFRCT+1D << OK: bump count >>   <<00483>>31085000
         ELSE                                                  <<04591>>31090000
            BEGIN                                              <<04591>>31095000
            FERR := IOSTAT(ACB'STATUS);                        <<04591>>31100000
            IF FERR = EOF                                      <<04591>>31105000
               THEN ACB'EOF := 1                               <<04591>>31110000
               ELSE IF BLK'IOOUT THEN                          <<*8073>>31115000
                  ACB'ERROR := FERR; <<Only report write errs>><<*8073>>31120000
            END;                                               <<04591>>31125000
                                                               <<04591>>31130000
         <<*************************************************>> <<04591>>31135000
         << Do not report a pre-read if labeled and EOF hit >> <<04591>>31140000
         << since, when it was originally hit, tape labels  >> <<04591>>31145000
         << backspaced over the EOF, so we don't have to    >> <<04591>>31150000
         << back space over it again.                       >> <<04591>>31155000
         <<*************************************************>> <<04591>>31160000
                                                               <<04591>>31165000
         IF NOT(ACB'LABELLED LAND ACB'EOF)                     <<04591>>31170000
            THEN RESULT := RESULT+1;                           <<04591>>31175000
         END;           << buffer dirty >>                              31180000
      BLOCK := BLK'BLOCK;                                               31185000
      BLK'BLOCK := -1D;     << Mark buffer empty >>                     31190000
      BLK'FLAGS  := 0;                                         <<04590>>31195000
      TOS := ACBM'PACBV'DSTN;                                  <<06511>>31200000
      TOS := ACBX'PACBOFFSET+SIZEACB+I*(BLKBUFDISP+ACB'BSIZE); <<06511>>31205000
      TOS := BKHDADR;                                                   31210000
      TOS := BLKBUFDISP;     << nr. words in header >>                  31215000
      MOVE'DS'5;          << Post updated block header to PACB. >>      31220000
      I := (I+1) MOD J;    << Advance buffer >>                         31225000
      IF MODE AND ACB'EOF THEN                                          31230000
         BEGIN      << Mag tape FSF; got EOF on preread. >>             31235000
         ACB'FPTR := (BLOCK+1D)*DOUBLE(ACB'BLKFACT);                    31240000
         ACB'CURRBUF := I;                                              31245000
         FQUIESCE'IO := -1;                                             31250000
         ACB'EOF := 0;                                                  31255000
         RETURN;                                                        31260000
         END;                                                           31265000
      END UNTIL I = ACB'CURRBUF;                                        31270000
   IF ACB'ACCCL <> DIRACC THEN                                 <<04141>>31275000
      BEGIN << Future writes must be to new block >>           <<04141>>31280000
      ACB'BLK := ACB'BLK + 1D;                                 <<04141>>31285000
      IF ACB'VARIABLE THEN ACB'BUFUSED := 0                    <<04141>>31290000
      ELSE ACB'FPTR := (BLOCK+1D)*DOUBLE(ACB'BLKFACT);         <<04141>>31295000
      END;                                                     <<04141>>31300000
                                                               <<04141>>31305000
   END;     << procedure FQUIESCE'IO >>                                 31310000
$PAGE "  IOWAIT SUB-PROCEDURES "                                        31315000
$ CONTROL SEGMENT = FILESYS2  << GET'CS'IOQINDICES >>                   31320000
                                                                        31325000
INTEGER PROCEDURE GET'CS'IOQINDICES(CSMDST,IOQ'VECTOR,         <<00613>>31330000
      IOQINDEX'ARRAY);                                                  31335000
VALUE IOQ'VECTOR,CSMDST;                                                31340000
INTEGER IOQ'VECTOR,CSMDST;                                              31345000
INTEGER ARRAY IOQINDEX'ARRAY;                                           31350000
OPTION PRIVILEGED,UNCALLABLE;                                           31355000
   BEGIN                                                                31360000
   << This procedure is used to return all of the IOQ indices           31365000
      associated with a CS AFT entry.  These IOQ indices are            31370000
      recovered from the data segment associated with the AFT           31375000
      "CSMDST", with the pointer being "IOQ'VECTOR".                    31380000
        Input: IOQ'VECTOR - vector to CS IOQ index entries              31385000
                CSMDST - DST number containing IOQ indices              31390000
        Output:  NUM'IOQS - number of IOQ indices                       31395000
             IOQINDEX'ARRAY - array containing the IOQ indices          31400000
      This procedure is also called by CABORTIO in COMSYS1.             31405000
      DB is at the stack.  >>                                           31410000
                                                                        31415000
   EQUATE MAXCBSIZE=15;                                                 31420000
   INTEGER I,NUM'IOQS;                                                  31425000
   INTEGER ARRAY CB(0:MAXCBSIZE);                                       31430000
                                                                        31435000
   TOS := @CB;                                                          31440000
   TOS := CSMDST;                                                       31445000
   TOS := IOQ'VECTOR;                                                   31450000
   TOS := MAXCBSIZE;                                                    31455000
   ASSEMBLE(MFDS);    << copy to local Q-rel array >>                   31460000
<< Move IOQ indices into IOQINDEX array. >>                             31465000
   NUM'IOQS := CB.(8:8) -1;   <<CB size includes zero'th word>>         31470000
   MOVE IOQINDEX'ARRAY := CB(1),(NUM'IOQS);                             31475000
<< Find number of IOQ indices >>                                        31480000
   I := 0;                                                              31485000
   WHILE IOQINDEX'ARRAY(I) <> 0 AND I < NUM'IOQS DO                     31490000
      I := I+1;                                                         31495000
   GET'CS'IOQINDICES := I;                                              31500000
   END;      << procedure GET'CS'IOQINDICES >>                          31505000
$ PAGE                                                                  31510000
PROCEDURE FINDWAITINGIO (IONUMBER,AFT,FLAGS);                           31515000
   << Finds and optionally waits for the first pending No-wait          31520000
     I/O request to complete.                                           31525000
     Input variables:                                                   31530000
         FLAGS - special action flags                                   31535000
            (14:1) - don't wait for I/O completion                      31540000
               0 - impede (wait) if no I/O has completed                31545000
               1 - return IONUMBER = 0 if no I/O has completed          31550000
            (15:1) - special completion checking order                  31555000
               0 - check for I/O completion at LEFTOFF+1                31560000
               1 - check for I/O completion at AFT 1                    31565000
                                                                        31570000
     Output variables:                                                  31575000
         IONUMBER - file/line number of completed I/O                   31580000
         AFT - AFT entry pointer of completed I/O                       31585000
                                                                        31590000
     Condition code:                                                    31595000
         CCE - OK                                                       31600000
         CCL - no I/O pending                                           31605000
                                                                        31610000
     This procedure can be called with DB at any data segment.          31615000
     DB will be at the stack when this procedure returns. >>            31620000
                                                                        31625000
VALUE IONUMBER,AFT,FLAGS;                                               31630000
INTEGER IONUMBER;                                                       31635000
INTEGER POINTER AFT;                                                    31640000
LOGICAL FLAGS;                                                          31645000
OPTION INTERNAL,PRIVILEGED,UNCALLABLE;                                  31650000
   BEGIN                                                                31655000
   DEFINE DONTWAIT = FLAGS.(14:1)#,  <<Don't wait for I/O>>             31660000
          RESET = FLAGS.(15:1)#;    <<Reset LEFTOFF to 0>>              31665000
   DEFINE SET'CCL =BEGIN TOS := -1; DEL; END #;                         31670000
   DEFINE SETS1AFT = TOS:=S1; SETAFT'#;                        <<01817>>31675000
   INTEGER FILENUM = IONUMBER;                                          31680000
   DOUBLE POINTER AFTDBL = AFT;                                         31685000
   EQUATE ENDOFLIST  = %177777;   << stacked info marker >>             31690000
   EQUATE                                                      <<04567>>31695000
      STUB'IOQX = -1;                                          <<04567>>31700000
   INTEGER POINTER PXFILE;        << PXFILE pointer >>                  31705000
   INTEGER LEFTOFF;     << leftoff file/line nr. from PXFILE >>         31710000
   INTEGER NRAFTENTRIES;                                                31715000
   INTEGER IOQX,COMP'IOQINDEX:=0;                              <<02362>>31720000
   LOGICAL ONLYMSGFILE:=TRUE;  <<TRUE IF ONLY WAIT ON MSG FILES  HM.00>>31725000
   EQUATE NO'WAIT'DONE = -1;                                   <<HM.00>>31730000
   EQUATE SOFTINTPEND = -2;                                    <<03038>>31735000
   INTEGER ARRAY IOQINDEX(0:13) = Q;                           <<06511>>31740000
   INTEGER I,NUM'IOQINDICES;                                   <<00613>>31745000
   LOGICAL                                                     <<00613>>31750000
      MULTI'CSIOQS, <<set if CS entry has multiple IOQINDICES>><<00613>>31755000
      OUTSTANDING'IOQ; <<set if AFT entry has outstanding I/O>><<00613>>31760000
                                                                        31765000
   SUBROUTINE SETWAKE'(INDEX);                                 <<HM.00>>31770000
   VALUE INDEX;                                                <<HM.00>>31775000
   INTEGER INDEX;                                              <<HM.00>>31780000
      BEGIN                                                    <<HM.00>>31785000
      IF AFTMSGTYPE THEN                                       <<HM.00>>31790000
         BEGIN                                                 <<HM.00>>31795000
         IF INDEX = NO'WAIT'DONE THEN                          <<HM.00>>31800000
            BEGIN  <<IO COMPLETED AT INITAITION TIME>>         <<HM.00>>31805000
            TOS:=-1; DEL;  <<FORCE CCL STATUS>>                <<HM.00>>31810000
            END                                                <<HM.00>>31815000
         ELSE                                                  <<HM.00>>31820000
            FCPORTENABLE(INDEX);                               <<03038>>31825000
         END                                                   <<HM.00>>31830000
      ELSE IF AFTPORTTYPE THEN                                 <<06959>>31835000
         BEGIN                                                 <<06959>>31840000
         IF INDEX < 0 THEN                                     <<06959>>31845000
            BEGIN  << IO COMPLETED BY SOFT INTERRUPT >>        <<06959>>31850000
            TOS := -1; DEL;  << FORCE CCL >>                   <<06959>>31855000
            END                                                <<06959>>31860000
         ELSE                                                  <<06959>>31865000
            ENABLEIOWAITPORT(INDEX);                           <<06959>>31870000
         END                                                   <<06959>>31875000
      ELSE                                                     <<HM.00>>31880000
         BEGIN                                                 <<HM.00>>31885000
         ONLYMSGFILE:=FALSE;                                   <<HM.00>>31890000
         SETWAKE(INDEX);                                       <<HM.00>>31895000
         END;                                                  <<HM.00>>31900000
      END;  <<SETWAKE'>>                                       <<HM.00>>31905000
   SUBROUTINE CLEARWAKE'(INDEX);                               <<HM.00>>31910000
   VALUE INDEX;                                                <<HM.00>>31915000
   INTEGER INDEX;                                              <<HM.00>>31920000
      BEGIN                                                    <<HM.00>>31925000
      IF AFTMSGTYPE THEN                                       <<HM.00>>31930000
         FCPORTDISABLE(INDEX)                                  <<HM.00>>31935000
      ELSE IF AFTPORTTYPE THEN                                 <<06959>>31940000
         DISABLEIOWAITPORT(INDEX)                              <<06959>>31945000
      ELSE                                                     <<HM.00>>31950000
         CLEARWAKE(INDEX);                                     <<HM.00>>31955000
      END;  <<CLEARWAKE>>                                      <<HM.00>>31960000
$  IF X0 = ON                                                           31965000
   IF MONOTHER THEN                                                     31970000
      BEGIN                                                             31975000
      FTITLE("FIND","WAIT","INGI","O   ");                              31980000
      DEBUG                                                             31985000
      END;                                                              31990000
$  IF                                                                   31995000
                                                                        32000000
   CONDCODE := CCE;      << assume success >>                           32005000
   EXCHANGEDB(0);                                              <<06511>>32010000
   SETPXFILE;            << init. PXFILE pointer >>                     32015000
   NRAFTENTRIES := PXFAFTSIZE/AFTENTRY;                                 32020000
   IF = THEN GO NFG;      << no files opened?? >>                       32025000
   TOS := PXFLEFTOFF;     << last entry to complete I/O >>              32030000
   IF = OR RESET THEN S0 := NRAFTENTRIES;  << reset LEFTOFF?>>          32035000
   LEFTOFF := TOS;        << last entry to consider >>                  32040000
   CLEARWWS;                                                            32045000
                                                                        32050000
   <<* * * Step thru pending I/O's looking for completed one * * *>>    32055000
                                                                        32060000
TRYAGAIN:                                                               32065000
   IONUMBER := LEFTOFF;    << Init. to last completor >>                32070000
   TOS := ENDOFLIST;    << Mark bottom of stacked info. >>              32075000
   DO BEGIN                                                             32080000
      IONUMBER := (IONUMBER MOD NRAFTENTRIES)+1;  << next entry >>      32085000
      SETAFT;     << init. AFT pointer >>                               32090000
      MULTI'CSIOQS := AFTCSTYPE LAND (AFTCSIOQCBV <> 0);       <<00613>>32095000
      OUTSTANDING'IOQ:=                                        <<03038>>32100000
        IF AFTIOQX = SOFTINTPEND AND                           <<06959>>32105000
             (AFTMSGTYPE LOR AFTPORTTYPE)                      <<06959>>32110000
           THEN FALSE                                          <<06959>>32115000
           ELSE (AFTIOQX <> 0) LOR MULTI'CSIOQS;               <<06959>>32120000
      IF AFTDBL <> 0D AND AFTDSKLUDGE AND OUTSTANDING'IOQ THEN <<00613>>32125000
         BEGIN                                                 <<00613>>32130000
         IF MULTI'CSIOQS THEN                                  <<00613>>32135000
            BEGIN     << Multiple CS IOQindices out >>         <<00613>>32140000
            NUM'IOQINDICES :=                                  <<00613>>32145000
               GET'CS'IOQINDICES(AFTCS'MDST,AFTCSIOQCBV,       <<00613>>32150000
                     IOQINDEX);                                <<00613>>32155000
            END                                                <<00613>>32160000
         ELSE                                                  <<00613>>32165000
            BEGIN      << AFT has only one IOQindex >>         <<00613>>32170000
            NUM'IOQINDICES := 1;                               <<00613>>32175000
            IOQINDEX := AFTIOQX;                               <<00613>>32180000
            END;                                               <<00613>>32185000
         I := -1;                                              <<00613>>32190000
         WHILE (I := I+1) < NUM'IOQINDICES DO                  <<00613>>32195000
            BEGIN  <<Step thru all IOQindices for this AFT >>  <<00613>>32200000
            IOQX := IOQINDEX(I);                               <<00613>>32205000
                                                               <<04567>>32210000
            <<**********************************************>> <<04567>>32215000
            << If the IOQX found is a -1, then this is a    >> <<04567>>32220000
            << file system stub.  Set CCL to signify that   >> <<04567>>32225000
            << the I/O has completed and return.            >> <<04567>>32230000
            <<**********************************************>> <<04567>>32235000
                                                               <<04567>>32240000
            IF IOQX < 0 AND AFT3270TYPE OR IOQX = STUB'IOQX    <<04567>>32245000
               THEN SET'CCL                                    <<00613>>32250000
               ELSE SETWAKE'(IOQX);                            <<HM.00>>32255000
            IF < THEN                                          <<00613>>32260000
               BEGIN                                           <<00613>>32265000
                                                               <<00613>>32270000
        << I/O has completed; clear Wake bits. >>              <<00613>>32275000
                                                               <<00613>>32280000
               WHILE S0 <> ENDOFLIST DO                        <<00613>>32285000
                  BEGIN      << cleanup >>                     <<00613>>32290000
                  SETS1AFT;                                    <<01817>>32295000
                  CLEARWAKE'(*);  <<CLEAR WAKE BIT>>           <<HM.00>>32300000
                  DEL     << Delete stacked AFT entry nr. >>   <<00613>>32305000
                  END;                                         <<00613>>32310000
               DEL;                                            <<00613>>32315000
                                                               <<00613>>32320000
            <<* * * Return info on completing I/O * * *>>      <<00613>>32325000
                                                               <<00613>>32330000
               SETAFT;                                         <<01817>>32335000
               AFTIOQX := IOQINDEX(I);   <<completed IOQINDEX>><<00613>>32340000
AOK:           PXFLEFTOFF := IONUMBER;<<new LEFTOFF file/line>><<00613>>32345000
               GO EXIT                                         <<00613>>32350000
               END;                                            <<00613>>32355000
            TOS := IONUMBER;  << stack AFT entry nr. >>        <<00613>>32360000
            TOS := IOQX;                                       <<00613>>32365000
            END      << stepping thru IOQindices >>            <<00613>>32370000
         END                                                            32375000
      END UNTIL IONUMBER = LEFTOFF;                                     32380000
                                                                        32385000
<< * * * Wait for completion if there are pending I/O's * * *>>         32390000
                                                                        32395000
   IF S0 <> ENDOFLIST THEN                                              32400000
      BEGIN      << Some AWAKE bits are set.  >>                        32405000
                                                                        32410000
      <<* * * Cleanup if NOWAIT request * * *>>                         32415000
                                                                        32420000
      IF DONTWAIT THEN                                                  32425000
         BEGIN   << Don't wait for completion. Clear Wake bits >>       32430000
         WHILE S0 <> ENDOFLIST DO                                       32435000
            BEGIN        << cleanup >>                                  32440000
            SETS1AFT;                                          <<01817>>32445000
            CLEARWAKE'(*);  <<CLEAR WAKE BIT>>                 <<HM.00>>32450000
            DEL       << delete AFT entry nr. >>                        32455000
            END;                                                        32460000
                                                                        32465000
         <<* * * Return CCE and IONUMBER=0 * * *>>                      32470000
                                                                        32475000
         IONUMBER := 0;  << indicate no I/O completed >>                32480000
         GO EXIT                                                        32485000
         END;                                                           32490000
                                                                        32495000
   << * * * Wait for any pending I/O completion * * *>>                 32500000
                                                                        32505000
      RESETCRITICAL(0);                                        <<HM.00>>32510000
      WAIT(IF ONLYMSGFILE THEN -4 ELSE -%104,%10001);          <<03038>>32515000
      IF > THEN                                                <<03038>>32520000
         BEGIN  <<SOFT INT OCCURRED>>                          <<03038>>32525000
         SETCRITICAL;                                          <<03038>>32530000
         WHILE S0 <> ENDOFLIST DO  <<BACK OUT OF IOQ REQUESTS>><<03038>>32535000
            BEGIN                                              <<03038>>32540000
            SETS1AFT;                                          <<03038>>32545000
            CLEARWAKE'(*);                                     <<03038>>32550000
            DEL;                                               <<03038>>32555000
            END;                                               <<03038>>32560000
         CONDCODE:=CCG;  <<TELL IOWAIT OF SOFT INT>>           <<03038>>32565000
         GO EXIT;                                              <<03038>>32570000
         END;                                                  <<03038>>32575000
      SETCRITICAL;                                             <<HM.00>>32580000
                                                                        32585000
   << * * * Find out which I/O completed * * *>>                        32590000
                                                                        32595000
      DO BEGIN                                                          32600000
         SETS1AFT;                                             <<01848>>32605000
         IOQX := TOS;                                                   32610000
         CLEARWAKE'(IOQX);  <<CLEAR WAKE BIT>>                 <<HM.00>>32615000
         IF < THEN                                             <<02362>>32620000
            BEGIN                                              <<02362>>32625000
              COMP'IOQINDEX := IOQX;                           <<02362>>32630000
              IONUMBER := TOS;                                 <<02362>>32635000
            END                                                <<02362>>32640000
          ELSE DEL;                                            <<02362>>32645000
      END UNTIL S0 = ENDOFLIST;                                <<02362>>32650000
      DEL;                                                     <<02362>>32655000
                                                                        32660000
         << * * * Return info on completing I/O * * *>>                 32665000
      IF COMP'IOQINDEX <> 0 THEN                               <<02362>>32670000
        BEGIN                                                  <<02362>>32675000
            SETAFT;    << init. AFT entry pointer >>                    32680000
            AFTIOQX := COMP'IOQINDEX;                          <<02362>>32685000
            GO AOK                                                      32690000
        END;                                                   <<02362>>32695000
      COMP'IOQINDEX := 0;                                      <<02362>>32700000
      GO TRYAGAIN  << erroneous awakening? >>                           32705000
      END;                                                              32710000
                                                                        32715000
<< * * * Return error since there was no pending I/O * * *>>            32720000
                                                                        32725000
NFG:                                                                    32730000
   PXFLEFTOFF := 0;  << reset Left-off nr. >>                           32735000
   IONUMBER := 0;    << error file/line nr. >>                          32740000
   CONDCODE := CCL;  << error condition code >>                         32745000
                                                                        32750000
EXIT:                                                                   32755000
   RETURN 1                                                    <<+0.02>>32760000
   END;      << procedure FINDWAITINGIO >>                              32765000
$PAGE " COMMAND INTERPRETER SUPPORT "                                   32770000
$CONTROL SEGMENT = FILESYS1A  << FBREAK >>                              32775000
PROCEDURE FBREAK;                                                       32780000
<< Creates a Break mode request queue for the ACB corresponding to      32785000
   $STDIN/$STDLIST.  This procedure is called by the CI on pseudo-      32790000
   interrupt entry from the terminal driver on Break. >>                32795000
                                                                        32800000
OPTION PRIVILEGED,UNCALLABLE;                                           32805000
   BEGIN                                                                32810000
   INTEGER CRIT;     << for SETCRITICAL >>                              32815000
<< Following LOC'ACB params must be in order: >>                        32820000
   INTEGER ACBMQ;                                              <<06511>>32825000
   INTEGER AFTE;     << AFT entry word 0 >>                             32830000
   DOUBLE  PACBV;                                              <<06511>>32835000
   DOUBLE  LACBV;                                              <<06511>>32840000
   INTEGER IOQX;                                                        32845000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>32850000
   BUILD'ACB;                                                  <<06511>>32855000
   INTEGER DSTX;      << orig. DST nr. >>                               32860000
                                                                        32865000
$  IF X0 = ON                                                           32870000
   IF MONUNCALLABLE THEN                                                32875000
      BEGIN         << monitoring >>                                    32880000
      FTITLE("FBRE","AK  ",0D,0D);                                      32885000
      DEBUG                                                             32890000
      END;                                                              32895000
$  IF                                                                   32900000
                                                                        32905000
   CRIT := SETCRITICAL;                                                 32910000
   GET'ACB'Q'LOC;                                              <<06511>>32915000
   LOC'ACB(*,ACBMQ,1,%100002);     << get ACB for file 1 >>    <<06511>>32920000
$  IF X1 = ON                                                           32925000
   IF <> THEN FTROUBLE(481);    << $NULL or error. >>                   32930000
$  IF                                                                   32935000
   ACB'BREAK := 1;                                             <<06511>>32940000
   IF = THEN ACB'SAVEEOFS := ACB'EOFS;                         <<06511>>32945000
   UNLOC'ACB(ACBMQ,0);      << release ACB >>                  <<06511>>32950000
   RESETCRITICAL(CRIT);                                                 32955000
   END;         << procedure FBREAK >>                                  32960000
$PAGE                                                          <<06511>>32965000
$CONTROL SEGMENT = FILESYS1A  << FUNBREAK >>                            32970000
PROCEDURE FUNBREAK (ABORT);                                             32975000
   << Destroys the Break mode request queue for the ACB corresponding   32980000
  to $STDIN/$STDLIST.  The request is ignored if not in Break mode.     32985000
                                                                        32990000
     Input variables:                                                   32995000
        ABORT - Broken Re-read flag                                     33000000
           FALSE - Redo Broken Read, if any                             33005000
           TRUE - Abort any Broken Read                                 33010000
                                                                        33015000
  This procedure is used by the CI for ABORT, RESUME, etc. >>           33020000
VALUE ABORT;                                                            33025000
LOGICAL ABORT;                                                          33030000
OPTION PRIVILEGED, UNCALLABLE;                                          33035000
   BEGIN                                                                33040000
   INTEGER CRIT;     << for SETCRITICAL >>                              33045000
<< Following LOC'ACB params must be in order: >>                        33050000
   INTEGER ACBMQ;                                              <<06511>>33055000
   INTEGER AFTE;     << AFT entry word 0 >>                             33060000
   DOUBLE  PACBV;                                              <<06511>>33065000
   DOUBLE  LACBV;                                              <<06511>>33070000
   INTEGER IOQX;                                                        33075000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>33080000
   BUILD'ACB;                                                  <<06511>>33085000
   INTEGER DSTX;                                                        33090000
                                                                        33095000
$  IF X0 = ON                                                           33100000
   IF MONUNCALLABLE THEN                                                33105000
      BEGIN        << Monitoring >>                                     33110000
      FTITLE("FUNB","REAK",0D,0D);                                      33115000
      DEBUG                                                             33120000
      END;                                                              33125000
$  IF                                                                   33130000
                                                                        33135000
   CRIT := SETCRITICAL;                                                 33140000
   GET'ACB'Q'LOC;                                              <<06511>>33145000
   LOC'ACB(*,ACBMQ,1,%100000);      << get ACB for file 1 >>   <<06511>>33150000
   IF <> THEN                                                           33155000
      BEGIN       << $NULL or error. >>                                 33160000
      TOS := CCL;                                                       33165000
      GO EXIT                                                           33170000
      END;                                                              33175000
   ACB'BREAK := 0;                                             <<06511>>33180000
   IF <> THEN                                                           33185000
      BEGIN         << Leaving Break mode >>                            33190000
      ACB'EOFS := ACB'SAVEEOFS;                                <<06511>>33195000
      ACB'ABORTREAD := ABORT;  << set Abort Read flag >>       <<06511>>33200000
                                                                        33205000
<< Tell terminal driver to clear its Break DIT flag                     33210000
   so that the next Read begins with any saved data                     33215000
   already read.  >>                                                    33220000
                                                                        33225000
      ATTACHIO(ACB'DADDR,0,0,0,30,0,0,0,BFLAGS);               <<06511>>33230000
      UNLOC'ACB(ACBMQ,4);        << Un-break. >>               <<06511>>33235000
      END                                                               33240000
   ELSE                                                                 33245000
      UNLOC'ACB(ACBMQ,0);        << release ACB >>             <<06511>>33250000
   TOS := CCE;                                                          33255000
EXIT:                                                                   33260000
   CONDCODE := TOS;                                                     33265000
   RESETCRITICAL(CRIT);                                                 33270000
   END;        << procedure FUNBREAK >>                                 33275000
$CONTROL SEGMENT = FILESYS1A  << FRESETEOF >>                           33280000
PROCEDURE FRESETEOF;                                                    33285000
   << Clears the EOF flags in the ACB corresponding to                  33290000
    $STDIN/$STDLIST.  This procedure is used by the CI.  >>             33295000
                                                                        33300000
OPTION PRIVILEGED,UNCALLABLE;                                           33305000
   BEGIN                                                                33310000
   INTEGER CRIT;     << for SETCRITICAL>>                               33315000
<< Following LOC'ACB params must be in order: >>                        33320000
   INTEGER ACBMQ;                                              <<06511>>33325000
   INTEGER AFTE;     << AFT entry word 0 >>                             33330000
   DOUBLE  PACBV;                                              <<06511>>33335000
   DOUBLE  LACBV;                                              <<06511>>33340000
   INTEGER IOQX;                                                        33345000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>33350000
   BUILD'ACB;                                                  <<06511>>33355000
   INTEGER DSTX;                                                        33360000
                                                                        33365000
$  IF X0 = ON                                                           33370000
   IF MONUNCALLABLE THEN                                                33375000
      BEGIN         << Monitoring >>                                    33380000
      FTITLE("FRES","ETEO","F   ",0D);                                  33385000
      DEBUG                                                             33390000
      END;                                                              33395000
$  IF                                                                   33400000
                                                                        33405000
   CRIT := SETCRITICAL;                                                 33410000
   GET'ACB'Q'LOC;                                              <<06511>>33415000
   LOC'ACB(*,ACBMQ,1,%100000);     << get ACB >>               <<06511>>33420000
   IF < THEN FTROUBLE(483)    << error >>                               33425000
      ELSE IF > THEN GO OUT;   << $NULL >>                              33430000
   ACB'EOFS := 0;       << clear "Global" flags >>             <<06511>>33435000
   ACB'EOF := 0;        << clear "local" flags >>              <<06511>>33440000
   UNLOC'ACB(ACBMQ,0);     << release ACB >>                   <<06511>>33445000
OUT:                                                                    33450000
   RESETCRITICAL(CRIT);                                                 33455000
   END;      << procedure FRESETEOF >>                                  33460000
$PAGE                                                          <<06511>>33465000
$ CONTROL SEGMENT = FILESYS3   << FGETDISKADR >>                        33470000
DOUBLE PROCEDURE FGETDISKADR(FILENUM,BLKNUM);                           33475000
   << Converts file number and block number into a logical device       33480000
     number and sector number.                                          33485000
                                                                        33490000
     Input variables:                                                   33495000
         FILENUM - file number                                          33500000
         BLKNUM - block number                                          33505000
                                                                        33510000
     Output variables:                                                  33515000
         FGETDISKADR - logical device number and sector number          33520000
            S-1.(0:8)   Logical device number                           33525000
            S-1.(8:8)   Sector number (most significant part)           33530000
            S-0         Sector number (least significant part)          33535000
                                                                        33540000
     Condition code:                                                    33545000
         CCE - OK                                                       33550000
         CCG - Beyond file limit                                        33555000
         CCL - Illegal file nr., $NULL, or not disk file.               33560000
                                                                        33565000
     This procedure is intended primarily for the Loader.  >>           33570000
                                                                        33575000
VALUE FILENUM,BLKNUM;                                                   33580000
INTEGER FILENUM;                                                        33585000
DOUBLE BLKNUM;                                                          33590000
OPTION PRIVILEGED,UNCALLABLE;                                           33595000
   BEGIN                                                                33600000
   INTEGER CRIT;    << for SETCRITICAL>>                                33605000
<< Following LOC'ACB params must be in order: >>                        33610000
   INTEGER ACBMQ;                                              <<06511>>33615000
   INTEGER AFTE;     << AFT entry word 0 >>                             33620000
   DOUBLE  PACBV;                                              <<06511>>33625000
   DOUBLE  LACBV;                                              <<06511>>33630000
   INTEGER IOQX;                                                        33635000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>33640000
   BUILD'ACB;                                                  <<06511>>33645000
   INTEGER DSTX;                                                        33650000
                                                               <<06511>>33655000
                                                                        33660000
$  IF X0 = ON                                                           33665000
   IF MONUNCALLABLE THEN                                                33670000
      BEGIN                                                             33675000
      FTITLE("FGET","DISK","ADR ",0D);                                  33680000
      DEBUG                                                             33685000
      END;                                                              33690000
$  IF                                                                   33695000
                                                                        33700000
   CRIT := SETCRITICAL;                                                 33705000
   GET'ACB'Q'LOC;                                              <<06511>>33710000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);   << get ACB >>             <<06511>>33715000
   IF <> THEN                                                           33720000
      BEGIN     << Invalid file, or $NULL >>                            33725000
      TOS := CCL;                                                       33730000
      GO EXIT                                                           33735000
      END;                                                              33740000
   IF ACB'FCB = 0D THEN                                        <<06511>>33745000
      BEGIN        << No FCB -- not disk. >>                            33750000
      TOS := CCL;                                                       33755000
      GO ACBERR                                                         33760000
      END;                                                              33765000
   FCONV'BLK(BLKNUM,ACBMQ,1,0,0D,0D,0);                        <<06511>>33770000
   ASSEMBLE(DDEL,DEL);  << remove EXTBASE,EXTSIZE >>           <<04653>>33775000
   ASMB(DDEL,DEL);      << discard EOF, STX >>                          33780000
   IF TOS > 1 THEN                                                      33785000
      TOS := CCG     << Beyond FLIM, or other error >>                  33790000
   ELSE                                                                 33795000
      BEGIN          << OK >>                                           33800000
      BS2 := TOS;       << insert LDEV >>                               33805000
      FGETDISKADR := TOS;  << LDEV and sector nr. >>                    33810000
      TOS := CCE                                                        33815000
      END;                                                              33820000
                                                                        33825000
ACBERR:                                                                 33830000
   UNLOC'ACB(ACBMQ,0);     << release ACB >>                   <<06511>>33835000
                                                                        33840000
EXIT:                                                                   33845000
   CONDCODE := TOS;     << report condition code >>                     33850000
   RESETCRITICAL(CRIT)                                                  33855000
   END;        << procedure FGETDISKADR >>                              33860000
$PAGE                                                          <<06511>>33865000
$ CONTROL SEGMENT = FILESYS3   << FACCESS >>                            33870000
LOGICAL PROCEDURE FACCESS(FILENUM);                                     33875000
   << Returns the access bit list for the specified file.               33880000
                                                                        33885000
     Input variables:                                                   33890000
         FILENUM - file number                                          33895000
                                                                        33900000
     Output variables:                                                  33905000
         FACCESS - access bit list                                      33910000
                                                                        33915000
     Condition code:                                                    33920000
         CCE - OK                                                       33925000
         CCL - Error                                                    33930000
         CCG - File is $NULL                                            33935000
                                                                        33940000
     This procedure is intended primarily for the Loader.   >>          33945000
                                                                        33950000
VALUE FILENUM;                                                          33955000
INTEGER FILENUM;                                                        33960000
OPTION PRIVILEGED,UNCALLABLE;                                           33965000
   BEGIN                                                                33970000
   INTEGER CRIT;     << for SETCRITICAL >>                              33975000
<< Following LOC'ACB params must be in order: >>                        33980000
   INTEGER ACBMQ;                                              <<06511>>33985000
   INTEGER AFTE;     << AFT entry word 0 >>                             33990000
   DOUBLE  PACBV;                                              <<06511>>33995000
   DOUBLE  LACBV;                                              <<06511>>34000000
   INTEGER IOQX;                                                        34005000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>34010000
   BUILD'ACB;                                                           34015000
   INTEGER DSTX;                                                        34020000
                                                                        34025000
$  IF X0 = ON                                                           34030000
   IF MONUNCALLABLE THEN                                                34035000
      BEGIN                                                             34040000
      FTITLE("FACC","ESS ",0D,0D);                                      34045000
      DEBUG                                                             34050000
      END;                                                              34055000
$  IF                                                                   34060000
                                                                        34065000
   CRIT := SETCRITICAL;                                                 34070000
   GET'ACB'Q'LOC;                                              <<06511>>34075000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);   << get ACB >>             <<06511>>34080000
   IF < THEN                                                            34085000
      BEGIN        << Invalid file nr. >>                               34090000
      TOS := CCL;                                                       34095000
      GO EXIT;                                                          34100000
      HELP; << dummy call >>                                   <<00117>>34105000
      END;                                                              34110000
   IF > THEN                                                            34115000
      BEGIN      << file is $NULL >>                                    34120000
      TOS := CCG;                                                       34125000
      GO EXIT                                                           34130000
      END;                                                              34135000
   IF ACB'ACCCL <> DIRACC THEN                                          34140000
      BEGIN       << Not disk. >>                                       34145000
      TOS := CCL;                                                       34150000
      TOS := DEVVIOL;                                                   34155000
      ACB'ERROR := TOS;                                                 34160000
      GO UNLK                                                           34165000
      END;                                                              34170000
   FACCESS := IF LOGICAL(ACB'DOMAIN) THEN ACB'ACCESS ELSE -1;  <<06511>>34175000
   TOS := CCE;     << OK condition code >>                              34180000
                                                                        34185000
UNLK:                                                                   34190000
   UNLOC'ACB(ACBMQ,0);     << release ACB >>                   <<06511>>34195000
                                                                        34200000
EXIT:                                                                   34205000
   CONDCODE := TOS;    << report condition code >>                      34210000
   RESETCRITICAL(CRIT)                                                  34215000
   END;      << procedure FACCESS >>                                    34220000
$PAGE                                                          <<06511>>34225000
$ CONTROL SEGMENT = FILESYS3   << FKSAMBNDVIOL >>                       34230000
PROCEDURE FKSAMBNDVIOL(FILENUM);                               <<KS.00>>34235000
   VALUE FILENUM;                                                       34240000
   INTEGER FILENUM;                                                     34245000
   OPTION PRIVILEGED,UNCALLABLE;                                        34250000
                                                                        34255000
  << This procedure handles KSAM file bounds violations. >>             34260000
   BEGIN                                                                34265000
   INTEGER POINTER AFT;                                                 34270000
   INTEGER USERDB;                                                      34275000
                                                                        34280000
                                                                        34285000
   USERDB := EXCHANGEDB(0);                                             34290000
   SETAFT;                                                              34295000
   AFTFLAG := 3;  << KSAM error >>                                      34300000
   AFTERRNUM := BNDVIOL;                                                34305000
   EXCHANGEDB(USERDB);                                                  34310000
                                                                        34315000
END;                                                                    34320000
$PAGE " COMMAND INTERPRETER SUPPORT - SETLOCKSTATUS "          <<06511>>34325000
PROCEDURE SETLOCKSTATUS(LABELADDR,PURGEOK);                    <<06511>>34330000
VALUE LABELADDR,PURGEOK;                                       <<06511>>34335000
DOUBLE LABELADDR;                                              <<06511>>34340000
LOGICAL PURGEOK;                                               <<06511>>34345000
OPTION UNCALLABLE,PRIVILEGED;                                  <<06511>>34350000
BEGIN                                                          <<06511>>34355000
                                                               <<06511>>34360000
<<**********************************************************>> <<06511>>34365000
<< This procedure is called by the CI to lock or unlock the >> <<06511>>34370000
<< Message Catalog.  If the file is already opened, then it >> <<06511>>34375000
<< sets the bits in the FCB, otherwise it sets the bits in  >> <<06511>>34380000
<< the file label.  It sets the lock bits, which will pre-  >> <<06511>>34385000
<< vent the file from being purged or renamed.              >> <<06511>>34390000
<<                                                          >> <<06511>>34395000
<< Input variables:                                         >> <<06511>>34400000
<<   LABELADDR - Disk address of the file.                  >> <<06511>>34405000
<<   PURGEOK   - TRUE  --> Clear lock state.                >> <<06511>>34410000
<<               FALSE --> Set lock state to 1, read.       >> <<06511>>34415000
<<                                                          >> <<06511>>34420000
<< Condition Code:                                          >> <<06511>>34425000
<<   CCE = Everything OK                                    >> <<06511>>34430000
<<   CCL = Error occured -- lock state unchanged.          >>  <<06511>>34435000
<<**********************************************************>> <<06511>>34440000
                                                               <<06511>>34445000
EQUATE                                                         <<06511>>34450000
   READ  = 0,                                                  <<06511>>34455000
   WRITE = 1;                                                  <<06511>>34460000
INTEGER                                                        <<06511>>34465000
   A,                                                          <<06511>>34470000
   LDEV,                                                       <<06511>>34475000
   FCBMQ,         << Q-relative offset to FCB.              >> <<06511>>34480000
   LABELADDR1 = LABELADDR;                                     <<06511>>34485000
DOUBLE                                                         <<06511>>34490000
   FCB'CB'ADDR,   << DST and offset to FCB in CB.           >> <<06511>>34495000
   FCB'STK'ADDR;  << DST and offset to FCB on stack.        >> <<06511>>34500000
INTEGER POINTER                                                <<06511>>34505000
   FCB;           << Pointer to FCB.                        >> <<06511>>34510000
INTEGER ARRAY                                                  <<06511>>34515000
   FLAB(0:127);                                                <<06511>>34520000
 DOUBLE ARRAY FLABDBL(*)=FLAB;                                 <<06511>>34525000
                                                               <<06511>>34530000
                                                               <<06511>>34535000
<<                    COPY'FCB                              >> <<06511>>34540000
                                                               <<06511>>34545000
SUBROUTINE COPY'FCB;                                           <<06511>>34550000
   BEGIN                                                       <<06511>>34555000
   GET'FCB'Q'LOC;                                              <<06511>>34560000
   LOCK'CB(0,0,FCBMQ,FLFCBVECT);                               <<06511>>34565000
   FCB'CB'ADDR  := DS1;   << Save FCB addresses.            >> <<06511>>34570000
   FCB'STK'ADDR := DS3;                                        <<06511>>34575000
   TOS := SIZEBFCB;       << Copy minumum FCB to stk.       >> <<06511>>34580000
   MOVE'DS'6;             << Copy FCB and pop FLAGS.        >> <<06511>>34585000
   END;                                                        <<06511>>34590000
                                                               <<06511>>34595000
                                                               <<06511>>34600000
SUBROUTINE UPDATE'FCB;                                         <<06511>>34605000
                                                               <<06511>>34610000
   <<****************************************************>>    <<06511>>34615000
   << Updates the actual FCB in the control block with   >>    <<06511>>34620000
   << the altered FCB on the stack and unlocks the FCB.  >>    <<06511>>34625000
   <<****************************************************>>    <<06511>>34630000
                                                               <<06511>>34635000
   BEGIN                                                       <<06511>>34640000
   TOS := FCB'CB'ADDR;  << CB DST and offset of FCB.     >>    <<06511>>34645000
   TOS := FCB'STK'ADDR; << Stack DST and offset of FCB.  >>    <<06511>>34650000
   TOS := SIZEBFCB;     << Now copy minimum FCB back.    >>    <<06511>>34655000
   MOVE'DS'5;                                                  <<06511>>34660000
   UNLOCK'CB(0,FLFCBVECT);                                     <<06511>>34665000
   END;                                                        <<06511>>34670000
                                                               <<06511>>34675000
                                                               <<06511>>34680000
<<                 MAIN BLOCK                               >> <<06511>>34685000
                                                               <<06511>>34690000
CONDCODE := CCE;                                               <<06511>>34695000
LDEV := LABELADDR1.(0:8);                                      <<06511>>34700000
LABELADDR1.(0:8) := 0;     << Clear LDEV from ADDR.         >> <<06511>>34705000
A := GETSIR(FISIR);        << Get the file integrity SIR.   >> <<06511>>34710000
IF FLABIO(LDEV,LABELADDR,READ,FLAB) <> 0 THEN                  <<06511>>34715000
   CONDCODE := CCL                                             <<06511>>34720000
ELSE                                                           <<06511>>34725000
   IF FLFCBVECT = 0D OR ABSOLUTE(CLOADID) <> FLCLID THEN       <<06511>>34730000
      BEGIN  << File is not currenty open, set FLAG bit.    >> <<06511>>34735000
      IF PURGEOK                                               <<06511>>34740000
         THEN FLSTATUS := 0                                    <<06511>>34745000
         ELSE FLSTATUS := 1;                                   <<06511>>34750000
      IF FLABIO(LDEV,LABELADDR,WRITE,FLAB) <> 0 THEN           <<06511>>34755000
         CONDCODE := CCL;                                      <<06511>>34760000
      END                                                      <<06511>>34765000
   ELSE                                                        <<06511>>34770000
                                                               <<06511>>34775000
      <<****************************************************>> <<06511>>34780000
      << The file is currenty opened, set the bits in the   >> <<06511>>34785000
      << FCB.  They will be transfered to the FLAB when     >> <<06511>>34790000
      << the file is FCLOSEd.                               >> <<06511>>34795000
      <<****************************************************>> <<06511>>34800000
                                                               <<06511>>34805000
      BEGIN                                                    <<06511>>34810000
      ALLOC'C'FCB;  << Alloc. min FCB w/o fill extent map.  >> <<06511>>34815000
      COPY'FCB;     << Copy the FCB to stack.               >> <<06511>>34820000
      IF PURGEOK                                               <<06511>>34825000
         THEN FCBLKST := 0                                     <<06511>>34830000
         ELSE FCBLKST := 1;                                    <<06511>>34835000
      UPDATE'FCB;   << Copy altered FCB back.               >> <<06511>>34840000
      END;                                                     <<06511>>34845000
RELSIR(FISIR,A);                                               <<06511>>34850000
END;                                                           <<06511>>34855000
$PAGE " FDELETE "                                                       34860000
$CONTROL SEGMENT = FILESYS3  << FDELETE >>                              34865000
                                                                        34870000
PROCEDURE FDELETE(FILENUM,REC);                                <<00630>>34875000
  VALUE FILENUM,REC;                                                    34880000
  INTEGER FILENUM;                                                      34885000
  DOUBLE REC;                                                           34890000
  OPTION VARIABLE,PRIVILEGED;                                           34895000
BEGIN                                                                   34900000
  COMMENT:                                                              34905000
    Deletes the specified RIO record ("REC").  If "REC" is              34910000
    not specified or negative, deletes the next record                  34915000
    (ACBFPTR).  Note that this differs from the COBOL-74                34920000
    definition which has unnatural side-effects.  Thus,                 34925000
    COBOL-74 should always do a random-access FDELETE!                  34930000
    ;                                                                   34935000
                                                                        34940000
                                                                        34945000
  INTEGER CRIT;                                                         34950000
                                                                        34955000
  LOGICAL                                                               34960000
    PARMMASK= Q-4;                                                      34965000
  DEFINE                                                                34970000
    P'REC=     PARMMASK #;                                              34975000
                                                               <<01864>>34980000
<< Remote File Access (RFA) variables.                      >> <<01864>>34985000
                                                               <<01864>>34990000
INTEGER POINTER                                                <<01864>>34995000
  RFAPTR;           << Message array (appendage) pointer.   >> <<01864>>35000000
                                                               <<01864>>35005000
INTEGER                                                        <<01864>>35010000
  RFALEN;           << Length of appendage.                 >> <<01864>>35015000
                                                                        35020000
<< Following LOC'ACB params must be last and in order: >>               35025000
   INTEGER ACBMQ;                                              <<06511>>35030000
   INTEGER AFTE;       << AFT entry word 0 >>                           35035000
   DOUBLE  PACBV;                                              <<06511>>35040000
   DOUBLE  LACBV;                                              <<06511>>35045000
   INTEGER IOQX;                                                        35050000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>35055000
   BUILD'ACB;                                                           35060000
   LOGICAL DSTX;      << DST nr. of user's buffer >>                    35065000
<< end of LOCACB params >>                                              35070000
                                                                        35075000
                                                                        35080000
$ IF X0=ON                                                              35085000
  IF MONCALLABLE THEN                                                   35090000
    BEGIN                                                               35095000
    FTITLE("FDEL","ETE ",0D,0D);                                        35100000
    DEBUG;                                                              35105000
    END;                                                                35110000
$ IF                                                                    35115000
                                                                        35120000
   ERRORON;                                                             35125000
   CRIT := SETCRITICAL;                                                 35130000
                                                                        35135000
   GET'ACB'Q'LOC;                                              <<06511>>35140000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<01864>>35145000
   IF < THEN                                                            35150000
      BEGIN      << Invalid file number >>                              35155000
      TOS := INVFN;                                                     35160000
      TOS := CCL;                                                       35165000
      GO EXIT;                                                          35170000
      END;                                                              35175000
   IF > THEN                                                            35180000
      BEGIN    << File is $NULL. >>                                     35185000
      TOS := 0;                                                         35190000
      TOS := CCE;                                                       35195000
      GO EXIT;                                                          35200000
      END;                                                              35205000
                                                                        35210000
   CASE * FTYPE OF                                                      35215000
      BEGIN                                                             35220000
   <<0>> BEGIN    << Conventional file >>                               35225000
         IF NOT ACB'RIO OR ACB'INHIBITBUF THEN                          35230000
            BEGIN                                                       35235000
            TOS := ACCVIOL;                                             35240000
            ACB'ERROR := S0;                                            35245000
            TOS := CCL;                                                 35250000
            GO UNLK;                                                    35255000
            END;                                                        35260000
         IF P'REC AND REC >= 0D THEN                                    35265000
            BEGIN        << Random-access Delete >>                     35270000
            ACB'FPTR := REC;                                            35275000
            END;                                                        35280000
                                                                        35285000
         IOMOVE(%40,DUM,0);    << de-activate record >>                 35290000
         TOS := ACB'ERROR;                                              35295000
         TOS := ACBSTATUSCODE;                                          35300000
UNLK:                                                                   35305000
         UNLOC'ACB(ACBMQ,0);                                   <<01864>>35310000
         END; <<0>>                                                     35315000
                                                                        35320000
   <<1>> BEGIN     << remote file >>                                    35325000
         SETRFAPTR;      << Build message array on TOS.     >> <<01864>>35330000
         RFALEN := 7;    << Length of msg array (appendage).>> <<01864>>35335000
         TOS := "RFA ";                                        <<01864>>35340000
         TOS := %63;     << FDELETE DS code = intrinsic nr. >> <<01864>>35345000
         TOS := RFAFILE;  << File number on remote system.  >> <<01864>>35350000
         TOS := REC;      << Record number parameter.       >> <<01864>>35355000
         TOS := PARMMASK; << Option Variable mask.          >> <<01864>>35360000
         MWCNOBUF;      << Stack MANAGEWRITECONVERSATION... >> <<01864>>35365000
                        << ...boilerplate and call it.      >> <<01864>>35370000
         CHECKXFER;    << Check for DS err, not FDELETE err.>> <<01864>>35375000
         DELAPPENDAGE;  << Cut back stack except for status >> <<01864>>35380000
         TOS := TOS.CC; << This is remote FDELETE CC.       >> <<01864>>35385000
         ASSEMBLE(ZERO,XCH);     << Report no FSERR here.   >> <<01864>>35390000
         END; <<1>>                                                     35395000
                                                                        35400000
   <<2>> GOTO BADFTYPE;                                                 35405000
   <<3>> GOTO BADFTYPE;                                                 35410000
   <<4>> GOTO BADFTYPE;                                                 35415000
                                                                        35420000
   <<5>> BEGIN                                                          35425000
BADFTYPE:                                                               35430000
         TOS := SYSTEM;                                                 35435000
         TOS := CCL;                                                    35440000
         END;                                                           35445000
                                                                        35450000
   <<6>> BEGIN    << KSAM file >>                                       35455000
         TOS := ACCVIOL;                                                35460000
         TOS := CCL;                                                    35465000
         END;                                                           35470000
   <<7>> ;                                                     <<HM.00>>35475000
   <<8>> BEGIN  <<MSG FILE>>                                   <<HM.00>>35480000
         TOS:=ACCVIOL;                                         <<HM.00>>35485000
         TOS:=CCL;                                             <<HM.00>>35490000
         UNLOC'ACB(ACBMQ,0);                                   <<01864>>35495000
         END;                                                  <<HM.00>>35500000
      END;      << FTYPE CASE >>                                        35505000
                                                                        35510000
EXIT:                                                                   35515000
   CONDCODE := TOS;                                                     35520000
   RESETCRITICAL(CRIT);                                                 35525000
   ERROREXIT(4,S0,0);                                                   35530000
   END;      << procedure FDELETE >>                                    35535000
$PAGE " FREAD "                                                         35540000
$CONTROL SEGMENT = FILESYS1A  << FREAD >>                               35545000
                                                                        35550000
INTEGER PROCEDURE FREAD(FILENUM,TARGET,TCOUNT);                         35555000
VALUE FILENUM,TCOUNT;                                                   35560000
INTEGER FILENUM,TCOUNT;                                                 35565000
ARRAY TARGET;                                                           35570000
OPTION PRIVILEGED;                                                      35575000
   BEGIN                                                                35580000
                                                                        35585000
   ENTRY FREADX;    << secondary entry point for READX >>               35590000
   ENTRY FREADBACKWARD;                                                 35595000
                                                                        35600000
   EQUATE UBND = -8; <<Q rel upper bound for bounds check>>    <<03059>>35605000
   EQUATE INITIATE   = 0;                                      <<03038>>35610000
   LOGICAL READX,READBK;                                                35615000
   INTEGER CRIT;       << for SETCRITICAL >>                            35620000
                                                                        35625000
   << Remote file access (RFA) variables >>                             35630000
                                                                        35635000
   INTEGER POINTER RFAPTR;     << appendage pointer >>                  35640000
   INTEGER RFALEN;             << appendage length >>                   35645000
   LOGICAL LOCAL'FAILURE := 0;                                          35650000
                                                                        35655000
 << Following LOC'ACB params must be last and in order: >>              35660000
   INTEGER ACBMQ;                                              <<06511>>35665000
   INTEGER AFTE;                                                        35670000
   DOUBLE  PACBV;                                              <<06511>>35675000
   DOUBLE  LACBV;                                              <<06511>>35680000
   INTEGER IOQX;                                                        35685000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>35690000
   BUILD'ACB;                                                           35695000
                                                                        35700000
   INTEGER DSTX;      << user buffer data seg >>                        35705000
   << end of LOC'ACB params >>                                          35710000
                                                                        35715000
SUBROUTINE ATTIO(FUNC);                                        <<02054>>35720000
VALUE FUNC; INTEGER FUNC;                                               35725000
   << Shortcut to call ATTACHIO. >>                                     35730000
                                                                        35735000
   BEGIN                                                                35740000
   TOS := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,0,4,BFLAGS);                  35745000
   ASMB(DEL,DUP);                                                       35750000
   IF TOS.(8:8) <> 1 THEN                                               35755000
      BEGIN         << ATTACHIO reports error. >>                       35760000
      ASMB(ZERO,XCH);    << for result of IOSTAT >>                     35765000
      TOS := IOSTAT(*);                                                 35770000
      ASMB(TEST);                                              <<02693>>35775000
      IF <> AND S0 <> EOT AND S0 <> TAPERREC THEN GO NFG;      <<02712>>35780000
      DEL;                                                              35785000
      END                                                      <<02072>>35790000
   ELSE DEL;                                                   <<02073>>35795000
   END;            << subroutine ATTIO >>                      <<02072>>35800000
                                                                        35805000
   IF (READBK := FALSE) THEN                                            35810000
      BEGIN                                                             35815000
FREADBACKWARD:                                                          35820000
      READBK := TRUE;                                                   35825000
      END;                                                              35830000
   IF (READX := FALSE) THEN                                             35835000
      BEGIN                                                             35840000
FREADX:                                                                 35845000
      READBK := FALSE;                                                  35850000
      READX := TRUE;                                                    35855000
      END;                                                              35860000
                                                                        35865000
$  IF X0 = ON                                                           35870000
   IF MONCALLABLE THEN                                                  35875000
      BEGIN          << monitoring >>                                   35880000
      FTITLE("FREA","D   ",0D,0D);                                      35885000
      DEBUG                                                             35890000
      END;                                                              35895000
$  IF                                                                   35900000
                                                                        35905000
   ERRORON;                                                             35910000
   CRIT := SETCRITICAL;                                                 35915000
   IF READX THEN                                                        35920000
      BEGIN                                                             35925000
      IF NOT (PRIVMODE) THEN                                            35930000
         BEGIN                                                          35935000
         TOS := ILLCAP;                                                 35940000
         TOS := CCL;                                                    35945000
         GO EXIT;                                                       35950000
         END;                                                           35955000
      IF FILENUM <> 1 THEN                                              35960000
         BEGIN                                                          35965000
         TOS := INVFN;                                                  35970000
         TOS := CCL;                                                    35975000
         GO EXIT;                                                       35980000
         END;                                                           35985000
      END;                                                              35990000
   GET'ACB'Q'LOC;                                              <<06511>>35995000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<06511>>36000000
   IF < THEN                                                            36005000
      BEGIN     << invalid file nr. >>                                  36010000
      TOS := INVFN;                                                     36015000
      TOS := CCL;                                                       36020000
      GO EXIT                                                           36025000
      END;                                                              36030000
   IF > THEN                                                            36035000
      BEGIN     << $NULL >>                                             36040000
      TOS := 0;     << No error. >>                                     36045000
      TOS := CCG;   << Report EOF >>                                    36050000
      GO EXIT                                                           36055000
      END;                                                              36060000
                                                                        36065000
      <<* * * OK. Do FREAD  * * * >>                                    36070000
                                                                        36075000
   CASE * FTYPE OF                                                      36080000
      BEGIN                                                             36085000
                                                                        36090000
      BEGIN      << conventional file >>                                36095000
      IF IOQX <> 0 THEN                                                 36100000
         BEGIN    << No-wait I/O pending >>                             36105000
         TOS := IOPENDING;                                              36110000
         GO NFG                                                         36115000
         END;                                                           36120000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>36125000
         BEGIN                                                          36130000
         TOS := BNDVIOL;                                                36135000
         GO NFG                                                         36140000
         END;                                                           36145000
      IF (1 <= ACB'ACTYPE <= 3) THEN                                    36150000
         BEGIN      << Error: doesn't have READ access. >>              36155000
ACV:     TOS := ACCVIOL;                                                36160000
NFG:     ACB'ERROR := S0;                                               36165000
         TOS := CCL;                                                    36170000
         GO UNLK;                                                       36175000
         END;                                                           36180000
      IF READBK THEN                                                    36185000
         BEGIN     << FREADBACKWARD request >>                          36190000
         IF NOT ACB'INHIBITBUF THEN GO ACV;                             36195000
         IF ACB'DTYPE <> MTAPE THEN                            <<02037>>36200000
            BEGIN        << Not tape; bitch. >>                         36205000
            TOS := DEVVIOL;                                             36210000
            GO NFG                                                      36215000
            END;                                                        36220000
         ACB'FPTR := ACB'FPTR-DOUBLE(ACB'BLKFACT);                      36225000
         IF ACB'NEWEOF THEN                                    <<02054>>36230000
            BEGIN      << Write tapemark for high water. >>    <<02054>>36235000
            ATTIO(6);                                          <<02054>>36240000
            ATTIO(8);      << backspace over it >>             <<02054>>36245000
            ACB'NEWEOF := 0;                                   <<02054>>36250000
            END;                                               <<02054>>36255000
         END;                                                           36260000
      TOS := ACB'READCODE;    << EOF check type (12:2) & mode (14:2) >> 36265000
      ASMB(DUP,DUP);                                                    36270000
      IF TOS.(12:2) <> 0 THEN  << readtype >>                           36275000
         BEGIN                << job or session >>                      36280000
         ASMB(TBC 14);   << read mode >>                                36285000
         IF = THEN                                                      36290000
            BEGIN            << Non-CI. >>                              36295000
            IF READX THEN TOS := TOS LOR STDINXRD;  << 1 >>             36300000
            ASMB(DELB,DUP);                                             36305000
            ASMB(DUP,INCA);                                             36310000
            IF (TOS LAND ACB'EOFS) <> 0 THEN                            36315000
               BEGIN     << Unpassable EOF. >>                          36320000
               DDEL;                                                    36325000
               ACB'EOF := 1;                                            36330000
               ACB'STATUS := EOFCODE;                                   36335000
               ACB'ERROR := EOF;                                        36340000
               ACB'TLOG := 0;                                           36345000
               GO LEOF;                                                 36350000
               END;                                                     36355000
            TOS.(11:1) := 1;  << flag non-CI job/session >>             36360000
            ASMB(XCH);                                                  36365000
            END;                                                        36370000
         ASMB(TRBC 12);                                                 36375000
         IF <> THEN TOS := TOS LOR 1;   << session >>                   36380000
         ASMB(TBC 13);                                                  36385000
         IF <> THEN TOS := TOS LAND 4;   << job >>                      36390000
         END;                                                           36395000
      TOS := TOS&LSL(8);     << EOF spec. code >>                       36400000
      ACB'CTL := TOS LOR TOS;                                           36405000
                                                                        36410000
   << Skip over any unread user header tape labels >>                   36415000
      IF LABEL'DEVICE THEN                                     <<03582>>36420000
         BEGIN                                                 <<02545>>36425000
         TOS := CHECKUL(FILENUM,0,0);                          <<02545>>36430000
         IF < THEN GO NFG;    << error >>                      <<02545>>36435000
         DEL;                                                  <<02545>>36440000
         END;                                                  <<02545>>36445000
      IF ACB'ACCCL = SERIALIO AND ACB'NEWEOF THEN              <<04591>>36450000
         BEGIN  << Can't read directly after a serial write.>> <<04591>>36455000
         ACB'ERROR := INVOP;                                   <<04591>>36460000
         TOS := ACB'ERROR;                                     <<04591>>36465000
         TOS := CCL;                                           <<04591>>36470000
         GO UNLK;                                              <<04591>>36475000
         END;                                                  <<04591>>36480000
                                                               <<06050>>36485000
      <<****************************************************>> <<06050>>36490000
      << Clear ACB'EOF bit for serial I/O so that we contin->> <<06050>>36495000
      << ue to do pre-reads, otherwise not done when ACB'EOF>> <<06050>>36500000
      << is set.  This would hurt STORE/RESTORE performance.>> <<06050>>36505000
      <<****************************************************>> <<06050>>36510000
                                                               <<06050>>36515000
      IF ACB'ACCCL = SERIALIO AND NOT ACB'INHIBITBUF           <<06258>>36520000
         THEN ACB'EOF := 0;                                    <<06050>>36525000
                                                               <<06050>>36530000
      TOS := IF ACB'NOWAIT THEN %30 ELSE %20;                           36535000
      IF READBK THEN TOS := TOS+6;                                      36540000
      IOMOVE(*,TARGET,TCOUNT);                                          36545000
      IF READBK THEN ACB'FPTR := ACB'FPTR-DOUBLE(ACB'BLKFACT);          36550000
                                                                        36555000
LEOF:                                                                   36560000
      FREAD := \ACB'TLOG\;                                              36565000
      IF ACB'GSTATUS = 1 THEN                                           36570000
         BEGIN             << Successful I/O. >>                        36575000
         TOS := IF ACB'ERROR = EOL                             <<02068>>36580000
            THEN CCL ELSE CCE;                                          36585000
                                                                        36590000
         <<* * * Measurement data on FREAD * * *>>                      36595000
                                                                        36600000
$        IF X3 = ON                                                     36605000
         IF MEAS'TAPE'ON THEN BEGIN                                     36610000
         IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                 36615000
            MMSTAT'(EFREAD,FILENUM,ACB'TLOG,ACB'HIT,0,0,0);    <<06958>>36620000
         END;       << of MEAS'TAPE'ON >>                               36625000
$        IF                                                             36630000
                                                                        36635000
         END     << successful I/O >>                                   36640000
      ELSE                                                              36645000
         BEGIN      << I/O error. >>                                    36650000
         IF ACB'ERROR = BOT THEN SET'LPDT'BOT(ACB'DADDR,1);    <<02545>>36655000
         TOS := ACBSTATUSCODE;  << condition code to return >>          36660000
         END;                                                           36665000
      TOS := ACB'ERROR;                                                 36670000
      ASMB(XCH);     << swap error nr. and cond. code >>                36675000
UNLK: UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<06511>>36680000
      END;      << conventional file >>                                 36685000
                                                                        36690000
      BEGIN    << Remote file >>                               <<DS.00>>36695000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>36700000
         LOCAL'FAILURE := BNDVIOL;                             <<DS.04>>36705000
      SETRFAPTR;                                               <<DS.00>>36710000
      RFALEN := 5;                                             <<DS.00>>36715000
      TOS := "RFA ";                                           <<DS.00>>36720000
      IF RFAMREC THEN TOS := 24 ELSE TOS := 3;                 <<DS.03>>36725000
      LOAD'ERROR;                                              <<DS.04>>36730000
      TOS := RFAFILE;                                          <<DS.00>>36735000
      TOS := TCOUNT;                                           <<DS.00>>36740000
      GETMWCPARMS;                                             <<DS.00>>36745000
      TOS := 0D;                                               <<DS.00>>36750000
      TOS := @TARGET;                                          <<DS.00>>36755000
      TOS := TCOUNT;                                           <<DS.00>>36760000
      TOS := MWCPLABEL;                                        <<DS.00>>36765000
      ASMB(PCAL 0);                                            <<DS.00>>36770000
      FREAD := TOS;                                                     36775000
      CHECKXFER;                                               <<DS.00>>36780000
      DELAPPENDAGE;                                            <<DS.00>>36785000
      PREPRETURN;                                              <<DS.00>>36790000
      GO EXIT;                                                 <<DS.00>>36795000
      END;      << remote file >>                                       36800000
         << dummy for 2 >>;                                             36805000
         << dummy for 3 >>;                                             36810000
         << dummy for 4 >>;                                             36815000
         << dummy for 5 >>;                                             36820000
      BEGIN        << KSAM file >>                                      36825000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>36830000
         BEGIN                                                          36835000
         FKSAMBNDVIOL(FILENUM);                                         36840000
         TOS := BNDVIOL;                                                36845000
         TOS := CCL;                                                    36850000
         GO EXIT;                                                       36855000
         END;                                                           36860000
      TOS := KREAD(FILENUM,TARGET,TCOUNT);                     <<KS.00>>36865000
      FREAD := TOS;                                                     36870000
      PUSH(STATUS);                                            <<KS.00>>36875000
      TOS := TOS.CC;     << report condition code >>           <<KS.00>>36880000
      ASMB(ZERO,XCH);                                          <<KS.00>>36885000
      END;        << KSAM file >>                              <<KS.00>>36890000
                                                                        36895000
      <<DUMMY FOR 7>>;                                         <<HM.00>>36900000
      BEGIN  <<MESSAGE FILE>>                                  <<HM.00>>36905000
      IF IOQX <> 0 THEN                                        <<HM.00>>36910000
         BEGIN    << No-wait I/O pending >>                    <<HM.00>>36915000
         TOS := IOPENDING;                                     <<HM.00>>36920000
         GO NFG                                                <<HM.00>>36925000
         END;                                                  <<HM.00>>36930000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>36935000
         BEGIN                                                 <<HM.00>>36940000
         TOS := BNDVIOL;                                       <<HM.00>>36945000
         GO NFG                                                <<HM.00>>36950000
         END;                                                  <<HM.00>>36955000
      IF NOT ACB'READ THEN                                     <<06511>>36960000
         BEGIN                                                 <<HM.00>>36965000
         TOS:=ACCVIOL;                                         <<HM.00>>36970000
         GO NFG;                                               <<HM.00>>36975000
         END;                                                  <<HM.00>>36980000
      FCREAD(INITIATE,TARGET,TCOUNT);                          <<03038>>36985000
      FREAD:=ACB'TLOG;                                         <<HM.00>>36990000
      UNLOC'ACB(ACBMQ,0);                                      <<06511>>36995000
      IF S0 <> 0 THEN FCAWAKEN(*) ELSE DEL;                    <<03038>>37000000
      TOS:=ACB'ERROR;                                          <<HM.00>>37005000
      ASMB(XCH);                                               <<HM.00>>37010000
      END;                                                     <<HM.00>>37015000
      END;       << FTYPE case >>                                       37020000
                                                                        37025000
EXIT:                                                                   37030000
   CONDCODE := TOS;          << report condition code >>                37035000
   RESETCRITICAL(CRIT);                                                 37040000
   ERROREXIT(3,S0,0)                                                    37045000
   END;       << procedure FREAD >>                                     37050000
$PAGE " FWRITE "                                                        37055000
$CONTROL SEGMENT = FILESYS1A  << FWRITE >>                              37060000
                                                                        37065000
PROCEDURE FWRITE(FILENUM,TARGET,TCOUNT,CONTROL);                        37070000
VALUE FILENUM,TCOUNT,CONTROL;                                           37075000
INTEGER FILENUM,TCOUNT;                                                 37080000
LOGICAL CONTROL;                                                        37085000
ARRAY TARGET;                                                           37090000
OPTION PRIVILEGED;                                                      37095000
   BEGIN                                                                37100000
   EQUATE UBND = -8; <<Q rel upper bound for bounds check>>    <<03059>>37105000
   EQUATE INITIATE   = 0;                                      <<03038>>37110000
   EQUATE                  << CCTL to open SDISC            >> <<03731>>37115000
      SETCONTIG = %1001;   <<   contiguous block.           >> <<03731>>37120000
                                                                        37125000
   << Remote file access (RFA) variables >>                             37130000
                                                                        37135000
   INTEGER POINTER RFAPTR;    << appendage pointer >>          <<DS.00>>37140000
   INTEGER RFALEN;            << appendage length >>           <<DS.00>>37145000
   LOGICAL LOCAL'FAILURE := 0;                                 <<DS.04>>37150000
                                                                        37155000
   INTEGER CRIT;         << for SETCRITICAL >>                          37160000
<< Following LOC'ACB params must be last and in order: >>               37165000
   INTEGER ACBMQ;                                              <<04591>>37170000
   INTEGER AFTE;                                                        37175000
   DOUBLE  PACBV;                                              <<06511>>37180000
   DOUBLE  LACBV;                                              <<06511>>37185000
   INTEGER IOQX;                                                        37190000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+9 >>                    37195000
   BUILD'ACB;                                                           37200000
                                                                        37205000
   INTEGER DSTX;       << user's buffer DST >>                          37210000
   << End of LOC'ACB params >>                                          37215000
                                                               <<HM.00>>37220000
   SUBROUTINE FORMCARRCONTROL;                                 <<HM.00>>37225000
<< This subroutine processes carriage control characters. >>            37230000
                                                                        37235000
      BEGIN                                                    <<HM.00>>37240000
      IF ACB'CONTROL THEN                                      <<HM.00>>37245000
         BEGIN       << File has carriage control. >>          <<HM.00>>37250000
         IF CONTROL = 1 THEN                                   <<HM.00>>37255000
            BEGIN      << Car control already in line. >>      <<HM.00>>37260000
            IF TCOUNT = 0 THEN                                 <<HM.00>>37265000
               BEGIN   << Woops! Must have car control, at least HM.00>>37270000
               TOS := BADCONTROL;                              <<HM.00>>37275000
               GO NFG                                          <<HM.00>>37280000
               END;                                            <<HM.00>>37285000
            X := TARGET(0).(0:8) << get col 1. line/page control HM.00>>37290000
            END                                                <<HM.00>>37295000
         ELSE                                                  <<HM.00>>37300000
            BEGIN      << separate control >>                  <<HM.00>>37305000
            X := CONTROL;                                      <<HM.00>>37310000
            IF (%400 <= X <= %403) THEN                        <<HM.00>>37315000
               CONTROL := X := X-%300;    << re-map control >> <<HM.00>>37320000
            END;     << separate control >>                    <<HM.00>>37325000
         IF (%100 <= X <= %103) THEN                           <<HM.00>>37330000
            BEGIN     << Set ACB line & page controls. >>      <<HM.00>>37335000
            IF (%100 <= X <= %101) THEN                        <<HM.00>>37340000
               ACB'LINECTL := X         << new line control >> <<01720>>37345000
            ELSE IF (%102 <= X <= %103) THEN                   <<HM.00>>37350000
               ACB'PAGECTL := X;         << new page control >><<01720>>37355000
            IF TCOUNT=0 OR (TCOUNT=-1 LAND CONTROL=1 LAND      <<07189>>37360000
               (ACB'DTYPE=TERMINAL LOR ACB'DTYPE=LPTR)) THEN   <<07189>>37365000
               BEGIN          << Control only - no text. >>    <<HM.00>>37370000
               TOS: = 0;      << Take quick exit. >>           <<HM.00>>37375000
               TOS := CCE;                                     <<HM.00>>37380000
               GO UNLK;                                        <<HM.00>>37385000
               END;    << control only  >>                     <<HM.00>>37390000
            END;     << set ACB line & page controls >>        <<HM.00>>37395000
         ACB'CTL := CONTROL                                    <<HM.00>>37400000
         END       << file has carriage control >>             <<HM.00>>37405000
      ELSE         << Carriage control not allowed; ignore >>  <<HM.00>>37410000
         ACB'CTL := 0;                                         <<HM.00>>37415000
      END  <<FORMCARRCONTROL>>;                                <<HM.00>>37420000
                                                                        37425000
$  IF X0 = ON                                                           37430000
   IF MONCALLABLE THEN                                                  37435000
      BEGIN          << monitoring >>                                   37440000
      FTITLE("FWRI","TE  ",0D,0D);                                      37445000
      DEBUG                                                             37450000
      END;                                                              37455000
$  IF                                                                   37460000
                                                                        37465000
   ERRORON;                                                             37470000
   CRIT := SETCRITICAL;                                                 37475000
   GET'ACB'Q'LOC;                                              <<04591>>37480000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<04591>>37485000
   IF < THEN                                                            37490000
      BEGIN          << invalid file nr. >>                             37495000
      TOS := INVFN;                                                     37500000
      TOS := CCL;                                                       37505000
      GO EXIT                                                           37510000
      END;                                                              37515000
   IF > THEN                                                            37520000
      BEGIN           << $NULL is a bit bucket. >>                      37525000
      TOS := 0;       << No error. >>                                   37530000
      TOS := CCE;                                                       37535000
      GO EXIT                                                           37540000
      END;                                                              37545000
                                                                        37550000
      <<* * * OK. Do WRITE  * * *>>                                     37555000
                                                                        37560000
   CASE * FTYPE OF                                                      37565000
      BEGIN                                                             37570000
                                                                        37575000
      BEGIN         << conventional file >>                             37580000
      IF IOQX <> 0 THEN                                                 37585000
         BEGIN           << No-wait I/O pending >>                      37590000
         TOS := IOPENDING;                                              37595000
         GO NFG                                                         37600000
         END;                                                           37605000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>37610000
         BEGIN                                                          37615000
         TOS := BNDVIOL;                                                37620000
         GO NFG                                                         37625000
         END;                                                           37630000
      TOS := ACB'ACTYPE;     << access type >>                          37635000
      IF = THEN                                                         37640000
         BEGIN       << Read only. >>                                   37645000
         TOS := ACCVIOL;                                                37650000
NFG:     ACB'ERROR := S0;                                               37655000
         TOS := CCL;                                                    37660000
         GO UNLK;                                                       37665000
         END;                                                           37670000
      IF TOS=3 AND ACB'ACCCL=DIRACC AND NOT ACB'CIRFILE        <<06511>>37675000
          AND ACB'DTYPE <> FDISC THEN                          <<01115>>37680000
         ACB'FPTR := GETFCB'INFO(ACB'FCB,XEOF);  << APPEND mode >>      37685000
      FORMCARRCONTROL;  <<GET THE USER'S CARR CONTROL>>        <<HM.00>>37690000
      IF LABEL'DEVICE THEN                                     <<03582>>37695000
         BEGIN                                                 <<02545>>37700000
         TOS := CHECKUL(FILENUM,1,ACB'NEWEOF);                 <<02545>>37705000
         IF < THEN GO NFG;   << error >>                       <<02545>>37710000
         DEL;                                                  <<02545>>37715000
         END;                                                  <<02545>>37720000
      IF ACB'DTYPE = SDISC AND CONTROL >= SETCONTIG AND        <<03753>>37725000
         NOT (PRIVMODE) THEN                                   <<03753>>37730000
            BEGIN            << Special SDISC control codes >> <<03731>>37735000
            TOS := ILLCAP;   << not allowed in user mode.   >> <<03731>>37740000
            GO NFG;                                            <<03731>>37745000
            END;                                               <<03731>>37750000
                                                               <<04591>>37755000
      <<****************************************************>> <<04591>>37760000
      << If the last operation to a serialio device was a   >> <<04591>>37765000
      << read, then obtain the number of pre-reads from     >> <<04591>>37770000
      << FQUIESC'IO so that we may back space over them be- >> <<04591>>37775000
      << fore performing the write.                         >> <<04591>>37780000
      <<****************************************************>> <<04591>>37785000
                                                               <<04591>>37790000
      IF ACB'ACCCL = SERIALIO AND NOT ACB'INHIBITBUF AND       <<04591>>37795000
         NOT ACB'NEWEOF THEN                                   <<04591>>37800000
         BEGIN                                                 <<04591>>37805000
         TOS := FQUIESCE'IO(FALSE); << TOS MUST MUST be used>> <<04591>>37810000
         ACB'TAPEDISP := TOS; << so the ACB is at Q-62!!!!! >> <<04591>>37815000
         END;                                                  <<04591>>37820000
      IF TCOUNT <> 0 THEN                                      <<04981>>37825000
         ACB'NEWEOF := 1; << Set bit if a non-zero write.   >> <<04981>>37830000
                                                               <<04159>>37835000
      TOS := IF ACB'DTYPE=SDISC THEN CONTROL LOR 1 ELSE                 37840000
           IF ACB'NOWAIT THEN %31 ELSE %21;                    <<04590>>37845000
      IOMOVE(*,TARGET,TCOUNT);                                          37850000
      IF ACB'ERROR = EOT THEN                                           37855000
         BEGIN           << End of tape >>                              37860000
         IF ACB'DTYPE = PTPNCH THEN                                     37865000
            BEGIN      << Paper tape punch. Do trailer >>               37870000
            TOS := ATTACHIO(ACB'DADDR,0,0,0,5,0,0,0,BFLAGS);            37875000
            DEL;          << discard TLOG >>                            37880000
            ACB'STATUS := TOS;                                          37885000
            IF ACB'GSTATUS <> 1 THEN                                    37890000
               BEGIN             << Error. >>                           37895000
               TOS := CCL;                                              37900000
               TOS := IOSTAT(ACB'STATUS)  << convert error nr. >>       37905000
               END                                                      37910000
            ELSE                                                        37915000
               BEGIN              << OK. >>                             37920000
               TOS := CCE;                                              37925000
               TOS := 0           << Clear error >>                     37930000
               END;                                                     37935000
            ACB'ERROR := TOS                                            37940000
            END      << paper tape punch >>                             37945000
         ELSE       << Magnetic tape >>                                 37950000
         TOS := CCL;                                           <<02545>>37955000
         END         << end of tape >>                                  37960000
      ELSE                                                              37965000
         TOS := ACBSTATUSCODE;  << report CC per status >>              37970000
                                                                        37975000
      <<* * * Measurement data on FWRITE * * *>>                        37980000
                                                                        37985000
$     IF X3 = ON                                                        37990000
      IF MEAS'TAPE'ON THEN BEGIN                                        37995000
      IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                    38000000
         MMSTAT'(EFWRITE,FILENUM,TCOUNT,ACB'HIT,0,0,0);        <<06958>>38005000
      END;     << of MEAS'TAPE'ON>>                                     38010000
$     IF                                                                38015000
                                                                        38020000
      TOS := ACB'ERROR;                                                 38025000
      ASMB(XCH);       << swap error nr. and cond. code >>              38030000
UNLK: UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<04591>>38035000
      END;        << conventional file >>                               38040000
                                                                        38045000
      BEGIN      << Remote file >>                                      38050000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>38055000
         BEGIN                                                 <<DS.04>>38060000
         LOCAL'FAILURE := BNDVIOL;                             <<DS.04>>38065000
         TCOUNT := 0;                                          <<DS.06>>38070000
         END;                                                  <<DS.04>>38075000
      SETRFAPTR;                                               <<DS.00>>38080000
      RFALEN := 6;                                             <<DS.00>>38085000
      TOS := "RFA ";                                           <<DS.00>>38090000
      IF RFAMREC THEN TOS := 26 ELSE TOS := 6;                 <<DS.03>>38095000
      LOAD'ERROR;                                              <<DS.04>>38100000
      TOS := RFAFILE;                                          <<DS.00>>38105000
      TOS := TCOUNT;                                           <<DS.00>>38110000
      TOS := CONTROL;                                          <<DS.00>>38115000
      GETMWCPARMS;                                             <<DS.00>>38120000
      IF RFAMREC THEN TOS := 0D ELSE                           <<DS.03>>38125000
         BEGIN                                                 <<DS.03>>38130000
         TOS := @TARGET;                                       <<DS.03>>38135000
         TOS := TCOUNT;                                        <<DS.03>>38140000
         END;                                                  <<DS.03>>38145000
      TOS := 0D;                                               <<DS.00>>38150000
      TOS := MWCPLABEL;                                        <<DS.00>>38155000
      ASMB(PCAL 0);                                            <<DS.00>>38160000
      DEL;                                                     <<DS.00>>38165000
      CHECKXFER;                                               <<DS.00>>38170000
      IF RFAMREC AND LOCAL'FAILURE = 0 THEN                    <<DS.04>>38175000
         BEGIN                                                 <<DS.03>>38180000
         RFALEN := 0;                                          <<DS.03>>38185000
         GETMWCPARMS;                                          <<DS.03>>38190000
         TOS := @TARGET;                                       <<DS.03>>38195000
         TOS := TCOUNT;                                        <<DS.03>>38200000
         TOS := 0D;                                            <<DS.03>>38205000
         TOS := MWCPLABEL;                                     <<DS.03>>38210000
         ASMB(PCAL 0);     << Send data across >>              <<DS.03>>38215000
         DEL;                                                  <<DS.03>>38220000
         CHECKXFER;                                            <<DS.03>>38225000
         RFALEN := 6;                                          <<DS.03>>38230000
         END;                                                  <<DS.03>>38235000
      DELAPPENDAGE;                                            <<DS.00>>38240000
      PREPRETURN;                                              <<DS.00>>38245000
      GO EXIT;                                                          38250000
      END;     << remote file >>                                        38255000
                                                                        38260000
            << dummy for 2 >>;                                          38265000
            << dummy for 3 >>;                                          38270000
            << dummy for 4 >>;                                          38275000
            << dummy for 5 >>;                                          38280000
      BEGIN       << KSAM file >>                                       38285000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>38290000
         BEGIN                                                          38295000
         FKSAMBNDVIOL(FILENUM);                                <<KS.00>>38300000
         TOS := BNDVIOL;                                                38305000
         TOS := CCL;                                                    38310000
         GO EXIT;                                                       38315000
         END;                                                           38320000
      KWRITE(FILENUM,TARGET,TCOUNT);                           <<KS.00>>38325000
      PUSH(STATUS);                                            <<KS.00>>38330000
      TOS := TOS.CC;                                           <<KS.00>>38335000
      ASMB(ZERO,XCH);                                          <<KS.00>>38340000
      END;      << KSAM file >>                                <<KS.00>>38345000
      <<DUMMY FOR 7>>;                                         <<HM.00>>38350000
      BEGIN  <<MESSAGE FILE>>                                  <<HM.00>>38355000
      IF IOQX <> 0 THEN                                        <<HM.00>>38360000
         BEGIN           << No-wait I/O pending >>             <<HM.00>>38365000
         TOS := IOPENDING;                                     <<HM.00>>38370000
         GO NFG                                                <<HM.00>>38375000
         END;                                                  <<HM.00>>38380000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>38385000
         BEGIN                                                 <<HM.00>>38390000
         TOS := BNDVIOL;                                       <<HM.00>>38395000
         GO NFG                                                <<HM.00>>38400000
         END;                                                  <<HM.00>>38405000
      IF NOT (1 <= ACB'ACTYPE <= 3) THEN                       <<06511>>38410000
         BEGIN                                                 <<HM.00>>38415000
         TOS:=ACCVIOL;                                         <<HM.00>>38420000
         GO NFG;                                               <<HM.00>>38425000
         END;                                                  <<HM.00>>38430000
      FORMCARRCONTROL;                                         <<HM.00>>38435000
      FCWRITE(INITIATE,TARGET,TCOUNT);                         <<03038>>38440000
      UNLOC'ACB(ACBMQ,0);                                      <<04591>>38445000
      IF S0 <> 0 THEN FCAWAKEN(*) ELSE DEL;                    <<03038>>38450000
      TOS:=ACB'ERROR;                                          <<HM.00>>38455000
      ASMB(XCH);                                               <<HM.00>>38460000
      END;                                                     <<HM.00>>38465000
      END;         << FTYPE case >>                                     38470000
                                                                        38475000
EXIT:                                                                   38480000
   CONDCODE := TOS;  << store condition code >>                         38485000
   RESETCRITICAL(CRIT);                                                 38490000
   ERROREXIT(4,S0,0)                                                    38495000
   END;        << procedure FWRITE >>                                   38500000
$PAGE " FREADDIR - FWRITEDIR "                                          38505000
$CONTROL SEGMENT = FILESYS1A  << FREADDIR/FWRITEDIR >>                  38510000
                                                                        38515000
PROCEDURE FREADDIR(FILENUM,TARGET,TCOUNT,REC);  <<and FWRITEDIR>>       38520000
VALUE FILENUM,TCOUNT,REC;                                               38525000
INTEGER FILENUM,TCOUNT;                                                 38530000
DOUBLE REC;                                                             38535000
ARRAY TARGET;                                                           38540000
OPTION PRIVILEGED;                                                      38545000
   BEGIN                                                                38550000
   ENTRY FWRITEDIR,DBFWRITEDIR;                                <<06511>>38555000
   INTEGER POINTER AFT;     << for KSAM >>                     <<KS.00>>38560000
   EQUATE UBND = -9; <<Q rel upper bound for bounds check>>    <<03059>>38565000
   LOGICAL CODE;       << 0=READ, 1=WRITE >>                            38570000
   DEFINE READ = NOT CODE#,                                             38575000
          WRITE = CODE#;                                                38580000
   INTEGER CRIT;       << for SETCRITICAL >>                            38585000
   DOUBLE SAVE'FPTR;                                           <<01759>>38590000
   INTEGER                                                     <<06958>>38595000
      REC0 = REC + 0,                                          <<06958>>38600000
      REC1 = REC + 1;                                          <<06958>>38605000
                                                                        38610000
   << Remote file access (RFA) variables: >>                            38615000
                                                                        38620000
   INTEGER POINTER RFAPTR;    << appendage pointer >>                   38625000
   INTEGER RFALEN;            << appendage length >>                    38630000
   LOGICAL LOCAL'FAILURE := 0;                                          38635000
   LOGICAL IMAGE'ACCESS := 0;                                  <<04874>>38640000
   INTEGER ACBMQ;      << Q relative address of ACB >>         <<04874>>38645000
                                                                        38650000
   << Following LOC'ACB params must be last and in order: >>            38655000
   INTEGER AFTE;       << AFT entry word 0 >>                           38660000
   DOUBLE  PACBV;                                              <<06511>>38665000
   DOUBLE  LACBV;                                              <<06511>>38670000
   INTEGER IOQX;                                                        38675000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<04874>>38680000
   BUILD'ACB;                                                           38685000
                                                                        38690000
   LOGICAL DSTX;      << DST nr. of caller's buffer (where DB is) >>    38695000
   << end of LOC'ACB params >>                                          38700000
                                                                        38705000
   TOS := 0;          << flag for Read >>                               38710000
   RFALEN := S0;                                                        38715000
   GO CONT;                                                             38720000
FWRITEDIR:                                                              38725000
   TOS := 1;          << flag for Write >>                              38730000
   GO CONT;                                                    <<06511>>38735000
DBFWRITEDIR:                                                   <<06511>>38740000
   TOS := 1;                                                   <<06511>>38745000
   IMAGE'ACCESS := TRUE;                                       <<06511>>38750000
                                                               <<06511>>38755000
                                                               <<06511>>38760000
CONT:                                                                   38765000
   CODE := TOS;                                                         38770000
                                                                        38775000
$  IF X0 = ON                                                           38780000
   IF MONCALLABLE THEN                                                  38785000
      BEGIN          << monitoring >>                                   38790000
      FTITLE("FREA","D/WR","ITED","IR  ");                              38795000
      DEBUG                                                             38800000
      END;                                                              38805000
$  IF                                                                   38810000
                                                                        38815000
   ERRORON;                                                             38820000
   CRIT := SETCRITICAL;                                                 38825000
   GET'ACB'Q'LOC;                                              <<04874>>38830000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<04874>>38835000
   IF < THEN                                                            38840000
      BEGIN    << invalid file nr. >>                                   38845000
      TOS := INVFN;                                                     38850000
      TOS := CCL;                                                       38855000
      GO EXIT                                                           38860000
      END;                                                              38865000
   IF > THEN                                                            38870000
      BEGIN   << $NULL >>                                               38875000
      TOS := 0;        << No error. >>                                  38880000
      TOS := IF WRITE THEN CCE ELSE CCG;                                38885000
      GO EXIT                                                           38890000
      END;                                                              38895000
                                                                        38900000
      <<* * * OK * * *>>                                                38905000
                                                                        38910000
   CASE * FTYPE OF                                                      38915000
      BEGIN                                                             38920000
                                                                        38925000
      BEGIN     << conventional file >>                                 38930000
      IF IOQX <> 0 THEN                                                 38935000
         BEGIN     << No-wait I/O pending >>                            38940000
         TOS := IOPENDING;                                              38945000
         GO NFG                                                         38950000
         END;                                                           38955000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>38960000
         BEGIN           << Out of bounds. >>                           38965000
         TOS := BNDVIOL;                                                38970000
         GO NFG                                                         38975000
         END;                                                           38980000
      IF ACB'ACCCL <> DIRACC OR ACB'SPOOLED THEN                        38985000
         BEGIN          << Not disk file. Barf! >>                      38990000
         TOS := DEVVIOL;                                                38995000
         GO NFG                                                         39000000
         END;                                                           39005000
                                                               <<04874>>39010000
       <<*******************************************>>         <<04874>>39015000
       <<  We will allow IMAGE access even if the   >>         <<04874>>39020000
       <<  file is open read only.                  >>         <<04874>>39025000
       <<*******************************************>>         <<04874>>39030000
                                                               <<04874>>39035000
      IF IMAGE'ACCESS THEN                                     <<04874>>39040000
       << No checking >>                                       <<04874>>39045000
      ELSE IF WRITE THEN                                       <<04874>>39050000
         BEGIN          << FWRITEDIR >>                                 39055000
         IF (ACB'ACTYPE=0) OR (ACB'ACTYPE=3) OR ACB'CIRFILE    <<01555>>39060000
            THEN  <<INPUT, APPEND, OR CIRCULAR FILE?>>         <<01555>>39065000
         IF = OR TOS = 3 OR ACB'CIRFILE THEN <<INPUT OR APPEND?  HM.00>>39070000
            BEGIN     << INPUT or APPEND only. Sorry, Charlie. >>       39075000
E1:         TOS := ACCVIOL;                                             39080000
NFG:        ACB'ERROR := S0;                                            39085000
            TOS := CCL;                                                 39090000
            GO UNLK;                                                    39095000
            END                                                         39100000
         END                                                            39105000
      ELSE      << FREADDIR >>                                          39110000
         IF (1 <= ACB'ACTYPE <= 3) THEN GO E1; << haven't READ access >>39115000
      IF ACB'NORMVAR THEN GO E1;   << no random access for these >>     39120000
      SAVE'FPTR := ACB'FPTR;                                   <<01759>>39125000
      TOS := CODE;                                                      39130000
      IF ACB'NOWAIT THEN TOS := TOS+%30;                                39135000
      TOS := @TARGET;                                                   39140000
      TOS := TCOUNT;                                                    39145000
      IF ACB'SPECVAR THEN ACB'BLK := REC ELSE ACB'FPTR := REC;          39150000
      IF NOT ACB'INHIBITBUF THEN                                        39155000
         BEGIN        << Buffered access >>                             39160000
         IOMOVE(*,*,*);                                                 39165000
         END                                                   <<00630>>39170000
      ELSE                                                              39175000
         BEGIN       << NOBUF access >>                                 39180000
         TOS := REC;     << Block number! >>                            39185000
         X := ACB'BLKFACT;                                              39190000
         MPYD;         << convert to record number >>                   39195000
         ACB'FPTR := TOS;                                               39200000
         IOMOVE(*,*,*);                                                 39205000
         END;                                                           39210000
      TOS := ACB'ERROR;       << error nr. >>                           39215000
      TOS := ACBSTATUSCODE;  << Condition code to report >>             39220000
      IF S0.(14:2) <> CCE THEN ACB'FPTR := SAVE'FPTR;          <<01759>>39225000
                                                                        39230000
      <<* * * Measurement data on FREADDIR/FWRITEDIR * * *>>            39235000
                                                                        39240000
$  IF X3 = ON                                                           39245000
      IF MEAS'TAPE'ON THEN BEGIN                                        39250000
      IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                    39255000
         BEGIN       << Measure >>                                      39260000
         IF ACB'INHIBITBUF                                     <<06958>>39265000
            THEN REC := REC * DBL(ACB'BLKFACT);                <<06958>>39270000
         IF READ                                               <<06958>>39275000
            THEN MMSTAT'(EFREADDIR,FILENUM,ACB'TLOG,ACB'HIT,   <<06958>>39280000
                         REC0,REC1,0)                          <<06958>>39285000
            ELSE MMSTAT'(EFWRITEDIR,FILENUM,TCOUNT,ACB'HIT,    <<06958>>39290000
                         REC0,REC1,0);                         <<06958>>39295000
         END                                                            39300000
      END;     << of MEAS'TAPE'ON>>                                     39305000
$  IF                                                                   39310000
                                                                        39315000
UNLK: UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<04874>>39320000
      END;       << conventional file >>                                39325000
                                                                        39330000
      BEGIN       << Remote file >>                                     39335000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>39340000
         BEGIN                                                 <<DS.04>>39345000
         LOCAL'FAILURE := BNDVIOL;                             <<DS.04>>39350000
         TCOUNT := 0;                                          <<DS.06>>39355000
         END;                                                  <<DS.04>>39360000
      SETRFAPTR;                                               <<DS.00>>39365000
      RFALEN := 7;                                             <<DS.00>>39370000
      TOS := "RFA ";                                           <<DS.00>>39375000
      IF WRITE THEN               << FWRITEDIR >>              <<DS.03>>39380000
         IF RFAMREC THEN TOS := 27 ELSE TOS := 7               <<DS.03>>39385000
      ELSE                                                     <<DS.03>>39390000
         IF RFAMREC THEN TOS := 25 ELSE TOS := 4;              <<DS.03>>39395000
      LOAD'ERROR;                                              <<DS.04>>39400000
      TOS := RFAFILE;                                          <<DS.00>>39405000
      TOS := TCOUNT;                                           <<DS.00>>39410000
      TOS := REC;                                              <<DS.00>>39415000
      TOS := 0;     << stack MWC parameters >>                 <<DS.00>>39420000
      TOS := RFALINE;                                          <<DS.00>>39425000
      TOS := RFAMSG;                                           <<DS.00>>39430000
      TOS := RFASTREAM;                                        <<DS.00>>39435000
      TOS := RFASUBSTR;                                        <<DS.00>>39440000
      TOS := @RFAPTR;                                          <<DS.00>>39445000
      TOS := RFALEN;                                           <<DS.00>>39450000
      IF WRITE THEN                                            <<DS.03>>39455000
         BEGIN         << FWRITEDIR >>                         <<DS.03>>39460000
         IF RFAMREC THEN TOS := 0D ELSE                        <<DS.03>>39465000
            BEGIN                                              <<DS.03>>39470000
            TOS := @TARGET;                                    <<DS.03>>39475000
            TOS := TCOUNT;                                     <<DS.03>>39480000
            END;                                               <<DS.03>>39485000
         TOS := 0D;                                            <<DS.03>>39490000
         END                                                            39495000
      ELSE                                                              39500000
         BEGIN     << FREADDIR >>                              <<DS.03>>39505000
         TOS := 0D;                                            <<DS.03>>39510000
         TOS := @TARGET;                                       <<DS.03>>39515000
         TOS := TCOUNT;                                        <<DS.03>>39520000
         END;                                                  <<DS.03>>39525000
      TOS := MWCPLABEL;                                        <<DS.00>>39530000
      ASMB(PCAL 0);                                            <<DS.00>>39535000
      DEL;                                                     <<DS.00>>39540000
      CHECKXFER;                                               <<DS.00>>39545000
      IF WRITE AND RFAMREC AND LOCAL'FAILURE=0 THEN            <<DS.04>>39550000
         BEGIN       << Send data across >>                    <<DS.03>>39555000
         RFALEN := 0;                                          <<DS.03>>39560000
         GETMWCPARMS;                                          <<DS.03>>39565000
         TOS := @TARGET;                                       <<DS.03>>39570000
         TOS := TCOUNT;                                        <<DS.03>>39575000
         TOS := 0D;                                            <<DS.03>>39580000
         TOS := MWCPLABEL;                                     <<DS.03>>39585000
         ASMB(PCAL 0);                                         <<DS.03>>39590000
         DEL;                                                  <<DS.03>>39595000
         CHECKXFER;                                            <<DS.03>>39600000
         RFALEN := 7;                                          <<DS.03>>39605000
         END;                                                  <<DS.03>>39610000
      DELAPPENDAGE;                                            <<DS.00>>39615000
      PREPRETURN;                                              <<DS.00>>39620000
      GO EXIT;                                                 <<DS.00>>39625000
      HELP;   << dummy call >>                                          39630000
      END;       << remote file >>                                      39635000
        << dummy 2 >>;                                                  39640000
        << dummy 3 >>;                                                  39645000
        << dummy 4 >>;                                                  39650000
        << dummy 5 >>;                                                  39655000
      BEGIN      << KSAM file >>                                        39660000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>39665000
         BEGIN           << Out of bounds. >>                           39670000
         FKSAMBNDVIOL(FILENUM);                                <<KS.00>>39675000
         TOS := BNDVIOL;                                                39680000
         GO KNFG                                                        39685000
         END;                                                           39690000
      IF READ THEN                                             <<KS.00>>39695000
         BEGIN     << FREADDIR >>                              <<KS.00>>39700000
         KREADDIR(FILENUM,TARGET,TCOUNT,REC);                  <<KS.00>>39705000
         PUSH(STATUS);                                         <<KS.00>>39710000
         TOS := TOS.CC;                                        <<KS.00>>39715000
         ASMB(ZERO,XCH);                                       <<KS.00>>39720000
         END    << FREADDIR >>                                 <<KS.00>>39725000
      ELSE                                                     <<KS.00>>39730000
         BEGIN    << FWRITEDIR >>                              <<KS.00>>39735000
         TOS := UNIMPL;      <<"unimplemented">>               <<KS.00>>39740000
KNFG:    DSTX := EXCHANGEDB(0);    << to stack >>              <<KS.00>>39745000
         SETAFT;                                               <<KS.00>>39750000
         AFTFLAG := 3;      << KSAM error >>                   <<KS.00>>39755000
         AFTERRNUM := S0;                                               39760000
         TOS := CCL;                                           <<KS.00>>39765000
         EXCHANGEDB(DSTX);                                     <<KS.00>>39770000
         END;      << FWRITEDIR >>                             <<KS.00>>39775000
      END;      << KSAM file >>                                         39780000
                                                                        39785000
         <<DUMMY 7>>;                                          <<HM.00>>39790000
         BEGIN                                                 <<HM.00>>39795000
         TOS:=ACCVIOL;                                         <<HM.00>>39800000
         GO NFG;                                               <<HM.00>>39805000
         END;                                                  <<HM.00>>39810000
      END;    << FTYPE CASE >>                                          39815000
                                                                        39820000
EXIT:                                                                   39825000
   CONDCODE := TOS;        << report condition code >>                  39830000
   RESETCRITICAL(CRIT);                                                 39835000
   ERROREXIT(5,S0,0)                                                    39840000
   END;         << procedure FREADDIR/FWRITEDIR >>                      39845000
$PAGE " FUPDATE "                                                       39850000
$CONTROL SEGMENT = FILESYS2   << FUPDATE >>                             39855000
PROCEDURE FUPDATE(FILENUM,TARGET,TCOUNT);                               39860000
VALUE FILENUM,TCOUNT;                                                   39865000
INTEGER FILENUM,TCOUNT;                                                 39870000
ARRAY TARGET;                                                           39875000
OPTION PRIVILEGED;                                                      39880000
   BEGIN                                                                39885000
   EQUATE UBND = -7; <<Q rel upper bound for bounds check>>    <<03059>>39890000
   INTEGER CRIT;        << for SETCRITICAL >>                           39895000
                                                                        39900000
   << Remote file access (RFA) variables: >>                            39905000
                                                                        39910000
   INTEGER POINTER RFAPTR;    << appendage pointer >>                   39915000
   INTEGER RFALEN;            << appendage length >>                    39920000
   LOGICAL LOCAL'FAILURE := 0;                                 <<DS.04>>39925000
   INTEGER WC;                                                          39930000
                                                                        39935000
   << Following LOC'ACB params must be last and in order: >>            39940000
   INTEGER ACBMQ;                                              <<06511>>39945000
   INTEGER AFTE;      << AFT entry word 0 >>                            39950000
   DOUBLE  PACBV;                                              <<06511>>39955000
   DOUBLE  LACBV;                                              <<06511>>39960000
   INTEGER IOQX;                                                        39965000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>39970000
   BUILD'ACB;                                                           39975000
   LOGICAL DSTX;     << DST nr. of caller's buffer >>                   39980000
   << end of LOC'ACB params >>                                          39985000
                                                                        39990000
$  IF X0 = ON                                                           39995000
   IF MONCALLABLE THEN DEBUG;  << monitoring >>                         40000000
$  IF                                                                   40005000
                                                                        40010000
   ERRORON;                                                             40015000
   WC := IF TCOUNT < 0 THEN (-TCOUNT+1)&LSR(1) ELSE TCOUNT;             40020000
   CRIT := SETCRITICAL;                                                 40025000
   GET'ACB'Q'LOC;                                              <<06511>>40030000
   LOC'ACB(*,ACBMQ,FILENUM,0);                                 <<06511>>40035000
   IF < THEN                                                            40040000
      BEGIN         << invalid file nr. >>                              40045000
      TOS := INVFN;                                                     40050000
      TOS := CCL;                                                       40055000
      GO EXIT                                                           40060000
      END;                                                              40065000
   IF > THEN                                                            40070000
      BEGIN        << $NULL >>                                          40075000
      TOS := 0;        << No error. >>                                  40080000
      TOS := CCE;                                                       40085000
      GO EXIT                                                           40090000
      END;                                                              40095000
                                                                        40100000
      <<* * * OK.  Do FUPDATE * * *>>                                   40105000
                                                                        40110000
   CASE * FTYPE OF                                                      40115000
      BEGIN                                                             40120000
                                                                        40125000
      BEGIN    << conventional file >>                                  40130000
      IF IOQX <> 0 THEN                                                 40135000
         BEGIN          << No-wait I/O pending >>                       40140000
         TOS := IOPENDING;                                              40145000
         GO NFG                                                         40150000
         END;                                                           40155000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>40160000
         BEGIN      << out of bounds. >>                                40165000
         TOS := BNDVIOL;                                                40170000
         GO NFG                                                         40175000
         END;                                                           40180000
      IF ACB'ACCCL <> DIRACC OR ACB'SPOOLED THEN                        40185000
         BEGIN      << Must be disk. >>                                 40190000
         TOS := DEVVIOL;                                                40195000
         GO NFG                                                         40200000
         END;                                                           40205000
      IF NOT ACB'UPDATE OR ACB'VARIABLE THEN                   <<06511>>40210000
         BEGIN      << Can't UPDATE. >>                                 40215000
         TOS := ACCVIOL;                                                40220000
         GO NFG                                                         40225000
         END;                                                           40230000
      IF ACB'FPTR <= 0D THEN                                            40235000
         BEGIN                                                          40240000
         TOS := FUPDSEQERR;                                             40245000
NFG:     ACB'ERROR := S0;                                               40250000
         TOS := CCL;                                                    40255000
         GO UNLK;                                                       40260000
         END;                                                           40265000
      TOS := IF ACB'NOWAIT THEN %31 ELSE 1;                             40270000
      IF ACB'INHIBITBUF THEN                                            40275000
         BEGIN         << NOBUF access >>                               40280000
         IF WC > ACB'BSIZE THEN                                <<06511>>40285000
            BEGIN       << More than one block is a no-no. >>           40290000
            TOS := BADTCOUNT;                                           40295000
            GO NFG                                                      40300000
            END;                                                        40305000
         ACB'FPTR := ACB'FPTR+1D-DOUBLE(ACB'BLKFACT);                   40310000
         END;                                                           40315000
      ACB'FPTR := ACB'FPTR-1D;                                          40320000
      IOMOVE(*,TARGET,TCOUNT);                                          40325000
      TOS := ACB'ERROR;                                                 40330000
      TOS := ACBSTATUSCODE;  << condition code to report >>             40335000
                                                                        40340000
      <<* * * Measurement data on FUPDATE * * *>>                       40345000
                                                                        40350000
$  IF X3 = ON                                                           40355000
      IF MEAS'TAPE'ON THEN BEGIN                                        40360000
      IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                    40365000
         MMSTAT'(EFUPDATE,FILENUM,TCOUNT,ACB'HIT,0,0,0);       <<06958>>40370000
      END;    << of MEAS'TAPE'ON >>                                     40375000
$  IF                                                                   40380000
UNLK: UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<06511>>40385000
      END;     << conventional file >>                                  40390000
                                                                        40395000
      BEGIN     << Remote file >>                                       40400000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>40405000
         BEGIN                                                 <<DS.04>>40410000
         LOCAL'FAILURE := BNDVIOL;                             <<DS.04>>40415000
         TCOUNT := 0;                                          <<DS.06>>40420000
         END;                                                  <<DS.04>>40425000
      SETRFAPTR;                                               <<DS.00>>40430000
      RFALEN := 5;                                             <<DS.00>>40435000
      TOS := "RFA ";                                           <<DS.00>>40440000
      IF RFAMREC THEN TOS := 28 ELSE TOS := 10;                <<DS.03>>40445000
      LOAD'ERROR;                                              <<DS.04>>40450000
      TOS := RFAFILE;                                          <<DS.00>>40455000
      TOS := TCOUNT;                                           <<DS.00>>40460000
      GETMWCPARMS;                                             <<DS.00>>40465000
      IF RFAMREC THEN TOS := 0D ELSE                           <<DS.03>>40470000
         BEGIN                                                 <<DS.03>>40475000
         TOS := @TARGET;                                       <<DS.03>>40480000
         TOS := TCOUNT;                                        <<DS.03>>40485000
         END;                                                  <<DS.03>>40490000
      TOS := 0D;                                               <<DS.00>>40495000
      TOS := MWCPLABEL;                                        <<DS.00>>40500000
      ASMB(PCAL 0);                                            <<DS.00>>40505000
      DEL;                                                     <<DS.00>>40510000
      CHECKXFER;                                               <<DS.00>>40515000
      IF RFAMREC THEN                                          <<DS.03>>40520000
         BEGIN     << Send data >>                             <<DS.03>>40525000
         RFALEN := 0;                                          <<DS.03>>40530000
         GETMWCPARMS;                                          <<DS.03>>40535000
         TOS := @TARGET;                                       <<DS.03>>40540000
         TOS := TCOUNT;                                        <<DS.03>>40545000
         TOS := 0D;                                            <<DS.03>>40550000
         TOS := MWCPLABEL;                                     <<DS.03>>40555000
         ASMB(PCAL 0);                                         <<DS.03>>40560000
         DEL;                                                  <<DS.03>>40565000
         CHECKXFER;                                            <<DS.03>>40570000
         RFALEN := 5;                                          <<DS.03>>40575000
         END;                                                  <<DS.03>>40580000
      DELAPPENDAGE;                                            <<DS.00>>40585000
      PREPRETURN;                                              <<DS.00>>40590000
      GO EXIT;                                                 <<DS.00>>40595000
      END;     << remote file >>                                        40600000
            << dummy 2 >>;                                              40605000
            << dummy 3 >>;                                              40610000
            << dummy 4 >>;                                              40615000
            << dummy 5 >>;                                              40620000
      BEGIN     << KSAM file >>                                         40625000
      IF FBNDVIOL(@TARGET,TCOUNT,UBND) THEN                    <<03059>>40630000
         BEGIN      << out of bounds. >>                                40635000
         FKSAMBNDVIOL(FILENUM);                                <<KS.00>>40640000
         TOS := BNDVIOL;                                                40645000
         TOS := CCL;                                                    40650000
         GO EXIT;                                                       40655000
         END;                                                           40660000
      KUPDATE(FILENUM,TARGET,TCOUNT);                          <<KS.00>>40665000
      PUSH(STATUS);                                            <<KS.00>>40670000
      TOS := TOS.CC;      << report condition code >>          <<KS.00>>40675000
      ASMB(ZERO,XCH);                                          <<KS.00>>40680000
      END;       << KSAM file >>                               <<KS.00>>40685000
      <<DUMMY 7>>;                                             <<HM.00>>40690000
      BEGIN  <<MSG FILE>>                                      <<HM.00>>40695000
      TOS:=ACCVIOL;                                            <<HM.00>>40700000
      GO NFG;                                                  <<HM.00>>40705000
      END;                                                     <<HM.00>>40710000
      END; << FTYPE CASE >>                                    <<DS.00>>40715000
                                                                        40720000
EXIT:                                                                   40725000
   CONDCODE := TOS;    << report condition code >>                      40730000
   RESETCRITICAL(CRIT);                                                 40735000
   ERROREXIT(3,S0,0)                                                    40740000
   END;      << procedure FUPDATE >>                                    40745000
$PAGE " IOWAIT "                                                        40750000
$CONTROL SEGMENT = FILESYS2   << IOWAIT >>                              40755000
                                                                        40760000
INTEGER PROCEDURE IOWAIT(FILENUM,TARGET,TCOUNT,CSTATION);               40765000
VALUE FILENUM;                                                          40770000
INTEGER FILENUM,TCOUNT;                                                 40775000
LOGICAL CSTATION;                                                       40780000
ARRAY TARGET;                                                           40785000
OPTION VARIABLE,PRIVILEGED;                                             40790000
                                                                        40795000
<< Notice to users:                                                     40800000
   It is not possible to use the IOWAIT intrinsic with a                40805000
   KSAM/3000 file at this time because the developers                   40810000
   of this access method for the HP3000 have decided                    40815000
   that the concept of input-output without wait is not                 40820000
   consistent with the method of implementation of the                  40825000
   access method.  Sorry, Charlie.          >>                          40830000
                                                                        40835000
   BEGIN                                                                40840000
   DEFINE READ = NOT ACB'NOWAITMODE#,                                   40845000
          WRITE = ACB'NOWAITMODE#;                                      40850000
   DEFINE NOBUFSPEC = NOT (PMAP.(13:1))#;                      <<HM.00>>40855000
   ENTRY MIOWAIT;        << MAKRO - reset LEFTOFF to zero >>            40860000
   ENTRY IODONTWAIT;     << Don't wait for I/O completion >>            40865000
   ENTRY MIODONTWAIT;    << MAKRO - don't wait and reset LEFTOFF>>      40870000
   LOGICAL PMAP = Q-4;   << Option Variable bit map >>                  40875000
   EQUATE UBND = -10; << Q rel upper bound for bounds check>>  <<03059>>40880000
   INTEGER PCBPT;     << Offset to our PCB for PCB defines. >> <<06511>>40885000
   INTEGER ERROR;            << error nr. for ERROREXIT >>              40890000
   INTEGER CRIT;             << for SETCRITICAL >>                      40895000
   INTEGER POINTER PXFILE;                                              40900000
   LOGICAL FLAGS;                                                       40905000
   DEFINE DONTWAIT = FLAGS.(14:1)#;  << don't wait for I/O >>           40910000
   INTEGER POINTER AFT;                                                 40915000
   DOUBLE POINTER AFTDBL = AFT;                                         40920000
   INTEGER ENTRYTYPE := -1;  << AFT entry type >>                       40925000
   LOGICAL UNKNOWNENTRY := TRUE;                               <<07399>>40930000
   DEFINE FSENTRY      = (ENTRYTYPE = 0)#,                     <<07399>>40935000
          CSENTRY       = ( ENTRYTYPE&LSR(1) = 2)#,            <<00183>>40940000
          DSENTRY       = ( ENTRYTYPE&LSR(1) = 1)#,            <<00183>>40945000
          TTSENTRY      = ( ENTRYTYPE = 7)#,                   <<HM.00>>40950000
          MSGENTRY      = ( ENTRYTYPE = 8)#,                   <<06959>>40955000
          PORTENTRY     = ( ENTRYTYPE = 9)#;                   <<06959>>40960000
                                                                        40965000
   DOUBLE IOCB;        << IOCB of completed I/O >>                      40970000
      INTEGER IOQSTATUS = IOCB,                                         40975000
              IOQTLOG = IOCB+1;                                         40980000
   INTEGER LDEV;        << LDEV on which I/O completed >>               40985000
   LOGICAL STATION := 0;  << CS station of completed I/O>>              40990000
   LOGICAL DUMMY'IOQX := FALSE;  ! File system stub?           <<06511>>40995000
   INTEGER GLOBAL'AFT'SIZE;      ! Size, in words, of AFT      <<06511>>41000000
   INTEGER TRANSLOG := 0;                                               41005000
   INTEGER I,COMP'IOQINDEX,NUM'IOQINDICES;                     <<00613>>41010000
   INTEGER ARRAY IOQINDEX(0:13)=Q;                             <<HM.00>>41015000
   EQUATE CS'ERRORLOC =  5;   << PXFILE location >>            <<00613>>41020000
   EQUATE                                                      <<HM.00>>41025000
      NO'WAIT'DONE    = -1,                                    <<HM.00>>41030000
      SOFTINTPEND     = -2,                                    <<03038>>41035000
      SOFTINTOCCURRED = -3,                                    <<03038>>41040000
      IOCOMPLETION    = 1,                                     <<03038>>41045000
      PORT'WAIT       = -4,                                    <<HM.00>>41050000
      LONG'WAIT       = 1;                                     <<HM.00>>41055000
INTEGER ACBMQ;                                                 <<04567>>41060000
                                                                        41065000
<< Following LOC'ACB params must be last and in order: >>               41070000
   INTEGER AFTE;      << AFT entry word 0 >>                            41075000
   DOUBLE  PACBV;                                              <<06511>>41080000
   DOUBLE  LACBV;                                              <<06511>>41085000
   INTEGER IOQX;      << IOQX of completed I/O >>                       41090000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;                        <<HM.00>>41095000
BUILD'ACB;                                                     <<06511>>41100000
   INTEGER DSTX;      << DST of user's buffer >>                        41105000
$PAGE                                                          <<06511>>41110000
   SUBROUTINE IOEXIT(FCERROR);                                          41115000
   << Inserts the specified error number in the PXFILE area or          41120000
     ACB and does the ERROREXIT from the IOWAIT procedure.              41125000
                                                                        41130000
        Input variables:                                                41135000
            FCERROR - FS/CS error number                                41140000
                                                                        41145000
      May be called with DB at any data segment.    >>                  41150000
   VALUE FCERROR;                                                       41155000
   INTEGER FCERROR;                                                     41160000
      BEGIN                                                             41165000
      IF FCERROR = SOFTINTOCCURRED THEN                        <<03038>>41170000
         BEGIN  <<SOFT INT, FORCE USER TO RECALL IOWAIT>>      <<03038>>41175000
         PREGISTER:=PREGISTER-1;                               <<03038>>41180000
         PREGISTER.(0:1):=1;                                   <<03038>>41185000
         IF DSTX <> 0 THEN EXCHANGEDB(DSTX);                   <<03038>>41190000
         RESETCRITICAL(CRIT);                                  <<03038>>41195000
         ERROREXIT(0,0,0);                                     <<03038>>41200000
         END;                                                  <<03038>>41205000
      IF UNKNOWNENTRY THEN                                              41210000
         BEGIN    << AFT type unknown. Post nr. in PXFILE >>            41215000
         EXCHANGEDB(0);   << Set DB to stack >>                         41220000
         SETPXFILE;      << init. PXFILE pointer >>                     41225000
         PXFFOPEN := FCERROR;                                           41230000
         PXFDOPEN := FCERROR;                                           41235000
         PXFCOPEN := FCERROR                                            41240000
         END                                                            41245000
      ELSE IF CSENTRY THEN      << CS line referenced? >>      <<00613>>41250000
         BEGIN     << Save CS error in MISC'DST for AFT entry>><<00613>>41255000
         EXCHANGEDB(0);       << Set DB to stack >>            <<00613>>41260000
         TOS := @FCERROR;   << S-rel addr before TOS moves>>   <<00613>>41265000
         TOS := AFTCS'MDST;                                    <<00613>>41270000
         TOS := CS'ERRORLOC;                                   <<00613>>41275000
         ASMB(CAB);       << FCERROR address to TOS >>         <<00613>>41280000
         TOS := 1;          << word count >>                   <<00613>>41285000
         ASMB(MTDS);                                           <<00613>>41290000
         END                                                   <<00613>>41295000
      ELSE IF FSENTRY OR MSGENTRY THEN                         <<HM.00>>41300000
         BEGIN      << Set ACBERROR. >>                                 41305000
         LOC'ACB(0,ACBMQ,FILENUM,UMODE);                       <<HM.00>>41310000
         DEL;      << discard DSTX >>                                   41315000
         ACB'ERROR := FCERROR;                                          41320000
         UNLOC'ACB(ACBMQ,0);                                   <<HM.00>>41325000
         END;                                                           41330000
      ERROR := FCERROR;                                                 41335000
      EXCHANGEDB(DSTX);                                        <<06511>>41340000
      RESETCRITICAL(CRIT);                                              41345000
      CONDCODE := CCL;                                                  41350000
      ERROREXIT(5,ERROR,0)                                              41355000
      END;      << subroutine IOEXIT >>                                 41360000
                                                                        41365000
   SUBROUTINE SETWAKE'(INDEX);                                 <<HM.00>>41370000
   VALUE INDEX;                                                <<HM.00>>41375000
   INTEGER INDEX;                                              <<HM.00>>41380000
      BEGIN                                                    <<HM.00>>41385000
      IF MSGENTRY THEN                                         <<06511>>41390000
         BEGIN                                                 <<01568>>41395000
         IF INDEX = NO'WAIT'DONE THEN                          <<01568>>41400000
            BEGIN  <<IO COMPLETED AT INITIATION TIME>>         <<01568>>41405000
            TOS:=-1; DEL;  <<FORCE CCL STATUS>>                <<01568>>41410000
            END                                                <<01568>>41415000
         ELSE                                                  <<01568>>41420000
            FCPORTENABLE(INDEX);                               <<03038>>41425000
         END                                                   <<01568>>41430000
      ELSE IF PORTENTRY THEN                                   <<06959>>41435000
         BEGIN                                                 <<06959>>41440000
         IF INDEX < 0 THEN                                     <<06959>>41445000
            BEGIN  << IO COMPLETED BY SOFT INTERRUPT >>        <<06959>>41450000
            TOS := -1; DEL;  << FORCE CCL >>                   <<06959>>41455000
            END                                                <<06959>>41460000
         ELSE                                                  <<06959>>41465000
            ENABLEIOWAITPORT(INDEX);                           <<06959>>41470000
         END                                                   <<06959>>41475000
      ELSE                                                     <<HM.00>>41480000
         SETWAKE(INDEX);                                       <<HM.00>>41485000
      END;  <<SETWAKE'>>                                       <<HM.00>>41490000
   SUBROUTINE CLEARWAKE'(INDEX);                               <<HM.00>>41495000
   VALUE INDEX;                                                <<HM.00>>41500000
   INTEGER INDEX;                                              <<HM.00>>41505000
      BEGIN                                                    <<HM.00>>41510000
      IF MSGENTRY THEN                                         <<06511>>41515000
         FCPORTDISABLE(INDEX)                                  <<HM.00>>41520000
      ELSE IF PORTENTRY THEN                                   <<06959>>41525000
         DISABLEIOWAITPORT(INDEX)                              <<06959>>41530000
      ELSE                                                     <<HM.00>>41535000
         CLEARWAKE(INDEX);                                     <<HM.00>>41540000
      END;  <<CLEARWAKE'>>                                     <<HM.00>>41545000
$PAGE                                                          <<06511>>41550000
   DOUBLE SUBROUTINE WAITFORIOX'(IOQX);                        <<HM.00>>41555000
   VALUE IOQX;                                                 <<HM.00>>41560000
   INTEGER IOQX;                                               <<HM.00>>41565000
      BEGIN                                                    <<HM.00>>41570000
      IF MSGENTRY OR PORTENTRY THEN                            <<06959>>41575000
         BEGIN  <<PORT WAIT, ALLOW ABORT>>                     <<HM.00>>41580000
         IF MSGENTRY                                           <<06959>>41585000
           THEN FCPORTENABLE(IOQX)                             <<06959>>41590000
           ELSE ENABLEIOWAITPORT(IOQX);                        <<06959>>41595000
         WHILE = DO                                            <<06959>>41600000
            BEGIN  <<WAIT FOR I/O OR SOFT INTERRUPT>>          <<03038>>41605000
            RESETCRITICAL(CRIT);                               <<06959>>41610000
            WAIT(PORT'WAIT,%10001);                            <<03038>>41615000
            IF > THEN                                          <<03038>>41620000
               BEGIN  <<SOFT INTERRUPT OCCURRED>>              <<03038>>41625000
               SETCRITICAL;                                    <<03038>>41630000
               CLEARWAKE'(IOQX);                               <<03038>>41635000
               IOEXIT(SOFTINTOCCURRED);                        <<03038>>41640000
               END;                                            <<03038>>41645000
            SETCRITICAL;                                       <<06959>>41650000
            IF MSGENTRY                                        <<06959>>41655000
              THEN FCPORTENABLE(IOQX)                          <<06959>>41660000
              ELSE ENABLEIOWAITPORT(IOQX);                     <<06959>>41665000
            END;                                               <<06959>>41670000
         END                                                   <<HM.00>>41675000
      ELSE                                                     <<HM.00>>41680000
         BEGIN                                                 <<HM.00>>41685000
         WAITFORIOX':=WAITFORIOX(IOQX);                        <<HM.00>>41690000
$IF X1=ON                                                      <<HM.00>>41695000
         IF <> THEN FTROUBLE(487);                             <<HM.00>>41700000
$IF                                                            <<HM.00>>41705000
         END;                                                  <<HM.00>>41710000
      END;  <<WAITFORIOX'>>                                    <<HM.00>>41715000
   SUBROUTINE CHECK'CS'IOQINDICES;                             <<00613>>41720000
      << Check the multiple CS IOQ indices for completion. >>           41725000
      << Completed IOQ index is stored in the CS AFTIOQX. >>            41730000
      BEGIN                                                             41735000
      NUM'IOQINDICES :=                                                 41740000
         GET'CS'IOQINDICES(AFTCS'MDST,AFTCSIOQCBV,IOQINDEX);            41745000
      IF NUM'IOQINDICES = 0 THEN RETURN;  << None outstanding>>         41750000
   << Check each IOQ index for completion. >>                           41755000
      CLEARWWS;                                                         41760000
      I := -1;                                                          41765000
      COMP'IOQINDEX := 0;                                               41770000
                                                                        41775000
         DO                                                             41780000
            BEGIN                                                       41785000
            DO                                                          41790000
               BEGIN                                                    41795000
               I := I + 1;                                              41800000
               IF IOQINDEX(I) <> 0 THEN                        <<C7793>>41805000
                  BEGIN                                        <<C7793>>41810000
                  SETWAKE(IOQINDEX(I));                        <<C7793>>41815000
                  IF < THEN   <<I/O complete >>                <<C7793>>41820000
                     COMP'IOQINDEX := IOQINDEX(I);             <<C7793>>41825000
                  END;   << valid ioq index >>                 <<C7793>>41830000
               END                                                      41835000
            UNTIL COMP'IOQINDEX <> 0 OR I = NUM'IOQINDICES-1;           41840000
                                                                        41845000
         IF COMP'IOQINDEX = 0 AND NOT DONTWAIT THEN                     41850000
            WAIT(-%100,0);                                              41855000
                                                                        41860000
         DO                                                             41865000
            BEGIN                                                       41870000
            IF IOQINDEX(I) <> 0 THEN                           <<C7793>>41875000
               BEGIN                                           <<C7793>>41880000
               CLEARWAKE(IOQINDEX(I));                         <<C7793>>41885000
               IF < THEN       << I/O complete >>              <<C7793>>41890000
                  COMP'IOQINDEX := IOQINDEX(I);                <<C7793>>41895000
               END;   << valid ioq index >>                    <<C7793>>41900000
            END                                                         41905000
         UNTIL (I:=I-1) < 0;                                            41910000
         END      << END DO UNTIL COMP'IOQINDEX <> 0 >>                 41915000
      UNTIL COMP'IOQINDEX <> 0 OR DONTWAIT;                             41920000
                                                                        41925000
      !------------------------------------------------------- <<07399>>41930000
      ! Save the completed IOQX in the CS AFT.  If none        <<07399>>41935000
      ! have completed, then we must show I/O pending so       <<07399>>41940000
      ! that we dont exit with an FSERR.                       <<07399>>41945000
      !------------------------------------------------------- <<07399>>41950000
                                                               <<07399>>41955000
      IF COMP'IOQINDEX <> 0                                    <<07399>>41960000
         THEN AFTIOQX := COMP'IOQINDEX  ! We found one.        <<07399>>41965000
         ELSE AFTIOQX := IOQINDEX;      ! Must show I/O pend.  <<07399>>41970000
      IOQX := AFTIOQX;                  ! Set Q-rel. variable. <<07399>>41975000
      END;    << subroutine CHECK'CS'IOQINDICES >>             <<01165>>41980000
                                                                        41985000
$PAGE                                                          <<06511>>41990000
SUBROUTINE GET'AFT'ENTRY;                                      <<06511>>41995000
                                                               <<06511>>42000000
!------------------------------------------------------------- <<06511>>42005000
! This subroutine finds the AFT entry for the file numb. sent. <<06511>>42010000
! The file could be a global AFT file in which case the AFT    <<06511>>42015000
! is found in the Global AFT DST.  If this is the case, then   <<06511>>42020000
! the file could be a standard MPE file or a message file on-  <<06511>>42025000
! ly.  Because of this possiblilty, AFT defines CANNOT BE      <<06511>>42030000
! USED unless you are possitive the AFT is in the stack!       <<06511>>42035000
! ANY accesses to the AFT MUST use the local variables and     <<06511>>42040000
! defines since the AFT pointer will not currently be set to   <<06511>>42045000
! to the AFT since the AFT resides in the Global AFT DST and   <<06511>>42050000
! upon exit of this subroutine, DB will be set the the stack.  <<06511>>42055000
! Upon entrance, DB will be set to the user's target DB .      <<06511>>42060000
!------------------------------------------------------------- <<06511>>42065000
                                                               <<06511>>42070000
BEGIN                                                          <<06511>>42075000
IF GLOBAL'FILENUM THEN                                         <<06511>>42080000
   BEGIN                                                       <<06511>>42085000
   IF GLOBAL'AFT'DSTN = 0 OR NOT PRIVMODE                      <<06511>>42090000
      THEN IOEXIT(INVFN);  ! Kick the bum out.                 <<06511>>42095000
   GLOBAL'AFT'SIZE := DST'(GLOBAL'AFT'DSTN*DSTENTRY).(3:13)*4; <<06511>>42100000
   @AFT := \FILENUM\*AFTENTRY;                                 <<06511>>42105000
   IF NOT(@AFT + AFTENTRY <= GLOBAL'AFT'SIZE)                  <<06511>>42110000
      THEN IOEXIT(INVFN);  ! File number is beyond range.      <<06511>>42115000
   EXCHANGEDB(GLOBAL'AFT'DSTN);                                <<06511>>42120000
   IF AFTDBL = 0D THEN                                         <<06511>>42125000
      BEGIN                                                    <<06511>>42130000
      EXCHANGEDB(0);       ! Set DB to stack and exit.         <<06511>>42135000
      IOEXIT(INVFN);       ! File is not opened.               <<06511>>42140000
      END;                                                     <<06511>>42145000
   END                                                         <<06511>>42150000
ELSE                                                           <<06511>>42155000
   BEGIN                                                       <<06511>>42160000
   IF DSTX <> 0 THEN EXCHANGEDB(0);                            <<06511>>42165000
   SETPXFILE;                                                  <<06511>>42170000
   IF NOT(1 <= FILENUM <= PXFAFTSIZE/AFTENTRY) OR              <<06511>>42175000
      (FILENUM <= 2 LAND NOT PRIVMODE)                         <<06511>>42180000
      THEN IOEXIT(INVFN);  ! Not legal file number for user.   <<06511>>42185000
   SETAFT;                                                     <<06511>>42190000
   IF NOT AFTDSKLUDGE OR AFTDBL = 0D                           <<06511>>42195000
      THEN IOEXIT(INVFN);  ! File not open and not DS Kludge.  <<06511>>42200000
   LDEV := AFTLDEV;        ! Save CS ldev, may be used later.  <<06511>>42205000
   END;                                                        <<06511>>42210000
IF AFTFSTYPE AND AFTNULL=1 ! If this is $NULL, then simply     <<06511>>42215000
   THEN IOEXIT(0);         ! return with no error.             <<06511>>42220000
IOQX := AFTIOQX;           ! Now save entry type and IOQX in   <<06511>>42225000
ENTRYTYPE := AFTTYPE;      ! Q-relative locations.             <<06511>>42230000
IF GLOBAL'FILENUM          ! Set back to stack if global AFT.  <<06511>>42235000
   THEN EXCHANGEDB(0);                                         <<06511>>42240000
END;                                                           <<06511>>42245000
$PAGE                                                          <<06511>>42250000
<< * * *  Begin execution  * * * >>                                     42255000
                                                                        42260000
$  IF X0 = ON                                                           42265000
   IF MONCALLABLE THEN                                                  42270000
      BEGIN        << monitoring >>                                     42275000
      FTITLE("IOWA","IT  ",0D,0D);                                      42280000
      DEBUG                                                             42285000
      END;                                                              42290000
$  IF                                                                   42295000
                                                                        42300000
   TOS := %(2)00;   << normal call >>                                   42305000
   GO CONT;                                                             42310000
MIOWAIT:                                                                42315000
   TOS := %(2)01;   << reset LEFTOFF >>                                 42320000
   GO CONT;                                                             42325000
IODONTWAIT:                                                             42330000
   TOS := %(2)10;  << Don't wait for I/O completion >>                  42335000
   GO CONT;                                                             42340000
   HELP;    << dummy call >>                                   <<00117>>42345000
MIODONTWAIT:                                                            42350000
   TOS := %(2)11;  << Reset LEFTOFF and don't wait >>                   42355000
CONT:                                                                   42360000
   FLAGS := TOS;   << special action flags >>                           42365000
                                                                        42370000
   ERRORON;                                                    <<00685>>42375000
   CRIT := SETCRITICAL;                                        <<00685>>42380000
   GET'ACB'Q'LOC;                                              <<04567>>42385000
   IOWAIT := 0;                                                         42390000
   PCBPT := CURPRC;                                            <<06511>>42395000
   DSTX := SPCBXDSDST;  << User's DST number, 0 if stack.   >> <<06511>>42400000
                                                                        42405000
   <<* * * Bounds check parameters * * *>>                              42410000
                                                                        42415000
   TOS := PMAP;           << OPTION-VARIABLE bit map >>                 42420000
   IF LS0.(15:1) THEN       << CSTATION specified? >>                   42425000
      IF FBNDVIOL(@CSTATION,1,UBND) THEN IOEXIT(BNDVIOL);      <<03059>>42430000
   IF LS0.(14:1) THEN       << TCOUNT specified? >>                     42435000
      IF FBNDVIOL(@TCOUNT,1,UBND) THEN IOEXIT(BNDVIOL);        <<03059>>42440000
   IF LS0.(13:1) THEN       << TARGET specified? >>            <<06959>>42445000
      IF FBNDVIOL(@TARGET,1,UBND) THEN IOEXIT(BNDVIOL);        <<06959>>42450000
                                                                        42455000
   <<* * * Get AFT address of completed I/O * * *>>                     42460000
                                                                        42465000
   IF NOT LS0.(12:1) OR FILENUM = 0 THEN                                42470000
      BEGIN         << Pick up any completed I/O. >>                    42475000
      FINDWAITINGIO(0,DUM,FLAGS);  << try to find one >>                42480000
      <<DB has now been set to the stack>>                     <<03038>>42485000
      IF > THEN IOEXIT(SOFTINTOCCURRED);                       <<03038>>42490000
      IF < THEN IOEXIT(NOIOPENDING1);     << warn't none. >>            42495000
      @AFT := TOS;           << AFT entry pointer >>                    42500000
      FILENUM := TOS;        << file or line nr. >>                     42505000
      IF FILENUM = 0 THEN                                               42510000
         BEGIN               << IODONTWAIT >>                           42515000
AOK:     EXCHANGEDB(DSTX);   << restore user's DB >>                    42520000
         CONDCODE := CCE;    << report OK >>                            42525000
         GO EXIT                                                        42530000
         END;                                                  <<06511>>42535000
      ENTRYTYPE := AFTTYPE;                                    <<06511>>42540000
      IOQX := AFTIOQX;                                         <<06511>>42545000
      LDEV := AFTLDEV;                                         <<06511>>42550000
      END                                                               42555000
   ELSE                                                                 42560000
      BEGIN            << Inquiry about specific file. >>               42565000
      GET'AFT'ENTRY;   ! Find the AFT entry, global or local.  <<06511>>42570000
      IF (MSGENTRY OR PORTENTRY) AND IOQX = SOFTINTPEND        <<06959>>42575000
         THEN IOEXIT(NOIOPENDING2);                            <<06511>>42580000
      IF CSENTRY AND (AFTCSIOQCBV <> 0) THEN                   <<06511>>42585000
         CHECK'CS'IOQINDICES;    << Check multiple CS IOQS >>  <<00613>>42590000
                                                               <<04567>>42595000
      <<****************************************************>> <<06959>>42600000
      << Don't check status if IOQX < 0.  The IOQX was put  >> <<06959>>42605000
      << there as a stub by the file system (nowait read    >> <<06959>>42610000
      << from an unallocated extent) or by IPC (all nowait  >> <<06959>>42615000
      << message files reads or writes have the negative    >> <<06959>>42620000
      << reply port number in the IOQX) or it is a special  >> <<06959>>42625000
      << index used be the PORT procedures.  In these cases,>> <<06959>>42630000
      << it is not a real IOQX, don't call I/O procedures.  >> <<06959>>42635000
      <<****************************************************>> <<06959>>42640000
                                                               <<04567>>42645000
      IF DONTWAIT AND IOQX > 0 THEN                            <<06511>>42650000
         BEGIN                                                          42655000
         SETWAKE'(IOQX);     <<CHECK FOR I/O COMPLETION>>      <<06511>>42660000
         IF = THEN                                                      42665000
            BEGIN          << I/O not completed. >>                     42670000
            CLEARWAKE'(IOQX);     <<RESET WAKE BIT>>           <<06511>>42675000
            GO AOK                                                      42680000
            END                                                         42685000
         END                                                            42690000
      END;            << specific file >>                               42695000
   DEL;  <<DELETE THE PMAP>>                                   <<HM.00>>42700000
                                                                        42705000
   <<*******************************************************>> <<04567>>42710000
   << Obtain IOCB of completed I/O.  If the IOQX is less    >> <<04567>>42715000
   << then zewro, than this is a dummy stub put there by    >> <<04567>>42720000
   << the file system, IPC or the PORT procedures.  In the  >> <<06959>>42725000
   << case of the file system, use the TLOG that is already >> <<06959>>42730000
   << in the ACB when calling IOMOVE.                       >> <<06959>>42735000
   <<*******************************************************>> <<04567>>42740000
                                                               <<04567>>42745000
                                                                        42750000
   IF IOQX = 0 THEN IOEXIT(NOIOPENDING2);                               42755000
   UNKNOWNENTRY := FALSE;     ! We have a specific AFT.        <<07399>>42760000
   IF IOQX > 0 THEN                                                     42765000
      BEGIN               << Real IOQX >>                               42770000
      IOCB := WAITFORIOX'(IOQX);  <<GET IOCB AND CS STATION>>  <<HM.00>>42775000
      STATION := X         << CS station >>                             42780000
      END                                                               42785000
   ELSE  << Dummy IOQX for file system or data comm.        >> <<06959>>42790000
      BEGIN                                                             42795000
      IF CSENTRY THEN FTROUBLE(911);  <<CS request?>>       <<00613>>   42800000
      IOQSTATUS := 1;       << Successful I/O >>               <<04567>>42805000
      DUMMY'IOQX := TRUE;                                      <<06511>>42810000
      END;                                                              42815000
                                                                        42820000
   <<* * * Complete I/O request * * *>>                                 42825000
                                                                        42830000
   IF GLOBAL'FILENUM ! Global FNUM, to to DST. @AFT is OK.     <<06511>>42835000
      THEN EXCHANGEDB(GLOBAL'AFT'DSTN);                        <<06511>>42840000
   AFTIOQX := 0;                                               <<06511>>42845000
   EXCHANGEDB(DSTX);  ! In either case, restore original DB.   <<06511>>42850000
                                                               <<06511>>42855000
   IF CSENTRY THEN                                                      42860000
      BEGIN               << CS line responded >>                       42865000
      TOS := 0D;         << set up call to CSIOWAIT >>                  42870000
      TOS := DSTX;                                                      42875000
      TOS := @AFT;                                                      42880000
      TOS := IOCB;                                                      42885000
      TOS := PMAP;                                                      42890000
      TOS := NOT FBNDVIOL(@TARGET,IOQTLOG,UBND) LAND           <<03059>>42895000
             PMAP.(13:1);                                      <<03059>>42900000
      EXCHANGEDB(0);      << set DB to stack >>                <<06511>>42905000
      AFTIOQX := IOQX;    << CSIOWAIT needs IOQINDEX >>        <<06511>>42910000
      TOS := @STATUS;                                                   42915000
      TOS := @TARGET;                                                   42920000
      TOS := ABSOLUTE(CSIOWAIT);   << CSIOWAIT P-label >>               42925000
      IF = THEN FTROUBLE(777);  << CSIOWAIT not in system.>>            42930000
      ASMB(PCAL 0);                                                     42935000
      TRANSLOG := TOS;     << DB now points to DSTX >>                  42940000
      ERROR := TOS                                                      42945000
      END       << CS line >>                                           42950000
   ELSE IF MSGENTRY THEN                                       <<06146>>42955000
      BEGIN  <<MESSAGE FILE>>                                  <<HM.00>>42960000
      LOC'ACB(*,ACBMQ,FILENUM,UMODE);                          <<HM.00>>42965000
      IF ACB'READ THEN                                         <<06511>>42970000
         BEGIN                                                 <<HM.00>>42975000
         IF NOBUFSPEC THEN                                     <<HM.00>>42980000
            BEGIN                                              <<HM.00>>42985000
            ACB'ERROR:=OMITTEDPARM;                            <<06511>>42990000
            ACB'TLOG:=0;                                       <<06511>>42995000
            TOS:=CCL; TOS:=0;                                  <<03038>>43000000
            END                                                <<HM.00>>43005000
         ELSE                                                  <<HM.00>>43010000
            FCREAD(IOCOMPLETION,TARGET,0)                      <<HM.00>>43015000
         END                                                   <<HM.00>>43020000
      ELSE                                                     <<HM.00>>43025000
         FCWRITE(IOCOMPLETION,DUM,0);                          <<01898>>43030000
      UNLOC'ACB(ACBMQ,0);                                      <<HM.00>>43035000
      IF S0 <> 0 THEN FCAWAKEN(*) ELSE DEL;                    <<03038>>43040000
      CONDCODE:=TOS;                                           <<HM.00>>43045000
      TRANSLOG:=ACB'TLOG;                                      <<06511>>43050000
      ERROR:=ACB'ERROR;                                        <<06511>>43055000
      END                                                      <<HM.00>>43060000
   ELSE IF FSENTRY THEN                                                 43065000
      BEGIN      << Conventional FS file responded >>                   43070000
      LOC'ACB(*,ACBMQ,FILENUM,UMODE);  << get ACB >>           <<HM.00>>43075000
                                                               <<04567>>43080000
      << For the dummy IOQX case, leave the ACB'TLOG as it  >> <<04567>>43085000
      << was.  The proper value was already there.          >> <<04567>>43090000
                                                               <<04567>>43095000
      IF NOT DUMMY'IOQX                                        <<06511>>43100000
         THEN ACB'TLOG := IOQTLOG;                             <<04567>>43105000
      ACB'STATUS := IOQSTATUS; << Set I/O status >>            <<04567>>43110000
      TOS := %40+ACB'NOWAITMODE;  << complete I/O >>                    43115000
      TOS := @TARGET;      << for :EOD test only >>                     43120000
      TOS := ACB'TLOG;    << TCOUNT - for sign >>              <<01698>>43125000
      IOMOVE(*,*,*);         << Complete the I/O >>                     43130000
      IF ACB'GSTATUS = 1 THEN                                           43135000
         BEGIN          << Successful I/O. >>                           43140000
         IF ACB'ERROR = TAPERREC OR  <<recovered tape error?>>          43145000
            READ AND (ACB'ERROR = EOL) OR  <<EOL after read?>>          43150000
            WRITE AND (ACB'ERROR = EOT) THEN  <<EOT after W?>>          43155000
            TOS := CCL    << report error >>                            43160000
         ELSE       << Really OK >>                                     43165000
            TOS := CCE                                                  43170000
         END                                                            43175000
      ELSE       << I/O error. >>                                       43180000
         TOS := ACBSTATUSCODE;  << Report condition code >>             43185000
                                                                        43190000
      <<* * * Measure data on IOWAIT * * *>>                            43195000
                                                                        43200000
$  IF X3 = ON                                                           43205000
      IF MEAS'TAPE'ON THEN BEGIN                                        43210000
      IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                    43215000
         MMSTAT'(EIOWAIT,FILENUM,ACB'TLOG,ACB'HIT,0,0,0);      <<06958>>43220000
      END; << OF MEAS'TAPE'ON>>                                         43225000
$  IF                                                                   43230000
                                                                        43235000
      CONDCODE := TOS;     << report condition code >>                  43240000
      TRANSLOG := ACB'TLOG;                                             43245000
      ERROR := ACB'ERROR;                                               43250000
      UNLOC'ACB(ACBMQ,0);     << release ACB >>                <<HM.00>>43255000
      END        << conventional file >>                                43260000
   ELSE IF DSENTRY THEN                                        <<00183>>43265000
      BEGIN      << DS line responded. >>                               43270000
      TOS := IOCB;       << TLOG and status >>                          43275000
      TRANSLOG := TOS;                                                  43280000
      IF S0.(8:8) = 1 THEN TOS.(15:1) := 0;  << no error. >>   <<DS.06>>43285000
      ERROR := TOS;      << I/O status >>                               43290000
      CONDCODE := IF ERROR.(8:8) = 0 THEN CCE ELSE CCL                  43295000
      END                                                               43300000
   ELSE IF TTSENTRY THEN                                       <<00183>>43305000
      BEGIN     << 3270 I/O completed. >>                      <<00183>>43310000
      TOS := 0;        << for result of TRANSLATE ERROR call >><<00183>>43315000
      TOS := 2;        << select ERROR TRANSLATE function >>   <<00421>>43320000
      TOS := IOCB;     << TLOG and status >>                   <<00421>>43325000
      TRANSLOG := TOS;    << count >>                          <<00421>>43330000
      TOS := PLABEL3270;                                       <<01165>>43335000
      IF = THEN FTROUBLE(53);    << 3270 not installed. >>     <<01910>>43340000
      ASMB(PCAL 0);    << STATION := PLABEL3270(STATUS,2); >>  <<00183>>43345000
      STATION := TOS;                                          <<00183>>43350000
      ERROR := 0;      << Always OK >>                         <<00183>>43355000
      CONDCODE := IF STATION = 0 THEN CCE ELSE CCL;            <<00183>>43360000
      END                                                      <<06959>>43365000
    ELSE IF PORTENTRY THEN                                     <<06959>>43370000
      BEGIN                                                    <<06959>>43375000
      IOWAITDISPATCHER(IOQX);                                  <<06959>>43380000
      IOWAIT := FILENUM;                                       <<06959>>43385000
      GOTO EXIT;    << Port dispatcher returned parameters. >> <<06959>>43390000
      END;                                                     <<06959>>43395000
                                                                        43400000
   <<* * * Return parameters to caller * * *>>                          43405000
                                                                        43410000
   IOWAIT := FILENUM;     << file/line nr. responding >>                43415000
   IF PMAP.(14:1) THEN TCOUNT := \TRANSLOG\;                            43420000
   IF PMAP THEN CSTATION := STATION;  << CS station responding >>       43425000
                                                                        43430000
EXIT:                                                                   43435000
   RESETCRITICAL(CRIT);                                                 43440000
   ERROREXIT(5,ERROR,0)                                                 43445000
   END;            << procedure IOWAIT >>                               43450000
$PAGE " FREADSEEK "                                                     43455000
$CONTROL SEGMENT = FILESYS2   << FREADSEEK >>                           43460000
PROCEDURE FREADSEEK(FILENUM,REC);                              <<KS.00>>43465000
VALUE FILENUM,REC;                                                      43470000
INTEGER FILENUM;                                                        43475000
DOUBLE REC;                                                             43480000
OPTION PRIVILEGED;                                                      43485000
   BEGIN                                                                43490000
   INTEGER POINTER AFT;      << for KSAM >>                    <<KS.00>>43495000
   DOUBLE SAVE'FPTR;      << for ACB'FPTR >>                            43500000
   INTEGER CRIT;        << for SETCRITICAL >>                           43505000
   INTEGER REC0 = REC + 0,                                     <<06958>>43510000
           REC1 = REC + 1;                                     <<06958>>43515000
                                                                        43520000
   << Remote file access (RFA) variables: >>                            43525000
                                                                        43530000
   INTEGER POINTER RFAPTR;     << appendage pointer >>                  43535000
   INTEGER RFALEN;             << appendage length >>                   43540000
                                                               <<DS.00>>43545000
<< Following LOC'ACB params must be last and in order: >>               43550000
   INTEGER ACBMQ;                                              <<06511>>43555000
   INTEGER AFTE;       << AFT entry word 0 >>                           43560000
   DOUBLE  PACBV;                                              <<06511>>43565000
   DOUBLE  LACBV;                                              <<06511>>43570000
   INTEGER IOQX;                                                        43575000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>43580000
   BUILD'ACB;                                                           43585000
   LOGICAL DSTX;      << DST nr. of user's buffer >>                    43590000
<< end of LOCACB params >>                                              43595000
                                                                        43600000
$  IF X0 = ON                                                           43605000
   IF MONCALLABLE THEN                                                  43610000
      BEGIN       << monitoring >>                                      43615000
      FTITLE("FREA","DSEE","K   ",0D);                                  43620000
      DEBUG                                                             43625000
      END;                                                              43630000
$  IF                                                                   43635000
                                                                        43640000
   ERRORON;                                                             43645000
   CRIT := SETCRITICAL;                                                 43650000
   GET'ACB'Q'LOC;                                              <<06511>>43655000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);   << get ACB >>             <<06511>>43660000
   IF < THEN                                                            43665000
      BEGIN         << Invalid file number. >>                          43670000
      TOS := INVFN;                                                     43675000
      TOS := CCL;                                                       43680000
      GO EXIT                                                           43685000
      END;                                                              43690000
   IF > THEN                                                            43695000
      BEGIN          << File is $NULL >>                                43700000
      TOS := 0;      << No error >>                                     43705000
      TOS := CCE;                                                       43710000
      GO EXIT                                                           43715000
      END;                                                              43720000
   CASE * FTYPE OF                                                      43725000
   BEGIN                                                                43730000
                                                                        43735000
   BEGIN     << conventional file >>                                    43740000
   IF IOQX <> 0 THEN                                                    43745000
      BEGIN           << No-wait I/O pending. >>                        43750000
      TOS := IOPENDING;                                                 43755000
      GO NFG                                                            43760000
      END;                                                              43765000
   IF ACB'ACCCL <> DIRACC OR ACB'SPOOLED THEN                           43770000
      BEGIN         << FREADSEEK invalid unless disk file. >>           43775000
      TOS := DEVVIOL;                                                   43780000
      GO NFG                                                            43785000
      END;                                                              43790000
   IF ACB'VARIABLE OR ACB'INHIBITBUF OR (1 <= ACB'ACTYPE <= 3) THEN     43795000
      BEGIN                                                             43800000
      TOS := ACCVIOL;                                                   43805000
NFG:  ACB'ERROR := S0;                                                  43810000
      TOS := CCL;         << error condition code >>                    43815000
      GO UNLK;                                                          43820000
      END;                                                              43825000
   SAVE'FPTR := ACB'FPTR;                                               43830000
   ACB'FPTR := REC;                                                     43835000
   IOMOVE(%10,DUM,0);      << start the read. >>                        43840000
   ACB'FPTR := SAVE'FPTR;                                               43845000
   TOS := ACB'ERROR;        << error nr. >>                             43850000
   TOS := ACBSTATUSCODE;    << condition code to report >>              43855000
                                                                        43860000
   <<* * * Measurement data on FREADSEEK * * *>>                        43865000
                                                                        43870000
$  IF X3 = ON                                                           43875000
   IF MEAS'TAPE'ON THEN BEGIN                                           43880000
   IF S0.(14:2) = CCE AND ACB'ACCCL = DIRACC THEN                       43885000
      MMSTAT'(EFREADSEEK,FILENUM,ACB'HIT,REC0,REC1,0,0);       <<06958>>43890000
   END;       << of MEAS'TAPE'ON>>                                      43895000
$  IF                                                                   43900000
                                                                        43905000
UNLK:                                                                   43910000
   UNLOC'ACB(ACBMQ,0);    << release ACB >>                    <<06511>>43915000
   END;       << conventional file >>                                   43920000
                                                                        43925000
   BEGIN      << remote file >>                                <<DS.00>>43930000
   SETRFAPTR;                                                  <<DS.00>>43935000
   RFALEN := 6;                                                <<DS.00>>43940000
   TOS := "RFA ";                                              <<DS.00>>43945000
   TOS := 5;                                                   <<DS.04>>43950000
   TOS := RFAFILE;                                             <<DS.00>>43955000
   TOS := REC;                                                 <<DS.00>>43960000
   MWCNOBUF;                                                   <<DS.00>>43965000
   CHECKXFER;                                                  <<DS.00>>43970000
   DELAPPENDAGE;                                               <<DS.00>>43975000
   PREPRETURN;                                                 <<DS.00>>43980000
   END;     << remote file >>                                           43985000
                                                                        43990000
      << dummy 2 >>;                                                    43995000
      << dummy 3 >>;                                                    44000000
      << dummy 4 >>;                                                    44005000
      << dummy 5 >>;                                                    44010000
   BEGIN        << KSAM file >>                                         44015000
   DSTX := EXCHANGEDB(0);      << to stack >>                  <<KS.00>>44020000
   SETAFT;                                                     <<KS.00>>44025000
   AFTFLAG := 3;   << KSAM error. >>                           <<KS.00>>44030000
   AFTERRNUM := UNIMPL;    <<"Unimplemented">>                 <<KS.00>>44035000
   TOS := UNIMPL;          << "Unimplemented" >>               <<KS.00>>44040000
   TOS := CCL;                                                 <<KS.00>>44045000
   EXCHANGEDB(DSTX);       << restore >>                       <<KS.00>>44050000
   END;       << KSAM >>                                       <<KS.00>>44055000
   <<DUMMY 7>>;                                                <<HM.00>>44060000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>44065000
   TOS:=ACCVIOL;                                               <<HM.00>>44070000
   GO NFG;                                                     <<HM.00>>44075000
   END;                                                        <<HM.00>>44080000
   END;       << FTYPE CASE >>                                 <<DS.00>>44085000
                                                                        44090000
EXIT:                                                                   44095000
   CONDCODE := TOS;    << report condition code >>                      44100000
   RESETCRITICAL(CRIT);                                                 44105000
   ERROREXIT(3,S0,0)                                                    44110000
   END;       << procedure FREADSEEK >>                                 44115000
$PAGE " FSPACE "                                                        44120000
$CONTROL SEGMENT = FILESYS2   << FSPACE >>                              44125000
PROCEDURE FSPACE(FILENUM,DSPL);                                         44130000
VALUE FILENUM,DSPL;                                                     44135000
INTEGER FILENUM,DSPL;                                                   44140000
OPTION PRIVILEGED;                                                      44145000
   BEGIN                                                                44150000
   INTEGER CRIT;     << for SETCRITICAL >>                              44155000
   INTEGER ERR;      << error nr. >>                                    44160000
   INTEGER I;                                                           44165000
      LOGICAL LI = I;                                          <<02545>>44170000
   DOUBLE NEWPOS;                                                       44175000
                                                                        44180000
   << Remote file access (RFA) variables: >>                   <<DS.00>>44185000
                                                                        44190000
   INTEGER POINTER RFAPTR;    << appendage pointer >>          <<DS.00>>44195000
   INTEGER RFALEN;            << appendage length >>           <<DS.00>>44200000
                                                                        44205000
<< Following LOC'ACB params must be last and in order: >>               44210000
   INTEGER ACBMQ;                                              <<04591>>44215000
   INTEGER AFTE;      << AFT entry word 0 >>                            44220000
   DOUBLE  PACBV;                                              <<06511>>44225000
   DOUBLE  LACBV;                                              <<06511>>44230000
   INTEGER IOQX;                                                        44235000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q + ACBMQ >>     <<04591>>44240000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        44245000
   BUILD'ACB;                                                           44250000
   LOGICAL DSTX;     << DST nr. of user's buffer >>                     44255000
<< End of LOC'ACB params >>                                             44260000
                                                                        44265000
SUBROUTINE ATTIO(FUNC);                                        <<02693>>44270000
VALUE FUNC; INTEGER FUNC;                                      <<02693>>44275000
   << Shortcut to call ATTACHIO. >>                            <<02693>>44280000
                                                               <<02693>>44285000
   BEGIN                                                       <<02693>>44290000
   TOS := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,0,4,BFLAGS);         <<02693>>44295000
   ASMB(DEL,DUP);                                              <<02693>>44300000
   IF TOS.(8:8) <> 1 THEN                                      <<02693>>44305000
      BEGIN         << ATTACHIO reports error. >>              <<02693>>44310000
      ASMB(ZERO,XCH);    << for result of IOSTAT >>            <<02693>>44315000
      TOS := IOSTAT(*);                                        <<02693>>44320000
      ASMB(TEST);                                              <<02693>>44325000
      IF <> AND S0 <> EOT AND S0 <> TAPERREC THEN GO NFG;      <<02712>>44330000
      END;                                                     <<02693>>44335000
   DEL;                                                        <<02693>>44340000
   END;            << subroutine ATTIO >>                      <<02693>>44345000
   SUBROUTINE TAPEFUNC(FUNC);                                  <<02693>>44350000
      << Performs the specified mag tape function.                      44355000
        Input variables:                                                44360000
            FUNC - ATTACHIO function. 11=FSR, 12=BSR.                   44365000
      >>                                                                44370000
   VALUE FUNC; INTEGER FUNC;                                   <<02693>>44375000
                                                               <<02693>>44380000
      BEGIN   << Do function, wait for completion >>                    44385000
      TOS := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,0,0,BFLAGS);      <<02693>>44390000
      IF S1STAT <> 1 THEN                                               44395000
         BEGIN    << Woops! Error. >>                                   44400000
         IF ACB'LABELLED AND S1STAT=EOFSTAT THEN               <<00901>>44405000
            BEGIN      << Handle EOF on labeled tape. >>       <<02545>>44410000
            IF S3 = 12 THEN    << BSR >>                       <<02693>>44415000
              ATTIO(11)     << FSR over TM: stay in data >>    <<02545>>44420000
            ELSE               << FSR >>                       <<02545>>44425000
              BEGIN     << FSR at EOF/EOV. Seek next volume >> <<02545>>44430000
              REELSWITCH(ACB'DADDR,0);                         <<02545>>44435000
              IF < THEN S1 := NAVLSTAT ELSE IF = THEN          <<02545>>44440000
                BEGIN       << Switched reels. Position >>     <<02545>>44445000
                ACB'BTFRCT := 0D;                              <<06511>>44450000
                TAPEFUNC(11);   << FSR over 1st record. >>     <<02693>>44455000
                GO ARND2;                                      <<02545>>44460000
                END;                                           <<02693>>44465000
                << If CCG, then report EOF. >>                 <<02693>>44470000
              END;                                             <<02545>>44475000
            END;     << handle EOF on labeled tape >>          <<00901>>44480000
         ASMB(XCH,ZROB);                                                44485000
         TOS := IOSTAT(*);    << convert error nr. >>                   44490000
         IF S0 = BOT AND ACB'DTYPE = MTAPE THEN                <<02545>>44495000
            SET'LPDT'BOT(ACB'DADDR,1);                         <<02545>>44500000
         ASMB(TEST);          << 0 = EOF. >>                            44505000
         IF = THEN GO E2;   << Report CCG on TM >>             <<02693>>44510000
         GO NFG;            << Some other error. Gripe >>      <<02693>>44515000
         END;     << error >>                                           44520000
ARND2:                                                         <<00901>>44525000
      DDEL;      << ATTACHIO results >>                        <<02545>>44530000
      END;        << subroutine TAPEFUNC >>                             44535000
$  IF X0 = ON                                                           44540000
   IF MONCALLABLE THEN                                                  44545000
      BEGIN      << Monitoring >>                                       44550000
      FTITLE("FSPA","CE  ",0D,0D);                                      44555000
      DEBUG                                                             44560000
      END;                                                              44565000
$  IF                                                                   44570000
                                                                        44575000
   <<* * * Build an ACB  * * *>>                                        44580000
                                                                        44585000
   ERRORON;                                                             44590000
   CRIT := SETCRITICAL;                                                 44595000
   GET'ACB'Q'LOC;                                              <<04591>>44600000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);    << get ACB >>            <<04591>>44605000
   IF < THEN                                                            44610000
      BEGIN         << Invalid file nr. >>                              44615000
      TOS := CCL;                                                       44620000
      TOS := INVFN;                                                     44625000
      GO EXIT                                                           44630000
      END;                                                              44635000
   IF > THEN                                                            44640000
      BEGIN         << File is $NULL. Report EOF  >>                    44645000
      TOS := CCG;                                                       44650000
      TOS := 0;    << no error >>                                       44655000
      GO EXIT                                                           44660000
      END;                                                              44665000
                                                                        44670000
   <<* * * Space file * * *>>                                           44675000
                                                                        44680000
   CASE * FTYPE OF                                                      44685000
   BEGIN                                                                44690000
                                                                        44695000
   BEGIN     << conventional file >>                                    44700000
   IF IOQX <> 0 THEN                                                    44705000
      BEGIN         << No-Wait I/O pending >>                           44710000
      TOS := IOPENDING;                                                 44715000
      GO NFG                                                            44720000
      END;                                                              44725000
   IF ACB'SPOOLED THEN                                                  44730000
      BEGIN        << Can't space spoofles. >>                          44735000
      TOS := SPOOLILLOP;                                                44740000
      GO NFG;                                                           44745000
      END;                                                              44750000
   IF ACB'VARIABLE OR ACB'APPEND THEN                          <<06511>>44755000
      BEGIN     << Illegal access. >>                                   44760000
      TOS := ACCVIOL;                                                   44765000
      GO NFG                                                            44770000
      END;                                                              44775000
   ACB'ERROR := 0;                                                      44780000
   IF ACB'ACCCL = DIRACC THEN                                           44785000
      BEGIN      << Disk >>                                             44790000
      IF ACB'CIRFILE AND NOT ACB'READ THEN                     <<06511>>44795000
         BEGIN                                                 <<HM.00>>44800000
         TOS:=ACCVIOL;                                         <<HM.00>>44805000
         GO NFG;                                               <<HM.00>>44810000
         END;                                                  <<HM.00>>44815000
                                                               <<04950>>44820000
      NEWPOS := DOUBLE(DSPL);                                  <<04950>>44825000
      IF ACB'INHIBITBUF THEN  << unbuffered access? >>                  44830000
         NEWPOS := NEWPOS*DOUBLE(ACB'BLKFACT)                  <<04950>>44835000
      ELSE  IF NOT ACB'RIO  THEN       << Buffered access >>   <<04450>>44840000
         FQUIESCE'IO(0);       << Complete any pending I/O >>           44845000
      NEWPOS := ACB'FPTR+NEWPOS;  << New pointer value.     >> <<04561>>44850000
      IF < THEN NEWPOS := 0D;     << before beginning of file?>>        44855000
      IF ACB'FCB=0D AND NEWPOS >= DISCSIZE(ACB'DADDR) OR       <<06511>>44860000
         ACB'FCB <> 0D AND                                     <<06511>>44865000
         NEWPOS >= GETFCB'INFO(ACB'FCB,XFLIM) THEN             <<06511>>44870000
         BEGIN              << Beyond file limit. >>                    44875000
E2:      TOS := CCG;        << EOF condition code >>                    44880000
         TOS := 0;          << no error >>                              44885000
         GO UNLK                                                        44890000
         END;                                                           44895000
      TOS := NEWPOS;                                                    44900000
      ACB'FPTR := DS1;       << update >>                               44905000
      X := ACB'BLKFACT;                                                 44910000
      DIVD'DEL;                                                         44915000
      ACB'HIBLK := TOS-1D;  << update high block nr. >>        <<06511>>44920000
                                                                        44925000
      IF ACB'RIO AND NOT ACB'INHIBITBUF THEN  << get activity  <<02054>>44930000
         IOMOVE(%50,DUM,0);                                             44935000
                                                                        44940000
      <<* * * Measurement data on FSPACE * * *>>                        44945000
                                                                        44950000
$  IF X3 = ON                                                           44955000
      IF MEAS'TAPE'ON THEN BEGIN                                        44960000
      MMSTAT'(EFSPACE,FILENUM,DSPL,0,0,0,0)                    <<06958>>44965000
      END; << OF MEAS'TAPE'ON>>                                         44970000
$  IF                                                                   44975000
      END      << disk >>                                               44980000
                                                                        44985000
   ELSE IF ACB'ACCCL = SERIALIO OR ACB'DTYPE = SDISC THEN               44990000
      BEGIN               << Magnetic tape or serial disk >>            44995000
      TOS := DSPL;                                                      45000000
      IF > THEN                                                         45005000
         BEGIN                                                 <<02545>>45010000
         TOS := 11;    << Forward space: FSR >>                <<02545>>45015000
         END                                                   <<02545>>45020000
      ELSE                                                              45025000
         BEGIN     << space backward >>                                 45030000
         TOS := -TOS;  << make displacement positive >>                 45035000
         TOS := 12    << BSR code >>                                    45040000
         END;                                                           45045000
      I := TOS;      << FSR/BSR code >>                                 45050000
      DSPL := TOS;   << positive displacement >>                        45055000
                                                               <<04591>>45060000
      <<****************************************************>> <<04591>>45065000
      << Before FSPACING, we must back space over all pre-  >> <<04591>>45070000
      << reads based on the value of ACB'TAPEDISP, obtained >> <<04591>>45075000
      << from FQUIESCE'IO, which counts them. In this way,  >> <<04591>>45080000
      << the head points to the correct current block.      >> <<04591>>45085000
      <<****************************************************>> <<04591>>45090000
                                                               <<04591>>45095000
      IF NOT ACB'INHIBITBUF THEN                                        45100000
         BEGIN        << Buffered access >>                             45105000
         TOS := FQUIESCE'IO(FALSE); << TOS MUST MUST be used>> <<04591>>45110000
         ACB'TAPEDISP := TOS; << so the ACB is at Q-62!!!!! >> <<04591>>45115000
         IF ACB'NEWEOF THEN                                    <<04591>>45120000
            BEGIN                                              <<04591>>45125000
            ACB'TAPEDISP := 0;<< No pre-reads were performed>> <<04591>>45130000
            END                                                <<04591>>45135000
         ELSE                                                  <<04591>>45140000
            WHILE ACB'TAPEDISP > 0 DO                          <<04591>>45145000
               BEGIN                                           <<04591>>45150000
               ATTIO(12);    << Back Space Record >>           <<04591>>45155000
               ACB'TAPEDISP := ACB'TAPEDISP - 1;               <<04591>>45160000
               END;                                            <<04591>>45165000
         END;      << buffered access >>                                45170000
      IF ACB'NEWEOF AND LI THEN                                <<02545>>45175000
         BEGIN     << Forward space after Write loses. >>      <<02545>>45180000
         TOS := INVOP;                                         <<02545>>45185000
         GO NFG;                                               <<02545>>45190000
         END;                                                  <<02545>>45195000
      IF ACB'DTYPE = MTAPE AND LI AND DSPL <> 0 THEN           <<02545>>45200000
         SET'LPDT'BOT(ACB'DADDR,0);                            <<02545>>45205000
      IF ACB'LABELLED THEN                                     <<02545>>45210000
         BEGIN                                                 <<02545>>45215000
         TOS := CHECKUL(FILENUM,6,ACB'NEWEOF&LSL(1)            <<02545>>45220000
            +(LI LAND 1));                                     <<02545>>45225000
         IF < THEN GO NFG;    << error >>                      <<02545>>45230000
         DEL;                                                  <<02545>>45235000
         END                                                   <<02545>>45240000
      ELSE IF ACB'NEWEOF THEN                                  <<02545>>45245000
         BEGIN    << Backspace after write: TM needed. >>               45250000
         ATTIO(6);      << WTM >>                              <<02693>>45255000
         ATTIO(12);     << BSR over it >>                      <<02693>>45260000
         END;                                                  <<02545>>45265000
      ACB'NEWEOF := 0;      << clear EOF Needed flag >>        <<02545>>45270000
      TOS := DSPL;                                                      45275000
      WHILE <> DO                                                       45280000
         BEGIN      << Space tape per request >>                        45285000
         TAPEFUNC(I);     << FSR or BSR >>                     <<02693>>45290000
         TOS := TOS-1                                                   45295000
         END;                                                           45300000
      ACB'FPTR := 0D;                                                   45305000
      ACB'HIBLK := -1D                                         <<06511>>45310000
      END      << mag tape or serial disk >>                            45315000
   ELSE                                                                 45320000
      BEGIN       << Other devices lose. >>                             45325000
      TOS := DEVVIOL;                                                   45330000
NFG:  TOS := CCL;                                                       45335000
      ACB'ERROR := S1;                                                  45340000
      ASMB(XCH);                                               <<HM.00>>45345000
      GO UNLK;                                                          45350000
      END;                                                              45355000
   TOS := CCE;    << OK condition code >>                               45360000
   TOS := 0;      << no error >>                                        45365000
                                                                        45370000
UNLK:                                                                   45375000
   UNLOC'ACB(ACBMQ,0);     << release ACB >>                   <<04591>>45380000
   END;       << conventional file >>                                   45385000
                                                                        45390000
   BEGIN    << Remote file >>                                           45395000
   SETRFAPTR;                                                  <<DS.00>>45400000
   RFALEN := 5;                                                <<DS.00>>45405000
   TOS := "RFA ";                                              <<DS.00>>45410000
   TOS := 11;                                                  <<DS.00>>45415000
   TOS := RFAFILE;                                             <<DS.00>>45420000
   TOS := DSPL;                                                <<DS.00>>45425000
   MWCNOBUF;                                                   <<DS.00>>45430000
   IF <> THEN                                                  <<DS.00>>45435000
      BEGIN                                                    <<DS.00>>45440000
      TOS := CCL;                                              <<DS.00>>45445000
      TOS := 0;                                                <<DS.00>>45450000
      TOS := RFALINE;                                          <<DS.00>>45455000
      TOS := DSCHKPLABEL;                                      <<DS.00>>45460000
      ASMB(PCAL 0);                                            <<DS.00>>45465000
$  IF X1 = ON                                                           45470000
      IF <> THEN FTROUBLE(486);                                         45475000
$  IF                                                                   45480000
      GO EXIT;                                                 <<DS.00>>45485000
      END;                                                     <<DS.00>>45490000
   DELAPPENDAGE;                                               <<DS.00>>45495000
   TOS := TOS.CC;     << return condition code >>              <<DS.00>>45500000
   TOS := 0;                                                   <<DS.00>>45505000
   END;    << remote file >>                                            45510000
                                                                        45515000
      << dummy 2 >>;                                                    45520000
      << dummy 3 >>;                                                    45525000
      << dummy 4 >>;                                                    45530000
      << dummy 5 >>;                                                    45535000
   BEGIN    << KSAM file >>                                             45540000
   KSPACE(FILENUM,DSPL);                                       <<KS.00>>45545000
   PUSH(STATUS);                                               <<KS.00>>45550000
   TOS := TOS.CC;                                              <<KS.00>>45555000
   TOS := 0;    << Show no error number >>                     <<KS.00>>45560000
   END;       << KSAM file >>                                  <<KS.00>>45565000
   <<DUMMY 7>>;                                                <<HM.00>>45570000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>45575000
   TOS:=ACCVIOL;                                               <<HM.00>>45580000
   GO NFG;                                                     <<HM.00>>45585000
   END;                                                        <<HM.00>>45590000
   END;      << FTYPE case >>                                           45595000
                                                                        45600000
EXIT:                                                                   45605000
   ERR := TOS;       << error number >>                                 45610000
   CONDCODE := TOS;  << condition code to report >>                     45615000
   RESETCRITICAL(CRIT);                                                 45620000
   ERROREXIT(2,ERR,0)                                                   45625000
   END;        << procedure FSPACE >>                                   45630000
$PAGE " FPOINT "                                                        45635000
$CONTROL SEGMENT = FILESYS2   << FPOINT >>                              45640000
PROCEDURE FPOINT(FILENUM,RECNUM);                                       45645000
VALUE FILENUM,RECNUM;                                                   45650000
INTEGER FILENUM;                                                        45655000
DOUBLE RECNUM;                                                          45660000
OPTION PRIVILEGED;                                                      45665000
   BEGIN                                                                45670000
   INTEGER CRIT;       << for SETCRITICAL >>                            45675000
                                                                        45680000
   << Remote file access (RFA) variables: >>                            45685000
                                                                        45690000
   INTEGER POINTER RFAPTR;    << appendage pointer >>          <<DS.00>>45695000
   INTEGER RFALEN;            << appendage length >>           <<DS.00>>45700000
                                                                        45705000
<< Following LOC'ACB params must be last and in order: >>               45710000
   INTEGER ACBMQ;                                              <<04591>>45715000
   INTEGER AFTE;      << AFT entry word 0 >>                            45720000
   DOUBLE  PACBV;                                              <<06511>>45725000
   DOUBLE  LACBV;                                              <<06511>>45730000
   INTEGER IOQX;                                                        45735000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q + ACBMQ >>     <<04591>>45740000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        45745000
   BUILD'ACB;                                                           45750000
   LOGICAL DSTX;     << User's DST nr. >>                               45755000
                                                                        45760000
$  IF X0 = ON                                                           45765000
   IF MONCALLABLE THEN                                                  45770000
      BEGIN       << Monitoring >>                                      45775000
      FTITLE("FPOI","NT  ",0D,0D);                                      45780000
      DEBUG                                                             45785000
      END;                                                              45790000
$  IF                                                                   45795000
                                                                        45800000
   ERRORON;                                                             45805000
   CRIT := SETCRITICAL;                                                 45810000
   GET'ACB'Q'LOC;                                              <<04591>>45815000
                                                               <<04591>>45820000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);    << get ACB >>            <<04591>>45825000
   IF < THEN                                                            45830000
      BEGIN       << Invalid file nr. >>                                45835000
      TOS := INVFN;                                                     45840000
      TOS := CCL;                                                       45845000
      GO EXIT                                                           45850000
      END;                                                              45855000
   IF > THEN                                                            45860000
      BEGIN        << File is $NULL >>                                  45865000
      TOS := 0;    << report No Error >>                                45870000
      TOS := CCE;                                                       45875000
      GO EXIT                                                           45880000
      END;                                                              45885000
   CASE * FTYPE OF                                                      45890000
   BEGIN                                                                45895000
                                                                        45900000
   BEGIN      << Conventional file >>                                   45905000
   IF IOQX <> 0 THEN                                                    45910000
      BEGIN        << No-wait I/O pending. >>                           45915000
      TOS := IOPENDING;                                                 45920000
      GO NFG                                                            45925000
      END;                                                              45930000
   IF ACB'ACCCL <> DIRACC THEN                                          45935000
      BEGIN          << Not disk. Boo! >>                               45940000
      TOS := DEVVIOL;                                                   45945000
      GO NFG                                                            45950000
      END;                                                              45955000
   IF ACB'VARIABLE OR ACB'APPEND                               <<06511>>45960000
      OR ACB'CIRFILE AND NOT ACB'READ THEN                     <<06511>>45965000
      BEGIN       << Illegal access. >>                                 45970000
      TOS := ACCVIOL;                                                   45975000
NFG:  ACB'ERROR := S0;  << save error nr. in ACB >>                     45980000
      TOS := CCL;     << Report error condition >>                      45985000
      GO UNLK;                                                          45990000
      END;                                                              45995000
   IF ACB'INHIBITBUF THEN                                               46000000
      BEGIN        << NOBUF access >>                                   46005000
      TOS := RECNUM;      << Block number! >>                           46010000
      X := ACB'BLKFACT;                                                 46015000
      MPYD;         << Get record number >>                             46020000
      RECNUM := TOS                                                     46025000
      END                                                               46030000
   ELSE  IF NOT ACB'RIO  THEN      << Buffered access >>       <<04450>>46035000
      FQUIESCE'IO(0);  << complete any pending I/O >>                   46040000
   IF RECNUM < 0D THEN                                         <<02068>>46045000
      BEGIN                                                    <<02068>>46050000
      TOS := BADRECNO;                                         <<02068>>46055000
      ACB'ERROR := S0;                                         <<02068>>46060000
      TOS := CCL;                                              <<02068>>46065000
      GO UNLK;                                                 <<02068>>46070000
      END                                                      <<02068>>46075000
   ELSE IF                                                     <<02068>>46080000
      ACB'FCB = 0D AND RECNUM >= DISCSIZE(ACB'DADDR) OR        <<06511>>46085000
      ACB'FCB<>0D AND RECNUM >= GETFCB'INFO(ACB'FCB,XFLIM) THEN<<06511>>46090000
      BEGIN       << Out of bounds; report EOF. >>                      46095000
      TOS := EOF;                                                       46100000
      ACB'ERROR := S0;                                                  46105000
      TOS := CCG;                                                       46110000
      GO UNLK;                                                          46115000
      END;                                                              46120000
   TOS := RECNUM;                                                       46125000
   ACB'FPTR := DS1;     << Set record pointer >>                        46130000
   X := ACB'BLKFACT;                                                    46135000
   DIVD'DEL;                                                            46140000
   ACB'HIBLK := TOS-1D;  << Set block nr. for pre-reads >>     <<06511>>46145000
   IF ACB'RIO AND NOT ACB'INHIBITBUF THEN  << get activity >>  <<02054>>46150000
      IOMOVE(%50,DUM,0);                                                46155000
                                                                        46160000
   <<* * * Measurement data on FPOINT * * *>>                           46165000
                                                                        46170000
$  IF X3 = ON                                                           46175000
   IF MEAS'TAPE'ON THEN BEGIN                                           46180000
   TOS := EFPOINT;     << event nr. >>                                  46185000
   TOS := FILENUM;                                                      46190000
   TOS := RECNUM;                                                       46195000
   MMSTAT'(*,*,*,*,0,0,0);                                     <<06958>>46200000
   END; << OF MEAS'TAPE'ON>>                                            46205000
$  IF                                                                   46210000
                                                                        46215000
   TOS := 0;     << No error >>                                         46220000
   TOS := CCE;  << condition code to report >>                          46225000
UNLK:                                                                   46230000
   UNLOC'ACB(ACBMQ,0);     << release ACB >>                   <<04591>>46235000
   END;      << conventional file >>                                    46240000
                                                                        46245000
   BEGIN    << remote file >>                                           46250000
   SETRFAPTR;                                                  <<DS.00>>46255000
   RFALEN := 6;                                                <<DS.00>>46260000
   TOS := "RFA ";                                              <<DS.00>>46265000
   TOS := 12;                                                  <<DS.00>>46270000
   TOS := RFAFILE;                                             <<DS.00>>46275000
   TOS := RECNUM;                                              <<DS.00>>46280000
   MWCNOBUF;                                                   <<DS.00>>46285000
   CHECKXFER;                                                  <<DS.00>>46290000
   DELAPPENDAGE;                                               <<DS.00>>46295000
   PREPRETURN;                                                 <<DS.00>>46300000
   END;     << remote file >>                                           46305000
      << dummy 2 >>;                                                    46310000
      << dummy 3 >>;                                                    46315000
      << dummy 4 >>;                                                    46320000
      << dummy 5 >>;                                                    46325000
   BEGIN         << KSAM file >>                                        46330000
   KPOINT(FILENUM,RECNUM);                                     <<KS.00>>46335000
   PUSH(STATUS);                                               <<KS.00>>46340000
   TOS := TOS.CC;    << return condition code >>               <<KS.00>>46345000
   ASMB(ZERO,XCH);                                             <<KS.00>>46350000
   END;    << KSAM file >>                                     <<KS.00>>46355000
   <<DUMMY 7>>;                                                <<HM.00>>46360000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>46365000
   TOS:=ACCVIOL;                                               <<HM.00>>46370000
   GO NFG;                                                     <<HM.00>>46375000
   END;                                                        <<HM.00>>46380000
   END;      << FTYPE case >>                                           46385000
                                                                        46390000
EXIT:                                                                   46395000
   CONDCODE := TOS;  << report condition code >>                        46400000
   RESETCRITICAL(CRIT);                                                 46405000
   ERROREXIT(3,S0,0)                                                    46410000
   END;    << procedure FPOINT >>                                       46415000
$PAGE " FCONTROL "                                                      46420000
$CONTROL SEGMENT = FILESYS2   << FCONTROL >>                            46425000
PROCEDURE FCONTROL(FILENUM,CODE,PARAM);                                 46430000
   << Performs control operations on the specified file.                46435000
                                                                        46440000
     Input variables:                                                   46445000
         FILENUM - file number                                          46450000
         CODE - Control code                                            46455000
            0 - general device control                                  46460000
            1 - line control                                            46465000
            2 - complete (quiesce) I/O                                  46470000
            3 - read hardware status word                               46475000
            4 - set terminal time-out interval                          46480000
            5 - rewind file                                             46485000
            6 - write EOF                                               46490000
            7 - space forward to tape mark                              46495000
            8 - space backward to tape mark                             46500000
            9 - rewind and unload tape                                  46505000
           10 - change terminal input speed                             46510000
           11 - change terminal output speed                            46515000
           12 - turn terminal echo on                                   46520000
           13 - turn terminal echo off                                  46525000
           14 - disable Break                                           46530000
           15 - enable Break                                            46535000
           16 - disable subsystem Break (Control-Y)                     46540000
           17 - enable subsystem Break (Control-Y)                      46545000
           18 - disable terminal tape mode                              46550000
           19 - enable terminal tape mode                               46555000
           20 - disable terminal input timer                            46560000
           21 - enable terminal input timer                             46565000
           22 - read terminal input timer                               46570000
           23 - disable parity checking                                 46575000
           24 - enable parity checking                                  46580000
           25 - set terminal line termination character                 46585000
           26 - disable binary transfers                                46590000
           27 - enable binary transfers                                 46595000
           28 - disable user mode block transfers                       46600000
           29 - enable user mode block transfers                        46605000
           30 - disable VIEW handshake mode                             46610000
           31 - enable VIEW handshake mode                              46615000
           32 - disable F1/F2 Escape sequences                          46620000
           33 - enable F1/F2 Escape sequences                           46625000
           34 - disable line deletion echo suppression                  46630000
           35 - enable line deletion echo suppression                   46635000
           36 - set parity                                              46640000
           37 - allocate terminal                                       46645000
           38 - set terminal type                                       46650000
           39 - get terminal type                                       46655000
           40 - get terminal output speed                               46660000
           41 - unedited terminal mode                                  46665000
           42 - MAKRO character write                                   46670000
           43 - abort No-wait I/O                                       46675000
           44 - ENABLE/DISABLE TRACE (MSG FILES)                 HM.00  46680000
           45 - ENABLE/DISABLE EXTENDED WAIT (MSG FILES)         HM.00  46685000
           46 - ENABLE/DISABLE EXTENDED READ (MSG FILES)         HM.00  46690000
           47 - NONDESTRUCTIVE READ (MSG FILES)                  HM.00  46695000
           48 - ARM/DISARM SOFTWARE INTERRUPTS                   HM.XX  46700000
         PARAM - utility parameter defined for following codes only:    46705000
            0 - Transmitted to and received from driver                 46710000
            1 - carriage control code                                   46715000
            4 - time-out interval in seconds                            46720000
           10 - new input speed                                         46725000
           11 - new output speed                                        46730000
           25 - new line termination character                          46735000
           36 - new parity code                                         46740000
           37 - terminal specifications                                 46745000
              (0:11) - speed in CPS                                     46750000
              (11:5) - terminal type code                               46755000
           38 - terminal type code                                      46760000
           41 - control characters                                      46765000
              (0:8) - ATTENTION character                               46770000
              (8:8) - End of Record character                           46775000
           42 - two characters                                          46780000
                                                                        46785000
     Output variables:                                                  46790000
         PARAM - Utility parameter returned for following codes only:   46795000
            0 - Driver status                                           46800000
            1 - Previous mode control (0=Post-, 1=pre-spacing)          46805000
            3 - Hardware status word                                    46810000
           10 - Previous terminal input speed                           46815000
           11 - Previous terminal output speed                          46820000
        12,13 - Previous echo state (0=ON,1=OFF)                        46825000
           22 - Terminal input time in hundredths of seconds            46830000
           36 - Old parity code                                         46835000
           39 - Terminal type code                                      46840000
           40 - Terminal output speed                                   46845000
                                                                        46850000
     Condition code:                                                    46855000
         CCE - OK                                                       46860000
         CCL - Error                                                    46865000
                                                                        46870000
   DB may be at any data segment when this procedure is called.    >>   46875000
                                                                        46880000
VALUE FILENUM,CODE;                                                     46885000
INTEGER FILENUM,CODE,PARAM;                                             46890000
OPTION PRIVILEGED;                                                      46895000
   BEGIN                                                                46900000
   ENTRY  kfcontrol'ksam;                                      <<02089>>46905000
   EQUATE UBND = -7; << Q rel upper bound for bounds check>>   <<03059>>46910000
   DEFINE ACTDEF =                                                      46915000
      IF NOT (ACB'FOPTIONS.(10:3) = 0) THEN GO E9#;                     46920000
                                                                        46925000
   INTEGER ARRAY FCB(0:SIZEBFCB+2-1) = Q;                               46930000
   DOUBLE ARRAY FCBDBL(*) = FCB;                                        46935000
   INTEGER  ACBMQ,  << Q relative location of ACB.          >> <<04591>>46940000
            FCBMQ;  << Q relative location of FCB.          >> <<04591>>46945000
EQUATE  BKUP = SIZEBFCB+2-XEOF;                                <<04591>>46950000
   INTEGER CRIT;            << for SETCRITICAL >>                       46955000
   INTEGER A;               << for GETSIR >>                            46960000
   LOGICAL DTYPE;           << device type from ACB >>                  46965000
   INTEGER FUNC;            << ATTACHIO function >>                     46970000
   INTEGER CTLA := 0;       << ATTACHIO first parameter >>              46975000
   INTEGER CTLB := 0;       << ATTACHIO second parameter >>             46980000
   LOGICAL FLAG := %11;     << ATTACHIO flag - Blocked with SBUF's >>   46985000
   LOGICAL TOG := FALSE;    << Return parameter to user? >>             46990000
   LOGICAL ksam'ept;  << do a special fcontrol 6 >>            <<02089>>46995000
   INTEGER JUNK;            << utility variable >>                      47000000
   DOUBLE DISKADR;          << file label sector nr. >>                 47005000
   INTEGER POINTER FLAB;     << file label buffer >>                    47010000
   DOUBLE POINTER FLABDBL = FLAB;                                       47015000
   LOGICAL MODE;                                               <<00546>>47020000
   LOGICAL LDEV := 0;                                          <<00546>>47025000
   LOGICAL LDEVIN := 0;                                        <<00546>>47030000
   DOUBLE IO'STATUS;  << Return parm from ATTACHIO.         >> <<04591>>47035000
   INTEGER                                                     <<04591>>47040000
          WAITIO'STATUS = IO'STATUS, << Word 1 of return.   >> <<04591>>47045000
          WAITIO'TLOG   = IO'STATUS+1; << Word 2 of return. >> <<04591>>47050000
   INTEGER POINTER AFT;                                        <<06511>>47055000
LOGICAL SUBTYPE;     << device subtype >>                      <<*7856>>47060000
LOGICAL ARRAY DEV'STATUS(0:2) = Q; << device status >>         <<*7856>>47065000
LOGICAL FERR;      << file system error >>                     <<*7856>>47070000
                                                                        47075000
   << Remote file access (RFA) variables: >>                            47080000
                                                                        47085000
   INTEGER POINTER RFAPTR;    << appendage pointer >>                   47090000
   INTEGER RFALEN;            << appendage length >>                    47095000
                                                               <<HM.00>>47100000
   << MESSAGE FILE DECLARATIONS >>                             <<HM.00>>47105000
   EQUATE LOWMSGVAL = 45;                                      <<HM.00>>47110000
   EQUATE HIMSGVAL  = 48;                                      <<03038>>47115000
                                                                        47120000
<< Following LOC'ACB params must be last and in order: >>               47125000
   INTEGER AFTE;       << AFT entry word 0 >>                           47130000
   DOUBLE  PACBV;                                              <<06511>>47135000
   DOUBLE  LACBV;                                              <<06511>>47140000
   INTEGER IOQX;                                                        47145000
   INTEGER ARRAY ACB(0:SIZEXACB) = Q;       << Q+ACBMQ >>      <<*7856>>47150000
   DOUBLE ARRAY ACBDBL(*) = ACB;                                        47155000
   BUILD'ACB;                                                           47160000
   DEFINE DSTX = ACB(SIZEXACB)#;  << User's DB setting >>      <<*7856>>47165000
<< End of LOC'ACB params >>                                             47170000
                                                                        47175000
   INTRINSIC  WHO;                                             <<00546>>47180000
                                                                        47185000
   SUBROUTINE LABELIO (RW);                                             47190000
      << Reads or writes the file label into the stack buffer.          47195000
                                                                        47200000
        Input variables:                                                47205000
           RW - I/O mode                                                47210000
              0 - Read                                                  47215000
              1 - Write                                                 47220000
                                                                        47225000
      DB must be at the stack when this subroutine is called.   >>      47230000
                                                                        47235000
   VALUE RW;                                                            47240000
   INTEGER RW;                                                          47245000
      BEGIN                                                             47250000
      X := FLABIO(DTYPE,DISKADR,RW,FLAB);  <<R/W label>>                47255000
      IF <> THEN                                                        47260000
         BEGIN       << Error. >>                                       47265000
         FLABIOERR(X,FILENUM);  << handle error >>                      47270000
         RELSIR(FISIR,A);       << release File SIR >>                  47275000
         EXCHANGEDB(JUNK);     << reset DB to original >>               47280000
         UNLOCK'CB(0,ACB'FCB);                                 <<06511>>47285000
         TOS := LBLIOERR;                                               47290000
         GO ERR                                                         47295000
         END                                                            47300000
      END;      << subroutine LABELIO >>                                47305000
                                                                        47310000
   SUBROUTINE REWINDACB;                                                47315000
   << This subroutine "rewinds" the ACB. >>                             47320000
      BEGIN                                                             47325000
      ACB'FPTR := 0D;    << Reset file pointer >>                       47330000
      ACB'HIBLK := -1D;   << Reset highest block nr. >>        <<06511>>47335000
      IF ACB'VARIABLE THEN                                              47340000
         BEGIN                                                          47345000
         ACB'BUFUSED := 0;                                     <<06511>>47350000
         ACB'BLK := 0D   << Reset var. block pointer >>        <<06511>>47355000
         END;                                                           47360000
      ACB'NEWEOF := 0;                                         <<04591>>47365000
      ACB'EOF := 0;       << Note: sets CC per prior state. >>          47370000
      END;                                                              47375000
                                                                        47380000
   DOUBLE SUBROUTINE ATTIO(FUNC);                                       47385000
VALUE FUNC; INTEGER FUNC;                                               47390000
   << Shortcut to call ATTACHIO. >>                                     47395000
                                                                        47400000
      ATTIO := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,0,4,BFLAGS);    <<02693>>47405000
                                                                        47410000
   SUBROUTINE TM;                                                       47415000
   << If the New EOF Needed flag is set in the ACB, a tape mark         47420000
      is written and the tape backspaced over it.    >>                 47425000
                                                                        47430000
      BEGIN                                                             47435000
      IF ACB'NEWEOF THEN                                                47440000
         BEGIN        << Tape mark needed. >>                           47445000
         TOS := ATTIO(6);      << WTM >>                                47450000
         ASMB(DEL,DUP);        << replicate returned status >>          47455000
         IF TOS.(8:8) <> 1 THEN                                         47460000
            BEGIN              << ATTACHIO reports error. >>            47465000
            ASMB(ZERO,XCH);    << for result of IOSTAT >>               47470000
            TOS := IOSTAT(*);   << convert error nr. >>                 47475000
            ASMB(TEST);        << zero if EOF >>                        47480000
            IF <> AND S0 <> EOT AND S0 <> TAPERREC THEN GO ERR <<02712>>47485000
            END;                                                        47490000
         DEL;                                                           47495000
         ACB'NEWEOF := 0;    << Clear EOF Needed flag >>                47500000
   << Backspace File over new tapemark, wait for completion >>          47505000
         TOS := ATTIO(8);     <<BF>>                                    47510000
         ASMB(DEL,DUP);                                                 47515000
         IF TOS.(8:8) <> 1 THEN                                         47520000
            BEGIN            << ATTACHIO reports error. >>              47525000
            ASMB(ZERO,XCH);    << for result of IOSTAT >>               47530000
            TOS := IOSTAT(*);   << convert error nr. >>                 47535000
            IF S0 <> EOF AND S0 <> TAPERREC THEN GO ERR;       <<03532>>47540000
            END;                                                        47545000
         DEL                                                            47550000
         END                                                            47555000
      END;     << subroutine TM >>                                      47560000
                                                                        47565000
   << special entry point to bypass extent   >>                <<02089>>47570000
   << initialization on an fcontrol 6 ONLY!  >>                <<02089>>47575000
   << For ksamutil keyinfo;recover           >>                <<02089>>47580000
   IF (ksam'ept:=false) THEN                                   <<02089>>47585000
      BEGIN                                                    <<02089>>47590000
kfcontrol'ksam:   ksam'ept:=true;                              <<02089>>47595000
      END;                                                     <<02089>>47600000
                                                               <<02089>>47605000
$  IF X0 = ON                                                           47610000
   IF MONCALLABLE THEN                                                  47615000
      BEGIN        << monitoring >>                                     47620000
      FTITLE("FCON","TROL",0D,0D);                                      47625000
      DEBUG                                                             47630000
      END;                                                              47635000
$  IF                                                                   47640000
                                                                        47645000
   ERRORON;                                                             47650000
   CRIT := SETCRITICAL;                                                 47655000
   GET'ACB'Q'LOC;                                              <<04591>>47660000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);    << get ACB >>                     47665000
   IF < THEN                                                            47670000
      BEGIN       << invalid file nr. >>                                47675000
      TOS := INVFN;                                                     47680000
ERROR:                                                                  47685000
      CTLA := TOS;     << Error nr. >>                                  47690000
      CONDCODE := CCL;  << error condition code >>                      47695000
      GO GETOUT;                                                        47700000
      END;                                                              47705000
   IF > THEN                                                            47710000
      BEGIN         << File is $NULL >>                                 47715000
      CONDCODE := CCE;                                                  47720000
      GO GETOUT                                                         47725000
      END;                                                              47730000
   IF NOT FBNDCHK (@PARAM, 1, UBND) THEN                       <<03059>>47735000
      BEGIN   << Parameter out of bounds.                   >> <<02556>>47740000
      TOS := BNDVIOL;                                          <<02556>>47745000
CHECK'FTYPE:                                                   <<02556>>47750000
      IF FTYPE = FS'TYPE OR FTYPE = MSG'TYPE                   <<02556>>47755000
        THEN GO ERR      << Stuff error in ACB.             >> <<02556>>47760000
        ELSE GO ERROR;   << No ACB, just scram.             >> <<02556>>47765000
      END;                                                     <<02556>>47770000
   JUNK := PARAM;   << Must follow call to FBNDCHK.         >> <<02642>>47775000
   IF NOT (0 <= CODE <= HIMSGVAL) THEN                         <<02556>>47780000
      BEGIN   << Invalid code.                              >> <<02556>>47785000
      TOS := ILLPARM;                                          <<02556>>47790000
      GO CHECK'FTYPE;                                          <<02556>>47795000
      END;                                                     <<02556>>47800000
   SUBTYPE := LDEVTOSUBTYPE(ACB'DADDR);<<get device subtype >> <<*7856>>47805000
   CASE * FTYPE OF                                                      47810000
   BEGIN                                                                47815000
                                                                        47820000
   BEGIN      << conventional file >>                                   47825000
   IF CODE > 43 THEN  <<INVALID CODE?>>                        <<HM.00>>47830000
      BEGIN                                                    <<HM.00>>47835000
      TOS := ILLPARM;                                          <<HM.00>>47840000
      GO ERR                                                   <<HM.00>>47845000
      END;                                                     <<HM.00>>47850000
   IF IOQX <> 0 AND CODE < 42 THEN                                      47855000
      BEGIN        << No-wait I/O pending. >>                           47860000
      TOS := IOPENDING;                                                 47865000
      GO ERR                                                            47870000
      END;                                                              47875000
   IF ACB'SPOOLED AND NOT (1 <= CODE <= 2) THEN GO E3;                  47880000
   ACB'ERROR := 0;                                                      47885000
   DTYPE := IF ACB'SPOOLED THEN ACB'SPTYPE ELSE ACB'DTYPE;     <<06511>>47890000
   X := IF CODE < 10 THEN CODE                                          47895000
        ELSE IF (10 <= CODE <= 42) THEN 10                              47900000
        ELSE 11;                                                        47905000
   CASE * X OF                                                          47910000
      BEGIN                                                             47915000
                                                                        47920000
   <<* * * 0 - General device control * * *>>                           47925000
                                                                        47930000
      BEGIN                                                             47935000
      CTLA := JUNK;    << user's control param. >>                      47940000
      FUNC := 28;      << control function >>                           47945000
      FLAG := 1;       << blocked request >>                            47950000
      TOG := TRUE      << report the result >>                          47955000
      END;                                                              47960000
                                                                        47965000
   <<* * * 1 - Line control * * *>>                                     47970000
                                                                        47975000
      BEGIN                                                             47980000
      IF DTYPE <> LPTR AND DTYPE <> TERMINAL THEN   <<illegal?>>        47985000
         IF ACB'SPOOLED THEN                                            47990000
            BEGIN                                                       47995000
E3:         TOS := SPOOLILLOP;                                          48000000
            GO ERR;                                                     48005000
            END                                                         48010000
         ELSE GO E1;                                                    48015000
      IF JUNK = 1 THEN                                                  48020000
         BEGIN       << Illegal control. >>                             48025000
         TOS := BADCONTROL;                                             48030000
         GO ERR                                                         48035000
         END;                                                           48040000
      IF NOT ACB'INHIBITBUF AND NOT ACB'SPOOLED THEN                    48045000
         FQUIESCE'IO(0);   << Complete physical I/O >>                  48050000
      IF (%400 <= JUNK <= %403) THEN JUNK := JUNK-%300;  <<re-map?>>    48055000
      IF (%100 <= JUNK <= %101) THEN                                    48060000
         BEGIN           << Set pre- or post-spacing. >>                48065000
         TOG := TRUE;     << report old state >>                        48070000
         TOS := 0;        << for old state value >>                     48075000
         ACB'LINECTL := JUNK;  << new state >>                          48080000
         IF <> THEN TOS := TOS+1;                                       48085000
         JUNK := TOS;      << old state >>                              48090000
         GO FSEXIT                                                      48095000
         END;                                                           48100000
      IF (%102 <= JUNK <= %103) THEN                                    48105000
         BEGIN        << Set auto page control >>                       48110000
         ACB'PAGECTL := JUNK;  << new state >>                          48115000
         GO FSEXIT                                                      48120000
         END;                                                           48125000
      IF ACB'SPOOLED THEN                                               48130000
         BEGIN    << Write spoofle record noting change. >>             48135000
         ACB'CTL := JUNK;                                               48140000
         ACB'NEWEOF := 1;                                               48145000
         IOMOVE(2,DUM,0);  << write ctrl rec >>                         48150000
         GO FSEXIT                                                      48155000
         END;                                                           48160000
      CTLA := JUNK;      << control code >>                             48165000
      TOS := ACB'LPCTL;   << line and page control >>                   48170000
      IF DTYPE = TERMINAL THEN                                          48175000
         BEGIN                                                          48180000
         TOS.(10:1) := ACB'TBLOCK;  << disable Block mode >>            48185000
         TOS.(12:1) := ACB'BINARYIO  << 8-bit transfers >>              48190000
         END                                                            48195000
      ELSE      << line printer >>                                      48200000
         TOS.(12:1) := NOT ACB'ASCII;  << ASCII/binary mode >>          48205000
      CTLB := TOS;        << device controls >>                         48210000
      FUNC := 1      << WRITE >>                                        48215000
      END;                                                              48220000
                                                                        48225000
   <<* * * 2 - Complete I/O * * *>>                                     48230000
                                                                        48235000
      BEGIN                                                             48240000
      IF NOT ACB'INHIBITBUF AND NOT ACB'SPOOLED THEN                    48245000
         FQUIESCE'IO(0);   << Complete I/O >>                           48250000
      GO FSEXIT                                                         48255000
      END;                                                              48260000
                                                                        48265000
   <<* * * 3 - Read hardware status word * * *>>                        48270000
                                                                        48275000
      BEGIN                                                             48280000
      JUNK := DEVICESTATUS(ACB'DADDR);  << get hardware status >>       48285000
      IF < THEN GO E1;     << if error >>                               48290000
      TOG := TRUE;        << report returned value >>                   48295000
      GO FSEXIT                                                         48300000
      END;                                                              48305000
                                                                        48310000
   <<* * * 4 - Set time-out interval * * *>>                            48315000
                                                                        48320000
      BEGIN                                                             48325000
      IF DTYPE <> TERMINAL THEN GO E1;  << must be terminal >>          48330000
      FUNC := 5;        << tell driver to set timeout >>                48335000
      CTLA := JUNK       << timeout value >>                            48340000
      END;                                                              48345000
                                                                        48350000
   <<* * * 5 - Rewind file * * *>>                                      48355000
   <<  REWIND should not be allowed if acc=APPEND.  This     >><<02353>>48360000
   <<  change was put in to prevent append-only files from   >><<02353>>48365000
   <<  being 'scratched' if REWIND was followed by WRITE EOF.>><<02353>>48370000
   <<  For multi-reel tape handling, user should use FCONTROL>><<02353>>48375000
   <<  9 (REWIND/UNLOAD).                                    >><<02353>>48380000
                                                                        48385000
      BEGIN                                                             48390000
      IF ACB'ACCCL = DIRACC THEN                                        48395000
         BEGIN          << Disk >>                                      48400000
         IF ACB'APPEND THEN GO E9; << Disallow if ACC=APPEND >><<02353>>48405000
         IF NOT ACB'INHIBITBUF THEN FQUIESCE'IO(0); << complete I/O >>  48410000
         REWINDACB;   << set to beginning of file >>                    48415000
         GO FSEXIT                                                      48420000
         END;                                                           48425000
      IF DTYPE = MTAPE OR DTYPE = SDISC THEN                            48430000
         BEGIN       << tape-like device >>                             48435000
         IF ACB'APPEND THEN GO E9; << Disallow if ACC=APPEND >><<02353>>48440000
         FUNC := 5;    << Rewind >>                                     48445000
DOIT:    FLAG := %13;  <<SYS. BUFFER - NO PCB>>                         48450000
         ACTDEF;      << Barf if $STDIN, etc. >>                        48455000
         IF NOT ACB'INHIBITBUF THEN                            <<*7856>>48460000
            BEGIN                                              <<*7856>>48465000
            FQUIESCE'IO(0);                                    <<*7856>>48470000
            IF ACB'ERROR <> 0 THEN                             <<*7856>>48475000
               BEGIN                                           <<*7856>>48480000
               IF ACB'ERROR = EOT THEN ACB'ERROR := 0          <<*7856>>48485000
               ELSE                                            <<*7856>>48490000
                  BEGIN                                        <<*7856>>48495000
                  TOS := ACB'ERROR;                            <<*7856>>48500000
                  GO ERR;                                      <<*7856>>48505000
                  END;                                         <<*7856>>48510000
               END;  << error from fquiesceio >>               <<*7856>>48515000
            END                                                <<*7856>>48520000
         ELSE IF STREAMING'DEVICE THEN                         <<*7856>>48525000
            BEGIN                                              <<*7856>>48530000
            IF DSTX <> 0 THEN EXCHANGEDB(0);<<must be @stack>> <<*7856>>48535000
            IO'STATUS := ATTACHIO(ACB'DADDR,0,0,@DEV'STATUS,   <<*7856>>48540000
                                CHECK'STATUS,3,0,1,BFLAGS);    <<*7856>>48545000
            << quiesce streaming drive and check status >>     <<*7856>>48550000
            IF DSTX <> 0 THEN EXCHANGEDB(DSTX);  <<switchback>><<*7856>>48555000
            IF WAITIO'STATUS <> 1 THEN                         <<*7856>>48560000
               BEGIN                                           <<*7856>>48565000
               FERR := IOSTAT(WAITIO'STATUS);                  <<*7856>>48570000
               IF FERR = EOF THEN                              <<*7856>>48575000
                  ACB'EOF := 1;                                <<*7856>>48580000
               IF (FERR <> EOF) AND (FERR <> EOT) THEN         <<*7856>>48585000
                  BEGIN                                        <<*7856>>48590000
                  TOS := FERR;                                 <<*7856>>48595000
                  GO ERR;                                      <<*7856>>48600000
                  END;                                         <<*7856>>48605000
               END;                                            <<*7856>>48610000
            END;                                               <<*7856>>48615000
         IF ACB'ERROR = EOT THEN ACB'ERROR := 0;               <<00483>>48620000
         IF LABEL'DEVICE THEN                                  <<03582>>48625000
            BEGIN        << labeled tape >>                    <<02545>>48630000
            TOS := CHECKUL(FILENUM,5,ACB'NEWEOF);              <<02545>>48635000
            IF < THEN GO ERR;                                  <<02545>>48640000
            DEL;                                               <<02545>>48645000
            REWINDACB;                                         <<02545>>48650000
            ACB'BTFRCT := 0D;                                  <<06511>>48655000
            GO FSEXIT;                                         <<02545>>48660000
            END;                                               <<02545>>48665000
         TM;     << write tape mark >>                         <<01156>>48670000
         REWINDACB;                                            <<01156>>48675000
         IF DTYPE = MTAPE THEN SET'LPDT'BOT(ACB'DADDR,1);      <<02545>>48680000
         END      << tapelike device >>                                 48685000
      ELSE                                                              48690000
         GO E1     << Other devices lose. >>                            48695000
      END;                                                              48700000
                                                                        48705000
   <<* * * 6 - Write End of File * * *>>                                48710000
                                                                        48715000
      BEGIN                                                             48720000
      IF ACB'ACCCL = DIRACC THEN                                        48725000
         BEGIN          << Disk >>                                      48730000
         IF DTYPE=FDISC THEN GO E1;                            <<01115>>48735000
         IF NOT (1 <= ACB'ACTYPE <= 6) THEN                     <<MRJE>>48740000
            BEGIN     << No Write access. >>                            48745000
E9:         TOS := ACCVIOL;                                             48750000
            GO ERR                                                      48755000
            END;                                                        48760000
         IF NOT ACB'INHIBITBUF THEN FQUIESCE'IO(0); << empty bufs >>    48765000
          << do not initialize extents for special ept >>      <<02089>>48770000
          IF NOT(ksam'ept) THEN iomove(%11,dum,0);             <<02089>>48775000
         IF NOT ACB'EXCLUSIVE THEN                             <<*8530>>48780000
            A := GETSIR(FISIR);                                <<*8530>>48785000
                                                                        48790000
      <<* * * Update FCBEOF, and get label address * * *>>              48795000
                                                                        48800000
         GET'FCB'Q'LOC;                                        <<04591>>48805000
         LOCK'CB(0,0,FCBMQ,ACB'FCB);                           <<06511>>48810000
         TOS := SIZEBFCB+2;     << word count >>                        48815000
         MOVE'DS'1;             << FCB + first e-map entry >>           48820000
         X := FCB.(2:14);                                               48825000
         IF BADFCBSIZE THEN FTROUBLE(64);                               48830000
         IF NOT ACB'APPEND THEN  << If APPEND, use cur. EOF >> <<02353>>48835000
         FCBEOF := ACB'FPTR;     << post new EOF >>                     48840000
         TOS := TOS-BKUP;         << back up >>                         48845000
         ASMB(DXCH);                                                    48850000
         TOS := TOS-BKUP;         << back up >>                         48855000
         TOS := 2;                                                      48860000
         MOVE'DS'6;               << update FCBEOF. >>                  48865000
         TOS := 0;                 << for LDEV >>                       48870000
         TOS := FCBLABEL;          << LDEV and sector nr.>>             48875000
         TOS := TOS&TASL(8)&DLSR(8);  << separate LDEV >>               48880000
         DISKADR := TOS;          << file label sector nr. >>           48885000
         DTYPE := TOS;           << file label LDEV >>                  48890000
                                                                        48895000
      <<* * * Update file label * * *>>                                 48900000
                                                                        48905000
         JUNK := EXCHANGEDB(0);        << set DB to stack >>            48910000
         ALLOCFLAB;             << allocate file label buffer >>        48915000
         LABELIO(0);            << Read label >>                        48920000
         FLEOF :=                << update EOF >>              <<02353>>48925000
         IF ACB'APPEND THEN FCBEOF ELSE ACB'FPTR;              <<02353>>48930000
         FLUSERLBL := FCBUSERLBL;    << update user label info >>       48935000
         FLSTART:=FCBSTART;                                    <<HM.00>>48940000
         FLEND:=FCBEND;                                        <<HM.00>>48945000
         FLHDRECS:=FCBHDRECS;                                  <<HM.00>>48950000
         LABELIO(1);            << rewrite label >>                     48955000
         IF NOT ACB'EXCLUSIVE THEN                             <<*8530>>48960000
            RELSIR(FISIR,A);       << release File SIR >>      <<*8530>>48965000
         EXCHANGEDB(JUNK);      << reset DB to original >>              48970000
         UNLOCK'CB(0,ACB'FCB);                                 <<06511>>48975000
         GO FSEXIT                                                      48980000
         END;                                                           48985000
      IF DTYPE=MTAPE OR DTYPE=SSLC OR DTYPE=SDISC THEN         <<SD.00>>48990000
         BEGIN    << Tape,SSLC, or SDISC device >>             <<SD.00>>48995000
         IF NOT (1 <= ACB'ACTYPE <= 6) THEN GO E9;             <<00900>>49000000
         ACTDEF;       << gripe if $STDIN, $STLIST, etc. >>             49005000
         IF NOT ACB'INHIBITBUF THEN                            <<04591>>49010000
            BEGIN                                              <<04591>>49015000
            TOS := FQUIESCE'IO(FALSE); << TOS MUST MUST be  >> <<04591>>49020000
            ACB'TAPEDISP := TOS; << used so ACB is at Q-62!!>> <<04591>>49025000
                                                               <<04591>>49030000
            <<**********************************************>> <<04591>>49035000
            << Backspace one block for every extra pre-read >> <<04591>>49040000
            << to properly position the tape before we write>> <<04591>>49045000
            << the EOF.  ACB'TAPEDISP is obtained from      >> <<04591>>49050000
            << FQUIESCE'IO by counting the I/O's outstanding>> <<04591>>49055000
            <<**********************************************>> <<04591>>49060000
                                                               <<04591>>49065000
            IF ACB'NEWEOF THEN                                 <<04591>>49070000
               ACB'TAPEDISP := 0  << No pre-reads performed.>> <<04591>>49075000
            ELSE                                               <<04591>>49080000
               WHILE ACB'TAPEDISP > 0 DO                       <<04591>>49085000
                  BEGIN                                        <<04591>>49090000
                  IO'STATUS := ATTIO(12);  << BSR >>           <<04591>>49095000
                  IF WAITIO'STATUS <> 1 THEN                   <<04591>>49100000
                     BEGIN                                     <<04591>>49105000
                     JUNK := IOSTAT(WAITIO'STATUS);            <<04591>>49110000
                     IF JUNK <> EOF AND JUNK <> EOT AND        <<04591>>49115000
                        JUNK <> TAPERREC THEN                  <<04591>>49120000
                        BEGIN                                  <<04591>>49125000
                        TOS := JUNK;  << Report the error.  >> <<04591>>49130000
                        GO ERR;                                <<04591>>49135000
                        END;                                   <<04591>>49140000
                     END;                                      <<04591>>49145000
                  ACB'TAPEDISP := ACB'TAPEDISP - 1;            <<04591>>49150000
                  END;                                         <<04591>>49155000
            END;                                               <<04591>>49160000
         FUNC := 6;  <<WTM>>                                            49165000
         IF LABEL'DEVICE THEN GO FSEXIT;                       <<03582>>49170000
         ACB'NEWEOF := 1;    << This is a write indeed!     >> <<06041>>49175000
         ACB'FPTR := 0D;                                                49180000
         ACB'HIBLK := -1D;                                     <<06511>>49185000
         CTLB.(13:1) := 1; <<Write after EOT is OK>>           <<02682>>49190000
         IF DTYPE = MTAPE THEN                                 <<02652>>49195000
            BEGIN                                              <<02652>>49200000
            TOS := WRITE'DENSITY(ACB'DADDR);                   <<02652>>49205000
            IF S1STAT <> 1 THEN                                <<02652>>49210000
               GO REPORT'ERROR;  << Skip WTM. >>               <<02652>>49215000
            DDEL;   << AOK, delete ATTACHIO return >>          <<02652>>49220000
            END;                                               <<02652>>49225000
         END                                                            49230000
      ELSE    << other device >>                                        49235000
         BEGIN                                                          49240000
E1:      TOS := DEVVIOL;                                                49245000
         GO ERR;                                                        49250000
         END;                                                           49255000
      END;                                                              49260000
                                                                        49265000
   <<* * * 7 - Space forward to tape mark * * *>>                       49270000
                                                                        49275000
      BEGIN                                                             49280000
      IF DTYPE<>MTAPE AND DTYPE<>SDISC THEN GO E1;             <<SD.00>>49285000
      IF ACB'NEWEOF AND ACB'LABELLED THEN                               49290000
         BEGIN    << Illegal after writing labeled tape. >>             49295000
         TOS := ILLPARM;                                                49300000
         GO ERR                                                         49305000
         END;                                                           49310000
      ACTDEF;      << Gripe if $STDIN, $STDLIST, etc. >>                49315000
      IF ACB'NEWEOF THEN                                       <<04591>>49320000
         BEGIN  << Spacing forward after a write is no-no.  >> <<04591>>49325000
         TOS := INVOP;                                         <<04591>>49330000
         GO ERR;                                               <<04591>>49335000
         END;                                                  <<04591>>49340000
      FUNC := 7;  <<FSF>>                                               49345000
<< Exit if tapemark has been encountered on a Pre-read. >>              49350000
      IF NOT ACB'INHIBITBUF AND FQUIESCE'IO(1) < 0 THEN                 49355000
         GO FSEXIT;     << EOF encountered. >>                          49360000
      REWINDACB;                                                        49365000
      IF <> THEN GO FSEXIT;   << EOF encountered. >>                    49370000
      IF DTYPE = MTAPE THEN SET'LPDT'BOT(ACB'DADDR,0);         <<02545>>49375000
      IF LABEL'DEVICE THEN                                     <<03582>>49380000
         BEGIN      << labeled tape >>                                  49385000
         TOS := CHECKUL(FILENUM,7,0);                          <<02545>>49390000
         IF < THEN GO ERR;                                     <<02545>>49395000
         DEL;                                                  <<02545>>49400000
         GO FSEXIT;                                                     49405000
         END;     << labeled tape >>                                    49410000
      END;                                                              49415000
                                                                        49420000
   <<* * * 8 - Space backward to tape mark * * *>>                      49425000
                                                                        49430000
      BEGIN                                                             49435000
      IF DTYPE <> MTAPE AND DTYPE <> SDISC THEN GO E1;         <<SD.00>>49440000
      IF LABEL'DEVICE THEN GO DOIT;                            <<03582>>49445000
      ACTDEF;         << Barf if $STDIN, etc. >>                        49450000
      FUNC := 8;      <<BSF>>                                           49455000
      IF ACB'INHIBITBUF THEN TM ELSE                                    49460000
         BEGIN       << Buffered. Must discard pre-reads. >>            49465000
         TOS := FQUIESCE'IO(FALSE); << TOS MUST MUST be used>> <<04591>>49470000
         ACB'TAPEDISP := TOS; << so the ACB is at Q-62!!!!! >> <<04591>>49475000
         IF ACB'NEWEOF THEN                                    <<04591>>49480000
            BEGIN                                              <<04591>>49485000
            TM;                 << Write tape mark          >> <<04591>>49490000
            ACB'TAPEDISP := 0;  << No pre-reads performed.  >> <<04591>>49495000
            END                                                <<04591>>49500000
         ELSE                                                  <<04591>>49505000
            WHILE ACB'TAPEDISP > 0 DO                          <<04591>>49510000
               BEGIN                                           <<04591>>49515000
               ATTIO(12);      << BSR >>                       <<04591>>49520000
               ACB'TAPEDISP := ACB'TAPEDISP - 1;               <<04591>>49525000
               END;                                            <<04591>>49530000
                                                               <<04591>>49535000
         END;                                                           49540000
      IF ACB'ERROR = EOT THEN ACB'ERROR := 0;                  <<00483>>49545000
      REWINDACB;                                                        49550000
      END;                                                              49555000
                                                                        49560000
   <<* * * 9 - Rewind and unload tape file * * *>>                      49565000
                                                                        49570000
      BEGIN                                                             49575000
      IF DTYPE <> MTAPE AND DTYPE <> SDISC THEN GO E1;         <<SD.00>>49580000
      IF LABEL'DEVICE THEN GO FSEXIT;                          <<03582>>49585000
      FUNC := 9;       << Rewind and Unload >>                          49590000
      GO DOIT;                                                          49595000
      END;                                                              49600000
                                                                        49605000
   <<* * * 10 thru 42 - terminal controls * * *>>                       49610000
                                                                        49615000
      BEGIN                                                             49620000
      IF DTYPE <> TERMINAL THEN GO E1;  << Lose if not terminal. >>     49625000
      IF CODE = 15 THEN   << Enable Break requested? >>        <<00546>>49630000
        BEGIN    << See if Break allowed from this device. >>  <<00546>>49635000
        LDEV := ACB'DADDR;     << Get file LDEV >>             <<00546>>49640000
        EXCHANGEDB(0);          << DB to user stack >>         <<00546>>49645000
        WHO(MODE,,,,,,,LDEVIN);  <<get $STDIN MODE & LDEV>>    <<00546>>49650000
        EXCHANGEDB(DSTX);       << reset DB to original >>     <<00546>>49655000
        IF MODE.(12:2) <> 1 THEN GO E1;  <<Not a session. >>   <<00546>>49660000
        IF LDEVIN <> LDEV THEN GO E1;  <<Device not $STDIN>>   <<00546>>49665000
        END;                                                   <<00546>>49670000
      IF CODE = 25 THEN        << New Stop character? >>                49675000
         ACB'STOPCHAR := JUNK                                  <<06511>>49680000
      ELSE IF (26 <= CODE <= 27) THEN  << Binary transfers? >>          49685000
         BEGIN                                                 <<07287>>49690000
         JUNK := GET'DSDEVICE(ACB'DADDR);                      <<07287>>49695000
         IF JUNK = 4 THEN                                      <<07287>>49700000
            BEGIN   ! Not implemented on PAD terminals.        <<07287>>49705000
            TOS := UNIMPL;                                     <<07287>>49710000
            GO TO ERR;                                         <<07287>>49715000
            END;                                               <<07287>>49720000
         ACB'BINARYIO := CODE;                                 <<07287>>49725000
         END                                                   <<07287>>49730000
      ELSE IF (28 <= CODE <= 29) THEN  << User mode block xfers? >>     49735000
         ACB'TBLOCK := CODE                                             49740000
      ELSE IF (30 <= CODE <= 31) THEN  << VIEW handshake? >>            49745000
         ACB'XMITCRLF := CODE                                  <<01790>>49750000
      ELSE IF (32 <= CODE <= 33) THEN  << F1/F2 escape sequences? >>    49755000
         ACB'FKEYS := CODE                                     <<06511>>49760000
      ELSE IF CODE = 42 THEN  << Hard pre-emptive write? >>             49765000
         BEGIN                                                          49770000
         IF NOT PRIVMODE THEN                                           49775000
            BEGIN                                                       49780000
            TOS := ILLCAP;                                              49785000
            GO ERR;                                                     49790000
            END;                                                        49795000
         CTLA := ACB'DADDR;       << Save LDEV >>                       49800000
         TOS := EXCHANGEDB(0);   << Set DB to stack >>                  49805000
         TOS := ATTACHIO(CTLA,0,0,@JUNK,1,-2,%320,0,                    49810000
            BFLAGS+%400);                                               49815000
         ASMB(CAB,ZROB);                                                49820000
         EXCHANGEDB(*);        << Reset to user's DB >>                 49825000
         IF TOS.(8:8) <> 1 THEN GO E1  << ATTACHIO error >>             49830000
         END                                                            49835000
      ELSE      << other terminal control >>                            49840000
         BEGIN                                                          49845000
         TOS := %(2)10010100000000000000000000000011D                   49850000
            &DLSR(CODE-10);                                             49855000
         DELB;                                                          49860000
         IF TOS THEN  <<10,11,36,38 OR 41?>>                            49865000
            CTLA := JUNK     << parameter >>                            49870000
         ELSE IF CODE = 37 THEN  << Allocate terminal? >>               49875000
            BEGIN                                                       49880000
            CTLA := JUNK.(11:5);  << terminal type >>                   49885000
            CTLB := JUNK.(0:11)   << terminal speed >>                  49890000
            END;                                                        49895000
         TOS := ATTACHIO(ACB'DADDR,0,0,0,                               49900000
            IF (26 <= CODE <= 35) THEN CODE-8 ELSE CODE-4,              49905000
            0,CTLA,CTLB,BFLAGS);                                        49910000
         JUNK := TOS;      << Old value, if any >>                      49915000
         IF TOS.(8:8) <> 1 THEN GO E1;  << Error. >>                    49920000
         TOS := %(2)1100100000000000001000000001111D&DLSR(CODE-10);     49925000
         DELB;                                                          49930000
         TOG := TOS    << set Return Value flag >>                      49935000
         END;                                                           49940000
      GO FSEXIT                                                         49945000
      END;                                                              49950000
                                                                        49955000
   <<* * * 43 - Abort NO-WAIT I/O * * *>>                               49960000
                                                                        49965000
      BEGIN                                                             49970000
      IF IOQX = 0 THEN                                         <<06511>>49975000
         BEGIN                                                 <<06511>>49980000
         TOS := NOIOPENDING2; ! No I/O pending on file!        <<06511>>49985000
         GO ERR;                                               <<06511>>49990000
         END;                                                  <<06511>>49995000
      IF GLOBAL'FILENUM       ! Get to AFT, global/local.      <<06511>>50000000
         THEN EXCHANGEDB(GLOBAL'AFT'DSTN)                      <<06511>>50005000
         ELSE EXCHANGEDB(0);                                   <<06511>>50010000
      SETAFT;                 ! Get to the AFT entry.          <<06511>>50015000
      AFTIOQX := 0;           ! Clear IOQX in AFT.             <<06511>>50020000
      EXCHANGEDB(DSTX);       ! Go back to users buffer.       <<06511>>50025000
      IF ACB'ACCCL = DIRACC                                    << 8467>>50030000
         THEN WAITFORIO(IOQX)    ! Wait for disc I/O.          << 8467>>50035000
         ELSE ABORTIOX(IOQX);    ! Non disc, abort the I/O.    << 8467>>50040000
      GO FSEXIT;              ! Rip this joint.                <<06511>>50045000
                                                               <<06511>>50050000
      END                     ! End of FCONTROL(43)            <<06511>>50055000
                                                                        50060000
      END;                    ! End of CASE statement.         <<06511>>50065000
                                                                        50070000
<<* * * Perform I/O operation * * *>>                                   50075000
                                                                        50080000
   TOS := ATTACHIO(ACB'DADDR,0,0,0,FUNC,0,CTLA,CTLB,                    50085000
      UFLAGS+FLAG);                                                     50090000
   IF FLAG.(13:3) = 1 THEN                                              50095000
      BEGIN         << Blocked request. Examine status >>               50100000
REPORT'ERROR:                                                  <<02652>>50105000
      JUNK := TOS;    << save returned TLOG >>                          50110000
      ACB'STATUS := S0;  << save logical I/O status >>                  50115000
      IF TOS.(8:8) <> 1 THEN                                            50120000
         BEGIN         << ATTACHIO reports error. >>                    50125000
         TOS := IOSTAT(ACB'STATUS);  << convert error nr. >>            50130000
         IF S0 = BOT AND DTYPE = MTAPE THEN                    <<02545>>50135000
            SET'LPDT'BOT(ACB'DADDR,1);                         <<02545>>50140000
         IF S0 <> 0 AND S0 <> TAPERREC THEN                    <<02712>>50145000
            <<Error other than EOF or tape retry>>             <<02712>>50150000
            BEGIN         << Other than EOF. >>                         50155000
  ERR:      CTLA := ACB'ERROR := TOS;  << error nr. >>         <<02712>>50160000
            CONDCODE := CCL;         << error condition code >><<02712>>50165000
            GO UNLK;                                           <<02712>>50170000
            END;                                               <<02712>>50175000
         END;               << error >>                        <<02712>>50180000
      END;                << examine status >>                          50185000
FSEXIT:                                                                 50190000
   CTLA := 0;                                                           50195000
   CONDCODE := CCE;                                                     50200000
                                                                        50205000
UNLK:                                                                   50210000
   UNLOC'ACB(ACBMQ,0);    << release ACB >>                             50215000
   END;      << conventional file >>                                    50220000
                                                                        50225000
   BEGIN     << Remote file >>                                          50230000
   SETRFAPTR;                                                  <<DS.00>>50235000
   RFALEN := 6;                                                <<DS.00>>50240000
   TOS := "RFA ";                                              <<DS.00>>50245000
   TOS := 15;                                                  <<DS.00>>50250000
   TOS := RFAFILE;                                             <<DS.00>>50255000
   TOS := CODE;                                                <<DS.00>>50260000
   TOS := PARAM;                                               <<DS.00>>50265000
   MWCNOBUF;                                                   <<DS.00>>50270000
   IF <> THEN                                                  <<DS.00>>50275000
      BEGIN                                                    <<DS.00>>50280000
      TOS := 0;                                                <<DS.00>>50285000
      TOS := RFALINE;                                          <<DS.00>>50290000
      TOS := DSCHKPLABEL;                                      <<DS.00>>50295000
      ASMB(PCAL 0);                                            <<DS.00>>50300000
$  IF X1 = ON                                                  <<DS.00>>50305000
      IF <> THEN FTROUBLE(486);                                         50310000
$  IF                                                          <<DS.00>>50315000
      GO ERROR;                                                <<DS.00>>50320000
      END;                                                     <<DS.00>>50325000
   TOS := RFALEN -2;                                           <<DS.00>>50330000
   ASMB(SUBS 0);      << delete appendage >>                   <<DS.00>>50335000
   PARAM := TOS;                                               <<DS.00>>50340000
   CTLA := 0;     << no error >>                               <<DS.00>>50345000
   TOS := TOS.CC;                                              <<DS.00>>50350000
   CONDCODE := TOS;                                            <<DS.00>>50355000
   END;     << remote file >>                                           50360000
      << dummy 2 >>;                                                    50365000
      << dummy 3 >>;                                                    50370000
      << dummy 4 >>;                                                    50375000
      << dummy 5 >>;                                                    50380000
   BEGIN   << KSAM file >>                                              50385000
   KCONTROL(FILENUM,CODE,PARAM);                               <<KS.00>>50390000
   PUSH(STATUS);                                               <<KS.00>>50395000
   TOS := TOS.CC;                                              <<KS.00>>50400000
   CONDCODE := TOS;    << report condition code >>             <<KS.00>>50405000
   CTLA := 0;     << no error >>                               <<KS.00>>50410000
   GO GETOUT;                                                  <<KS.00>>50415000
   END;   << KSAM file >>                                      <<KS.00>>50420000
   <<DUMMY 7>>;                                                <<HM.00>>50425000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>50430000
   IF IOQX <> 0 AND CODE <> 43 THEN                            <<03038>>50435000
      BEGIN        << No-wait I/O pending. >>                  <<03038>>50440000
      TOS := IOPENDING;                                        <<03038>>50445000
      GO ERR                                                   <<03038>>50450000
      END;                                                     <<03038>>50455000
   CTLA:=0; CONDCODE:=CCE;                                     <<HM.00>>50460000
   IF CODE = 2 THEN                            <<QUIESCE I/O>> <<HM.00>>50465000
      TOS:=SUCCESSFUL                                          <<HM.00>>50470000
   ELSE IF CODE = 3 THEN                       <<READ HW STATUS  HM.00>>50475000
      BEGIN                                                    <<HM.00>>50480000
      JUNK:=DEVICESTATUS(ACB'DADDR);                           <<HM.00>>50485000
      IF < THEN GO E1;  <<ERROR?>>                             <<HM.00>>50490000
      TOG:=TRUE;  <<SET RETURN FLAG>>                          <<HM.00>>50495000
      TOS:=SUCCESSFUL;                                         <<HM.00>>50500000
      END                                                      <<HM.00>>50505000
   ELSE IF CODE = 4 THEN                       <<SET TIMEOUT>> <<HM.00>>50510000
      TOS:=FCCONTROL(0,PARAM)                                  <<HM.00>>50515000
   ELSE IF CODE = 6 THEN                       <<WRITE EOF?>>  <<HM.00>>50520000
      TOS:=FCWRITEOF(0,0)                                      <<HM.00>>50525000
   ELSE IF CODE = 43 THEN                      <<ABORT I/O?>>  <<HM.00>>50530000
      BEGIN                                                    <<HM.00>>50535000
      CASE FCABORTREQUESTS(0,0) OF                             <<HM.00>>50540000
         BEGIN                                                 <<HM.00>>50545000
         BEGIN  <<A PENDING REQUEST WAS ABORTED>>              <<HM.00>>50550000
         TOS:=SUCCESSFUL;                                      <<HM.00>>50555000
         END;                                                  <<HM.00>>50560000
         BEGIN  <<A REQUEST HAS ALREADY COMPLETED>>            <<HM.00>>50565000
         CTLA:=0; CONDCODE:=CCG;                               <<HM.00>>50570000
         TOS:=SUCCESSFUL;                                      <<HM.00>>50575000
         UNLOC'ACB(ACBMQ,0);                                   <<HM.00>>50580000
         GO EXIT1;                                             <<HM.00>>50585000
         END;                                                  <<HM.00>>50590000
         BEGIN  <<NO I/O WAS OUTSTANDING>>                     <<HM.00>>50595000
         TOS:=NOIOPENDING2;                                    <<HM.00>>50600000
         END;                                                  <<HM.00>>50605000
         END;  <<CASE>>                                        <<HM.00>>50610000
      END                                                      <<HM.00>>50615000
   ELSE IF LOWMSGVAL <= CODE <= HIMSGVAL THEN <<MSG SPECIFIC?>><<HM.00>>50620000
      TOS:=FCCONTROL(CODE-LOWMSGVAL+1,PARAM)                   <<HM.00>>50625000
   ELSE                                        <<INVALID CODE>><<HM.00>>50630000
      TOS:=DEVVIOL;                                            <<HM.00>>50635000
   IF S0 <> SUCCESSFUL THEN GO ERR;                            <<HM.00>>50640000
   UNLOC'ACB(ACBMQ,0);                                         <<HM.00>>50645000
   END;                                                        <<HM.00>>50650000
                                                               <<DS.00>>50655000
   END;       << FTYPE CASE >>                                          50660000
EXIT1:                                                         <<HM.00>>50665000
                                                                        50670000
   <<* * * Measurement data on FCONTROL * * *>>                         50675000
                                                                        50680000
$  IF X3 = ON                                                           50685000
   IF MEAS'TAPE'ON THEN BEGIN                                           50690000
   IF ACB'ACCCL = DIRACC THEN                                           50695000
      MMSTAT'(EFCONTROL,FILENUM,CODE,0,0,0,0);                 <<06958>>50700000
   END; << OF MEAS'TAPE'ON>>                                            50705000
$  IF                                                                   50710000
                                                                        50715000
   IF TOG THEN PARAM := JUNK;  << Return value to user >>               50720000
                                                                        50725000
GETOUT:                                                                 50730000
   RESETCRITICAL(CRIT);                                                 50735000
   ERROREXIT(3,CTLA,0);                                                 50740000
   END;     << procedure FCONTROL >>                                    50745000
$PAGE " FDEVICECONTROL "                                                50750000
PROCEDURE FDEVICECONTROL(FILENO,TARGET,TCOUNT,CTRL,P1,P2,ERRNUM);       50755000
VALUE FILENO,TCOUNT,P1,P2,CTRL;                                         50760000
INTEGER FILENO,TCOUNT,ERRNUM,CTRL;                                      50765000
LOGICAL P1,P2;                                                          50770000
ARRAY TARGET;                                                           50775000
OPTION PRIVILEGED;                                                      50780000
                                                               <<02556>>50785000
COMMENT -- FDEVICECONTROL is an extension  of  FCONTROL  which <<04321>>50790000
can  handle arrays (TARGET) to be passed to a device.  Control <<04321>>50795000
codes less than FDEVICECONTROL's range (%100-%377, 64-255) are <<04321>>50800000
passed to FCONTROL.  Any error there will be returned  through <<04321>>50805000
the ERRNUM parameter.                                          <<04321>>50810000
  FDEVICECONTROL has the following restrictions:               <<04321>>50815000
1.  DB must be at the stack (that is, no split-stack calls).   <<04321>>50820000
2.  Only conventional and remote files (or $NULL) are support- <<04321>>50825000
    ed by FDEVICECONTROL. FCONTROL also supports KSAM and mes- <<04321>>50830000
    sage files, and these will continue to be  supported  from <<04321>>50835000
    FDEVICECONTROL  when the CTRL parameter indicates FCONTROL <<04321>>50840000
    processing.                                                <<04321>>50845000
3.  CTRL must be in the range 0 to %77 (63) to cause an  FCON- <<04321>>50850000
    TROL  call,  or  %100-%377 (64-255) for processing by FDE- <<04321>>50855000
    VICECONTROL.  Some of these condes may not presently apply <<04321>>50860000
    to any device.                                             <<04321>>50865000
  Error handling in the preliminary processing deserves a word <<02556>>50870000
or two.  For an error to be reported by FCHECK it must  be  in <<02556>>50875000
ACB'ERROR of the ACB (or PXFOPEN for FOPEN's, but that doesn't <<02556>>50880000
concern us).  The ACB for remote files lives with the file  on <<02556>>50885000
the remote system. To log an error there, we must get at least <<02556>>50890000
as far as the remote file code below.  We remember  the  first <<02556>>50895000
error  we find, ignoring all others, until we can report it to <<02556>>50900000
the remote file (if FILENO is a remote  file).  If  FILENO  is <<02556>>50905000
not remote, the error is reported locally.  In either case the <<02556>>50910000
intrinsic terminates after the error is processed.             <<02556>>50915000
  As part of the intrinsic operation, any error (or  0  if  no <<02556>>50920000
error)  is returned in ERRNUM.  Well, almost any error.  If we <<02556>>50925000
were called in split-stack mode (illegal  because  ERRNUM  and <<02556>>50930000
TARGET are reference parameters) or if we detect a bounds vio- <<02556>>50935000
lation on ERRNUM we can't return anything there. To handle all <<02556>>50940000
situations, LOCAL'FAILURE (used by the remote  file  code)  is <<02556>>50945000
used as a three-way flag. A -1 indicates a bounds violation on <<02556>>50950000
ERRNUM until it can be remoted to any remote file. A value > 0 <<02556>>50955000
is the File System error code for Illegal DB.  Finally, LOCAL' <<02556>>50960000
FAILURE = 0 means that ERRNUM is valid, use it (ERRNUM will be <<02556>>50965000
0 if there is no error).                                       <<02556>>50970000
;                                                              <<02556>>50975000
   BEGIN                                                                50980000
   COMMENT:  Parameter definitions:                            <<02556>>50985000
                                                                        50990000
     FILENO      -     File number of an opened devicefile.    <<04321>>50995000
                                                                        51000000
     TARGET      -     Data to be written to the devicefile.   <<04321>>51005000
                                                                        51010000
     TCOUNT      -     +words or -bytes of data in Target.              51015000
                                                                        51020000
     CTRL   -     Code for the operation to be performed.               51025000
      < %100  -  Call FCONTROL with this control code.         <<04321>>51030000
        %100  -  Download VFC (2608A, 2608S, 2631 only)        <<04333>>51035000
         101  -  Download Left Margin (2608A, 2608S only)      <<04321>>51040000
         200  -  Select Primary/Secondary Character Set        <<04321>>51045000
         201  -  Select Logical Pages/Forms                             51050000
         202  -  Move Pen Relative                                      51055000
         203  -  Move Pen Absolute                                      51060000
         204  -  Define Job Characteristics                             51065000
         205  -  Download Physical Page Definition                      51070000
         206  -  Download/Delete Character Set                          51075000
         207  -  Download/Delete Forms                                  51080000
         210  -  Download Logical Page Table                            51085000
         211  -  Download Multi-Copy Form Overlay Table                 51090000
         212  -  Download/Delete VFC                           <<04333>>51095000
         213  -  Download/Delete Pictures                      <<04140>>51100000
         214  -  Page Control                                  <<02576>>51105000
         215  -  Clear Environment                                      51110000
         216  -  Job Start, callable only in priv mode because <<04321>>51115000
                   it can clear billing info (# pages printed).<<04321>>51120000
         217  -  Load default Environment                               51125000
         220  -  Print Pictures                                <<04140>>51130000
         222  -  Set/clear device extended capability mode.    <<04321>>51135000
         300  -  Access LYNX2 terminal configuration file.              51140000
         301  -  Record processing information for NRJE spool  <<06956>>51145000
                 file.                                         <<06956>>51150000
                                                                        51155000
           All other CTRL's return an OPERATION INCONSISTENT   <<04321>>51160000
             WITH DEVICE TYPE error.                           <<04321>>51165000
                                                                        51170000
     P1          -     Additional control information...       <<02556>>51175000
                                                                        51180000
     P2          -     ... varies depending on CTRL.           <<02556>>51185000
                                                                        51190000
     ERRNUM      -     Returns error number.                            51195000
         126  -  ILL'CHAR'SET   - Character set number must be <<02556>>51200000
                                    between 0 and 31.          <<02556>>51205000
         127  -  ILL'FORM       - Form number must be between  <<02556>>51210000
                                    0 and 31.                  <<02556>>51215000
         128  -  ILL'LOG'PAGE   - Logical page number must be  <<02556>>51220000
                                    between 0 and 31.          <<02556>>51225000
         129  -  ILL'VFC        - Vertical format number must  <<02556>>51230000
                                    be between 0 and 31.       <<02556>>51235000
         130  -  ILL'NUMCOPIES  - Number of copies must be     <<02556>>51240000
                                    tween 1 and 32767.         <<02556>>51245000
         131  -  ILL'OVERLAY    - Number of overlays must be   <<02556>>51250000
                                    between 1 and 8.           <<02556>>51255000
         132  -  ILL'PAGELENGTH - Page length parameter must   <<02556>>51260000
                                    be between 12 (=3") and    <<02556>>51265000
                                    68 (=17").                 <<02556>>51270000
         133  -  ILL'PICTURE    - Picture number must be       <<04140>>51275000
                                  between 0 and 31.            <<04140>>51280000
         134  -  SET'OR'CLEAR   - Parameter must be 1 (set) or <<04321>>51285000
                                    or 0 (clear).              <<04321>>51290000
         or other FSERR (e.g., BNDVIOL, ILLDB, etc.).  If      <<02556>>51295000
         FDEVICECONTROL discovers a bounds violation on the    <<02556>>51300000
         ERRNUM parameter itself, it is not changed.           <<02556>>51305000
                                                                        51310000
                                                                        51315000
      Conditions Codes:                                                 51320000
      CCE - No error, ERRNUM := 0.                             <<02556>>51325000
      CCL - Error, ERRNUM := FSERR (or not modified if error   <<02556>>51330000
              is bounds violation on ERRNUM itself).           <<02556>>51335000
;                                                              <<02556>>51340000
                                                                        51345000
EQUATE                                                         <<02556>>51350000
  DOWNLOAD'VFC = %100,   << ATTACHIO function code.         >> <<04482>>51355000
  MAX'FDEVCTRL = %377,   << Maximum value of CTRL parameter >> <<04321>>51360000
  MIN'FDEVCTRL = %100,   << Minimum value of CTRL parameter >> <<04321>>51365000
  FSYSERR      = %25,    << File sys error for termtype file>> <<lynx>> 51370000
  REMOTE'FILE  =    1;   << File type of remote file.       >> <<02556>>51375000
   EQUATE UBND = -11;  <<Q rel upper bound for bounds check>>  <<03059>>51380000
   INTEGER                                                              51385000
      LDEV,           << Logical device number of FILENO.   >> <<04333>>51390000
      SENDCOUNT;                                                        51395000
                                                                        51400000
   LOGICAL                                                     <<04321>>51405000
      CRIT,                                                    <<04321>>51410000
      DEVICE'FLAGS;   << Environment requirements for CTRL. >> <<04333>>51415000
   LOGICAL POINTER TARGET'PT;                                           51420000
                                                               <<02556>>51425000
<< Remote File Access (RFA) variables.                      >> <<02556>>51430000
                                                               <<02556>>51435000
INTEGER POINTER                                                <<02556>>51440000
  RFAPTR;           << Message array (appendage) pointer.   >> <<02556>>51445000
                                                               <<02556>>51450000
INTEGER                                                        <<02556>>51455000
  TLOG,             << returned from ATTACHIO >>               <<lynx>> 51460000
  RFALEN;           << Length of appendage.                 >> <<02556>>51465000
                                                               <<02556>>51470000
LOGICAL                                                        <<02556>>51475000
  LOCAL'FAILURE;    << Error code to be entered in remote   >> <<02556>>51480000
                    << file's ACB'ERROR for use by FCHECK.  >> <<02556>>51485000
                                                                        51490000
 << Following LOC'ACB params must be last and in order: >>              51495000
   INTEGER ACBMQ;                                              <<04591>>51500000
   INTEGER AFTE;                                               <<02556>>51505000
   DOUBLE  PACBV;                                              <<06511>>51510000
   DOUBLE  LACBV;                                              <<06511>>51515000
   INTEGER IOQX;                                               <<02556>>51520000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;   << Q+13 >>           <<04321>>51525000
   BUILD'ACB;                                                           51530000
   INTEGER DSTX;                                                        51535000
 << end of LOC'ACB params >>                                            51540000
                                                                        51545000
   DEFINE INTRINEXIT = [10/0,6/7] #,                                    51550000
          BIT0       =(0:1)#,                                  <<02556>>51555000
          BIT1       =(1:1)#,                                  <<02556>>51560000
          BIT3       =(3:1)#,                                  <<02556>>51565000
          BIT4       =(4:1)#,                                  <<02556>>51570000
          BIT15      =(15:1)#,                                 <<lynx>> 51575000
          LOWER'BYTE =(8:8)#,                                  <<02556>>51580000
          UPPER'BYTE =(0:8)#,                                  <<02556>>51585000
          MUST'BE'HOT     = DEVICE'FLAGS.(14:1)#,              <<04321>>51590000
          MUST'BE'SPOOLED = DEVICE'FLAGS.(13:1)#,              <<04321>>51595000
          MUST'BE'PRIV    = DEVICE'FLAGS.(15:1)#;              <<04333>>51600000
                                                               <<02556>>51605000
SUBROUTINE CHECK'PREVIOUS'ERROR (THIS'ERROR);                  <<02556>>51610000
  VALUE THIS'ERROR;  INTEGER THIS'ERROR;                       <<02556>>51615000
                                                               <<02556>>51620000
BEGIN COMMENT -- checks for existence of a previously-detected <<02556>>51625000
error and sets the error code from  THIS'ERROR  if  none.  The <<02556>>51630000
tests must be in the order shown.                              <<02556>>51635000
;                                                              <<02556>>51640000
IF LOCAL'FAILURE = 0 AND ERRNUM = 0 THEN ERRNUM := THIS'ERROR; <<02556>>51645000
END;   << of CHECK'PREVIOUS'ERROR.                          >> <<02556>>51650000
                                                               <<02556>>51655000
                                                               <<02556>>51660000
INTEGER SUBROUTINE GET'ERROR;                                  <<02556>>51665000
                                                                        51670000
BEGIN COMMENT -- Returns  the  appropriate  error  code  after <<02556>>51675000
testing LOCAL'FAILURE for bounds violation or split-stack call.<<02556>>51680000
;                                                              <<02556>>51685000
GET'ERROR := IF LOCAL'FAILURE = %177777                        <<02556>>51690000
  THEN BNDVIOL   << on ERRNUM                               >> <<02556>>51695000
  ELSE IF LOCAL'FAILURE = 0                                    <<02556>>51700000
    THEN ERRNUM   << ERRNUM O.K.                            >> <<02556>>51705000
    ELSE LOCAL'FAILURE;   << We were called in split-stack. >> <<02556>>51710000
END;   << of GET'ERROR.                                        <<02556>>51715000
                                                               <<02556>>51720000
                                                               <<02556>>51725000
   ERRORON;                                                             51730000
   CRIT := SETCRITICAL;                                                 51735000
   LOCAL'FAILURE := 0;                                         <<02556>>51740000
   TOS := FBNDCHK (@ERRNUM, 1, UBND);                          <<03059>>51745000
   IF S0 = 1                                                            51750000
     THEN   << Split-stack call, put it on hold.            >> <<02556>>51755000
        BEGIN                                                  <<02556>>51760000
        DEL;                                                   <<02556>>51765000
        LOCAL'FAILURE := ILLDB;                                <<02556>>51770000
        END                                                    <<02556>>51775000
     ELSE                                                      <<02556>>51780000
        BEGIN   << Not a split-stack call.                  >> <<02556>>51785000
        IF NOT TOS                                             <<02556>>51790000
          THEN LOCAL'FAILURE := %177777   << BV on ERRNUM.  >> <<02556>>51795000
          ELSE ERRNUM := 0;   << Everything's rosy.         >> <<02556>>51800000
        IF FBNDVIOL (@TARGET, TCOUNT, UBND) THEN               <<03059>>51805000
          CHECK'PREVIOUS'ERROR (BNDVIOL);                      <<02556>>51810000
        IF CTRL < MIN'FDEVCTRL   << Assume FCONTROL call... >> <<04321>>51815000
           THEN IF GET'ERROR = 0  << if no errors yet.      >> <<04321>>51820000
              THEN BEGIN                                       <<04321>>51825000
                   FCONTROL (FILENO, CTRL, TARGET);            <<04321>>51830000
                                                               <<04321>>51835000
  COMMENT -- The FCHECK call below may return bum data if  the <<04321>>51840000
FCONTROL  error  is a local error but FILENO is a remote file. <<04321>>51845000
This is because FCONTROL does not put its local error code  in <<04321>>51850000
the  remote file's ACB, where FCHECK looks for it.  The kludgy <<04321>>51855000
%100000 assures that we return CCL in this  case  (at  EXIT0). <<04321>>51860000
If FCONTROL is ever fixed, that statement (and these comments) <<04321>>51865000
can be deleted.                                                <<04321>>51870000
;                                                              <<04321>>51875000
                   IF <> THEN                                  <<04321>>51880000
                      BEGIN                                    <<04321>>51885000
                      FCHECK (FILENO, ERRNUM);                 <<04321>>51890000
                      IF ERRNUM = 0 THEN ERRNUM := %100000;    <<04321>>51895000
                      END;                                     <<04321>>51900000
                   GO TO EXIT0;                                <<04321>>51905000
                   END    << of FCONTROL call.              >> <<04321>>51910000
              ELSE   << Previous error, can't do FCONTROL.  >> <<04321>>51915000
           ELSE      << Not in FCONTROL range.              >> <<04321>>51920000
           BEGIN                                               <<lynx>> 51925000
              IF NOT (MIN'FDEVCTRL <= CTRL <= MAX'FDEVCTRL)    <<04321>>51930000
                 THEN CHECK'PREVIOUS'ERROR (INVOP);            <<04321>>51935000
              IF (%102 <= CTRL <= %177) OR                     <<lynx>> 51940000
                 (%223 <= CTRL <= %277) OR                     <<lynx>> 51945000
                 (%302 <= CTRL <= %377) THEN                   <<07069>>51950000
                 CHECK'PREVIOUS'ERROR (INVOP);                 <<lynx>> 51955000
           END;                                                <<lynx>> 51960000
        END;   << Not a split-stack call.                   >> <<02556>>51965000
                                                               <<02556>>51970000
COMMENT -- LOC'ACB is one of those strange beasts which return <<02556>>51975000
values via a partial cutback of the parameter stack.  The rea- <<02556>>51980000
son is that it may be called in split-stack mode,  making  re- <<02556>>51985000
ference parameters impossible.  In this case, the first param- <<02556>>51990000
eter in the list is ignored but holds a  place  for  a  return <<02556>>51995000
value.  The same result could be obtained more cleanly by mak- <<02556>>52000000
ing LOC'ACB a typed procedure.  Maybe another time...          <<02556>>52005000
;                                                              <<02556>>52010000
   GET'ACB'Q'LOC;                                              <<04591>>52015000
   LOC'ACB (0, ACBMQ, FILENO, UMODE);                          <<02556>>52020000
   DSTX := TOS;                                                <<02556>>52025000
   IF < THEN                                                   <<02642>>52030000
      BEGIN   << Invalid file number.                       >> <<02642>>52035000
      CHECK'PREVIOUS'ERROR (INVFN);                            <<02556>>52040000
      GO TO EXIT0;                                             <<02556>>52045000
      END;    << of invalid file number.                    >> <<02642>>52050000
   IF > THEN GO TO EXIT0;   << $NULL.                       >> <<02642>>52055000
                                                               <<02556>>52060000
   IF DSTX <> 0 THEN CHECK'PREVIOUS'ERROR (ILLDB);             <<02556>>52065000
   IF FTYPE > REMOTE'FILE THEN                                 <<02556>>52070000
      BEGIN   << Only normal and remote files supported.    >> <<02556>>52075000
      CHECK'PREVIOUS'ERROR (UNIMPL);                           <<02556>>52080000
      IF FTYPE = MSG'TYPE THEN                                 <<02556>>52085000
         BEGIN                                                 <<02556>>52090000
STUFF'ACB:                                                     <<02556>>52095000
         ACB'ERROR := GET'ERROR;                               <<02556>>52100000
         GO RELACB;                                            <<02556>>52105000
         END;                                                  <<02556>>52110000
      GO TO EXIT0;                                             <<02556>>52115000
      END;    << of illegal file type.                      >> <<02556>>52120000
                                                               <<02556>>52125000
   CASE * FTYPE OF                                             <<02556>>52130000
    BEGIN                                                      <<02556>>52135000
                                                               <<02556>>52140000
      BEGIN   << 0 -- conventional file.                    >> <<02556>>52145000
      IF GET'ERROR <> 0 THEN GO STUFF'ACB;                     <<04321>>52150000
                                                                        52155000
  COMMENT -- This next call was designed to remove all  device <<04333>>52160000
and  environment  dependencies  from  FDEVICECONTROL and place <<04333>>52165000
them in a lower level access routine where other  callers  can <<04333>>52170000
access them too.  Maintenance and enhancements are much easier <<04333>>52175000
this way as well.  You call with an LDEV number and  the  CTRL <<04333>>52180000
code.  It returns a bit mask of required environments.  If the <<04333>>52185000
LDEV does not support a particular CTRL, VALIDDEVTYPE  returns <<04333>>52190000
FALSE.                                                         <<04333>>52195000
  For example, if LDEV is a 2680, the bit mask will  return  a <<04333>>52200000
requirement  that  the  device  be spooled.  If CTRL is one of <<04333>>52205000
those that reads status or an environment from the device, the <<04333>>52210000
bit mask will state that the device must be unspooled, or hot, <<04333>>52215000
since reads from a spooled device are not meaningful.          <<04333>>52220000
  If the device is spooled, CTRL may only be supported on some <<04333>>52225000
devices in its class.  To prevent VALIDDEVTYPE from  returning <<04333>>52230000
an error, LDEV is set to -1. This alerts VALIDDEVTYPE to check <<04333>>52235000
only that CTRL is supported on some device. This imposes other <<04333>>52240000
restrictions as well.  See the comments  in  VALIDDEVTYPE  for <<04333>>52245000
further details.                                               <<04333>>52250000
;                                                              <<04321>>52255000
     IF ACB'SPOOLED                                            <<04333>>52260000
        THEN LDEV := -1                                        <<04333>>52265000
        ELSE LDEV := ACB'DADDR;                                <<04333>>52270000
     IF NOT VALIDDEVTYPE (LDEV, CTRL, DEVICE'FLAGS) THEN       <<04333>>52275000
        CHECK'PREVIOUS'ERROR (DEVVIOL);                        <<04333>>52280000
     IF ACB'SPOOLED AND MUST'BE'HOT THEN                       <<04321>>52285000
        CHECK'PREVIOUS'ERROR (SPOOLILLOP);                     <<04321>>52290000
     IF NOT ACB'SPOOLED AND MUST'BE'SPOOLED THEN               <<04321>>52295000
        CHECK'PREVIOUS'ERROR (SPOOLDEVDOWN);                   <<04321>>52300000
     IF NOT (PRIVMODE) AND MUST'BE'PRIV THEN                   <<04321>>52305000
        CHECK'PREVIOUS'ERROR (ILLCAP);                         <<04321>>52310000
     IF ERRNUM <> 0 THEN GO TO NFG;                            <<04321>>52315000
                                                                        52320000
      << convert to positive byte count >>                     <<06167>>52325000
      IF TCOUNT > 0 THEN                                       <<lynx>> 52330000
         TCOUNT := TCOUNT&LSL(1)                               <<lynx>> 52335000
      ELSE                                                     <<lynx>> 52340000
         TCOUNT := -TCOUNT;                                    <<lynx>> 52345000
      ACB'P1 := P1;                                            <<06511>>52350000
      ACB'P2 := P2;                                            <<06511>>52355000
      @TARGET'PT := @TARGET;                                   <<02556>>52360000
                                                               <<04333>>52365000
<< Split relevant codes into ranges of %100.                >> <<04333>>52370000
                                                               <<04333>>52375000
      IF (MIN'FDEVCTRL <= CTRL <= %101) THEN                   <<lynx>> 52380000
         CASE * CTRL - %100 OF                                 <<04333>>52385000
          BEGIN                                                <<04333>>52390000
            BEGIN    << %100 - 2608A/2608S/2631 Download VFC>> <<04333>>52395000
            END;                                               <<04333>>52400000
                                                               <<04333>>52405000
            BEGIN    << %101 - 2608A/2608S Dwnld left mrgn. >> <<04333>>52410000
            END;                                               <<04333>>52415000
                                                               <<lynx>> 52420000
            << %102 - %177 reserved >>                         <<lynx>> 52425000
                                                               <<lynx>> 52430000
          END     << %100-%101 CASE                         >> <<lynx>> 52435000
      ELSE IF (%200 <= CTRL <= %222) THEN                      <<lynx>> 52440000
                                                               <<04333>>52445000
      CASE * CTRL-%200 OF                                      <<02556>>52450000
      BEGIN                                                             52455000
         BEGIN         << %200 - select character set >>                52460000
         IF P1.LOWER'BYTE > 31 OR P2.LOWER'BYTE > 31 THEN      <<02556>>52465000
            BEGIN                                                       52470000
            ERRNUM := ILL'CHAR'SET;                            <<02556>>52475000
NFG:        ACB'ERROR := ERRNUM;                               <<02556>>52480000
            GO RELACB;                                         <<02556>>52485000
            END;                                                        52490000
         END;                                                           52495000
                                                                        52500000
         BEGIN        << %201 - logical page selection >>               52505000
         IF P1.BIT0 AND P2.UPPER'BYTE > 31                     <<02556>>52510000
           OR P1.BIT1 AND P2.LOWER'BYTE > 31 THEN              <<02556>>52515000
            BEGIN                                                       52520000
            ERRNUM := ILL'LOG'PAGE;                            <<02556>>52525000
            GO NFG;                                                     52530000
            END;                                                        52535000
         END;                                                           52540000
                                                                        52545000
         BEGIN        << %202 - move pen relative >>                    52550000
         END;                                                           52555000
                                                                        52560000
         BEGIN        << %203 - move pen absolute >>                    52565000
         END;                                                           52570000
                                                                        52575000
         BEGIN        << %204 - define Job characteristics >>           52580000
         IF P1.BIT1 AND (P2 = 0 OR P2.BIT0) THEN               <<02556>>52585000
            BEGIN   << Too many (or 0) copies specified.    >> <<02556>>52590000
            ERRNUM := ILL'NUMCOPIES;                           <<02556>>52595000
            GO TO NFG;                                         <<02556>>52600000
            END;                                               <<02556>>52605000
         END;                                                           52610000
                                                                        52615000
         BEGIN  << %205 - download phys page & multi-copy overlay >>    52620000
         IF P1.BIT3 AND NOT (12 <= INTEGER (P1.LOWER'BYTE) <=  <<02556>>52625000
           68) THEN                                            <<02556>>52630000
            BEGIN  << Redefining page length w/ illgl lngth >> <<02556>>52635000
            ERRNUM := ILL'PAGELENGTH;                          <<02556>>52640000
            GO TO NFG;                                         <<02556>>52645000
            END;                                               <<02556>>52650000
         IF P1.BIT4 AND (P2 = 0 OR P2.BIT0) THEN               <<02556>>52655000
            BEGIN   << Redefining max copies w/ illgl num.  >> <<02556>>52660000
            ERRNUM := ILL'NUMCOPIES;                           <<02556>>52665000
            GO TO NFG;                                         <<02556>>52670000
            END;                                               <<02556>>52675000
         END;                                                           52680000
                                                                        52685000
         BEGIN      << %206 - download/delete character set >> <<02556>>52690000
         IF  P2.LOWER'BYTE > 31 THEN                           <<02556>>52695000
            BEGIN    << character set nr. out of range >>               52700000
            ERRNUM := ILL'CHAR'SET;                            <<02556>>52705000
            GO NFG;                                                     52710000
            END;                                                        52715000
         END;                                                           52720000
                                                                        52725000
         BEGIN        << %207 - download/delete form >>                 52730000
         IF P2.LOWER'BYTE > 31 THEN                            <<02556>>52735000
            BEGIN                                                       52740000
            ERRNUM := ILL'FORM;                                <<02556>>52745000
            GO NFG;                                                     52750000
            END;                                                        52755000
         END;                                                           52760000
                                                                        52765000
         BEGIN        << %210 - download logical page table >>          52770000
         END;                                                           52775000
                                                                        52780000
         BEGIN        << %211 - download multi-copy form overlay >>     52785000
         IF NOT (1 <= (TCOUNT&LSR(1)) <= 8) THEN               <<lynx>> 52790000
            BEGIN    << no more than 8 overlays. >>                     52795000
            ERRNUM := ILL'OVERLAY;                             <<02556>>52800000
            GO NFG;                                                     52805000
            END;                                                        52810000
         END;                                                           52815000
                                                                        52820000
         BEGIN       << %212 - Download/Delete VFC.         >> <<04333>>52825000
         IF P2.LOWER'BYTE > 31 THEN                            <<02556>>52830000
            BEGIN      << VFC number out of range. >>                   52835000
            ERRNUM := ILL'VFC;                                 <<02556>>52840000
            GO TO NFG;                                         <<02556>>52845000
            END;                                                        52850000
         END;                                                           52855000
                                                                        52860000
         BEGIN       << %213 - Download/Delete Picture >>      <<04140>>52865000
         IF P2.LOWER'BYTE > 31 THEN                            <<04140>>52870000
            BEGIN    << picture number out of range >>         <<04140>>52875000
            ERRNUM := ILL'PICTURE;                             <<04140>>52880000
            GO TO NFG;                                         <<04140>>52885000
            END;                                               <<04140>>52890000
         END;                                                  <<04140>>52895000
                                                                        52900000
         BEGIN        << %214 - page control                >> <<02576>>52905000
         IF P2.LOWER'BYTE > 31 THEN                            <<02576>>52910000
            BEGIN                                              <<02576>>52915000
            ERRNUM := ILL'LOG'PAGE;                            <<02576>>52920000
            GO TO NFG;                                         <<02576>>52925000
            END;                                               <<02576>>52930000
         END;                                                  <<02576>>52935000
                                                                        52940000
         BEGIN       << %215 - clear Environment >>            <<02556>>52945000
         END;                                                           52950000
                                                                        52955000
         BEGIN       << %216 - Job Open                     >> <<04321>>52960000
         END;                                                  <<04321>>52965000
                                                                        52970000
         BEGIN       << %217 - load default Environment >>     <<02556>>52975000
         END;                                                           52980000
                                                               <<04140>>52985000
         BEGIN       << %220 - Print Picture >>                <<04140>>52990000
         IF P1.BIT0 AND P2.LOWER'BYTE > 31 THEN                <<04140>>52995000
            BEGIN  << picture number > 31 -- out of range >>   <<04140>>53000000
            ERRNUM := ILL'PICTURE;                             <<04140>>53005000
            GO TO NFG;                                         <<04140>>53010000
            END;                                               <<04140>>53015000
         END;                                                  <<04140>>53020000
                                                                        53025000
         BEGIN       << %221 = 145 - End of Job             >> <<04321>>53030000
         END;                                                  <<04321>>53035000
                                                               <<04321>>53040000
         BEGIN       << %222 = 146 - Device extended capa-  >> <<04321>>53045000
                     <<              bility mode.           >> <<04321>>53050000
         IF P1 > 1 THEN                                        <<04321>>53055000
            BEGIN   << 1 = set, 0 = clear, others illegal.  >> <<04321>>53060000
            ERRNUM := SET'OR'CLEAR;                            <<04321>>53065000
            GO TO NFG;                                         <<04321>>53070000
            END;                                               <<04321>>53075000
         END;                                                  <<04321>>53080000
                                                               <<lynx>> 53085000
         << %223 - %277 reserved >>                            <<lynx>> 53090000
                                                               <<lynx>> 53095000
      END        << %200-%222 CASE                          >> <<lynx>> 53100000
                                                               <<04333>>53105000
      ELSE IF (%300 <= CTRL <= %301) THEN                      <<06956>>53110000
        CASE *CTRL - %300 OF                                   <<06956>>53115000
         BEGIN                                                 <<06956>>53120000
           BEGIN   << %300 - access terminal config file >>    <<lynx>> 53125000
              IF ACB'READ AND ACB'SPOOLED THEN                 <<*7993>>53130000
               << can't have read from spooled device >>       <<lynx>> 53135000
              BEGIN                                            <<lynx>> 53140000
                 ERRNUM := SPOOLILLOP;                         <<lynx>> 53145000
                 GO TO NFG;                                    <<lynx>> 53150000
              END;                                             <<lynx>> 53155000
           END;                                                <<06956>>53160000
                                                               <<06956>>53165000
           BEGIN   << %301 - record NRJE spoofle information >><<06956>>53170000
           END;                                                <<06956>>53175000
         END      << case %300 - %301 >>                       <<06956>>53180000
                                                               <<06956>>53185000
         ELSE CASE *CTRL - %370 OF                             <<lynx>> 53190000
            BEGIN                                              <<04333>>53195000
                                                               <<lynx>> 53200000
              << %302 - %367 reserved >>                       <<06956>>53205000
                                                               <<lynx>> 53210000
                                                               <<04333>>53215000
              BEGIN   << %370 - Kanji function, no parms.   >> <<04333>>53220000
              END;                                             <<04333>>53225000
                                                               <<04333>>53230000
              BEGIN   << %371 - Kanji function, no parms.   >> <<04333>>53235000
              END;                                             <<04333>>53240000
                                                               <<04333>>53245000
              BEGIN   << %372 - Kanji function, no parms.   >> <<04333>>53250000
              END;                                             <<04333>>53255000
                                                               <<04333>>53260000
              BEGIN   << %373 - Kanji function, no parms.   >> <<04333>>53265000
              END;                                             <<04333>>53270000
                                                               <<04333>>53275000
              BEGIN   << %374 - Kanji function, no parms.   >> <<04333>>53280000
              END;                                             <<04333>>53285000
                                                               <<04333>>53290000
              BEGIN   << %375 - Kanji function, no parms.   >> <<04333>>53295000
              END;                                             <<04333>>53300000
                                                               <<04333>>53305000
              BEGIN   << %376 - Kanji function, no parms.   >> <<04333>>53310000
              END;                                             <<04333>>53315000
                                                               <<04333>>53320000
              BEGIN   << %377 - Kanji function, no parms.   >> <<04333>>53325000
              END;                                             <<04333>>53330000
            END;   << %370 - %377 CASE.                     >> <<lynx>> 53335000
                                                               <<04321>>53340000
      IF ACB'SPOOLED                                           <<04321>>53345000
         THEN                                                  <<04321>>53350000
            BEGIN                                              <<04321>>53355000
                                                                        53360000
    << Write data out to spoofle. >>                                    53365000
                                                                        53370000
<< 2608x printers don't support the continuation record pro->> <<04482>>53375000
<< tocol the way the 2680 does.  This means that VFC  down- >> <<04482>>53380000
<< loads  must  be done in one record.  To achieve this, we >> <<04482>>53385000
<< fool both this code and IOMOVE by temporarily  expanding >> <<04482>>53390000
<< the  size of ACB'SPREC to larger than the largest possi- >> <<04482>>53395000
<< ble VFC file.  The VFC download function is not valid on >> <<04482>>53400000
<< the 2680. If used, it will be caught when the spoofle is >> <<04482>>53405000
<< printed.  Note that this problem doesn't arise  for  hot >> <<04482>>53410000
<< devices  (below),  because  they  get the entire TCOUNT. >> <<04482>>53415000
<< This code is a short-term fix, and  should  be  replaced >> <<04482>>53420000
<< when a better long-term solution is available.           >> <<04482>>53425000
                                                               <<04482>>53430000
            DEVICE'FLAGS := ACB'SPREC;   << Temp store.     >> <<04482>>53435000
            IF CTRL = DOWNLOAD'VFC THEN ACB'SPREC := 500;      <<04482>>53440000
            SENDCOUNT := ACB'SPREC;                            <<07398>>53445000
            ACB'CTL := %320;  << Don't kill trailing blanks >>          53450000
                                                                        53455000
<< if SENDCOUNT is odd, truncate last bit to get    >>         <<06167>>53460000
<< even byte count before rounding to words.        >>         <<06167>>53465000
           SENDCOUNT.(15:1) := 0;                              <<06167>>53470000
            DO BEGIN                                                    53475000
               IF SENDCOUNT > TCOUNT THEN SENDCOUNT := TCOUNT;          53480000
                                                               <<02556>>53485000
<< No values may be stacked when IOMOVE is called.          >> <<02556>>53490000
                                                               <<02556>>53495000
               IOMOVE(CTRL,TARGET'PT,-SENDCOUNT);              <<lynx>> 53500000
               IF ACB'STATUS <> 1 THEN                                  53505000
                  BEGIN                                                 53510000
                  ERRNUM := ACB'ERROR;                                  53515000
                                                               <<02578>>53520000
<< The following kludge assures returning  CCL  on  an  EOF >> <<02578>>53525000
<< error (FSERR 0).                                         >> <<02578>>53530000
                                                               <<02578>>53535000
                  IF ERRNUM = 0 THEN ERRNUM := %100000;                 53540000
                  GO RELACB;                                            53545000
                  END;                                                  53550000
                                                                        53555000
               ACB'P2.(0:1) := 1;    << continuation record >> <<06511>>53560000
               @TARGET'PT := @TARGET'PT+(SENDCOUNT&LSR(1));    <<06167>>53565000
               TCOUNT := TCOUNT-SENDCOUNT;                              53570000
               END UNTIL <=;                                            53575000
            ACB'SPREC := DEVICE'FLAGS;                         <<04482>>53580000
            END   << of spooled output.                     >> <<04321>>53585000
         ELSE                                                  <<04321>>53590000
            BEGIN   << Non-spooled (hot) output device.     >> <<04321>>53595000
                                                               <<04321>>53600000
<< No values may be stacked when FQUIESCE'IO is called.     >> <<04321>>53605000
                                                               <<04321>>53610000
            IF NOT ACB'INHIBITBUF THEN FQUIESCE'IO (0);        <<04321>>53615000
            TOS := ATTACHIO (ACB'DADDR,   << LDEV number    >> <<04321>>53620000
                             0,           << QMISC          >> <<04321>>53625000
                             0,           << Dataseg #      >> <<04321>>53630000
                                          <<   (0 = stack)  >> <<04321>>53635000
                             @TARGET,     << DB-rel offset  >> <<04321>>53640000
                                          <<   in dataseg   >> <<04321>>53645000
                             CTRL,        << Function code  >> <<04321>>53650000
                             -TCOUNT,                          <<lynx>> 53655000
                             P1,                               <<04321>>53660000
                             P2,                               <<04321>>53665000
                             BFLAGS);                          <<04321>>53670000
            TLOG := TOS;   << save TLOG as well >>             <<lynx>> 53675000
            ACB'STATUS := S0;  << Should save status though >> <<04321>>53680000
            IF TOS.GENERAL'STATUS <> NO'ERR'STAT THEN          <<04321>>53685000
               BEGIN                                           <<04321>>53690000
               IF ACB'STATUS <> FSYSERR THEN                   <<lynx>> 53695000
                  ERRNUM := ACB'ERROR := IOSTAT (ACB'STATUS)   <<lynx>> 53700000
               ELSE                                            <<lynx>> 53705000
                  ERRNUM := ACB'ERROR := TLOG;                 <<lynx>> 53710000
                                                               <<04321>>53715000
<< The following kludge assures returning  CCL  on  an  EOF >> <<04321>>53720000
<< error (FSERR 0).                                         >> <<04321>>53725000
                                                               <<04321>>53730000
               IF ERRNUM = 0 THEN ERRNUM := %100000;           <<04321>>53735000
               END;                                            <<04321>>53740000
            END;   << Non-spooled (hot) output device.      >> <<04321>>53745000
                                                               <<04321>>53750000
RELACB:                                                                 53755000
      UNLOC'ACB(ACBMQ,0);                                               53760000
EXIT0:                                                         <<02556>>53765000
      TOS := GET'ERROR;                                        <<02556>>53770000
      IF S0 = 0 THEN TOS := CCE ELSE TOS := CCL;               <<02556>>53775000
      S1 := S1 & LSL(1) & LSR(1);  << Clear bit0 if temp EOF>> <<02578>>53780000
      END;    << 0 -- conventional file.                    >> <<02556>>53785000
                                                               <<02556>>53790000
      BEGIN   << 1 -- remote file.                          >> <<02556>>53795000
COMMENT --                                                     <<02556>>53800000
  This section builds the message array for the  DS  interface <<02556>>53805000
procedure  MANAGEWRITECONVERSATION,  calls  the  procedure and <<02556>>53810000
then processes the results.  In keeping with the other intrin- <<02556>>53815000
sics, the message array will be built on the top of stack, al- <<02556>>53820000
though maintenance of such a structure can be quite difficult. <<02556>>53825000
The other side of the coin is that the array is allocated only <<02556>>53830000
when needed (that is, for accessing a remote file), thus  con- <<02556>>53835000
serving the stack.                                             <<02556>>53840000
  The DS software allocates us one record's  worth  of  buffer <<02556>>53845000
space,  based on the record size of the spoofle at FOPEN time. <<02556>>53850000
Since our remote requests may involve  larger  size  transfers <<02556>>53855000
(which  the  remote  FDEVICECONTROL  will  break  into smaller <<02556>>53860000
units), we must structure them in a  manner  similar  to  that <<02556>>53865000
used by the remote FWRITE code for multi-record transfers.  We <<02556>>53870000
require two calls to the DS interface  procedure  MANAGEWRITE- <<02556>>53875000
CONVERSATION. The first call passes the message array (append- <<02556>>53880000
age) which includes the total transfer length but  a  0-length <<02556>>53885000
transfer  in  the  MANAGEWRITECONVERSATION  call itself.  This <<02556>>53890000
alerts the DS code to allocate a buffer large enough  to  hold <<02556>>53895000
the  transfer  but  does not perform the transfer itself.  The <<02556>>53900000
second call does not require an  appendage  but  includes  the <<02556>>53905000
proper length in the MANAGEWRITECONVERSATION call.             <<02556>>53910000
  The fully-built stack (just before the first call to MANAGE- <<02556>>53915000
WRITECONVERSATION) looks like this:                            <<02556>>53920000
                                                               <<02556>>53925000
    +-------------------------------+                          <<02556>>53930000
    | Message array (appendage) for |                          <<02556>>53935000
    | MANAGEWRITECONVERSATION       |                          <<02556>>53940000
    | (see below)                   |                          <<02556>>53945000
    +-------------------------------+                          <<02556>>53950000
    | DS parameters                 | \                        <<02556>>53955000
    | . . . . . . . . . . . . . . . |  \                       <<02556>>53960000
    | @appendage (stack-DB-relative)|   |                      <<02556>>53965000
    | . . . . . . . . . . . . . . . |   |                      <<02556>>53970000
    | Length of appendage           |   |                      <<02556>>53975000
    | . . . . . . . . . . . . . . . |   |  MANAGEWRITE         <<02556>>53980000
    | @data array TO remote (TARGET)|    > CONVERSATION        <<02556>>53985000
    | . . . . . . . . . . . . . . . |   |  parameters          <<02556>>53990000
    | Length of TO array (TCOUNT)   |   |                      <<02556>>53995000
    | . . . . . . . . . . . . . . . |   |                      <<02556>>54000000
    | @data array FROM remote (0)   |   |                      <<02556>>54005000
    | . . . . . . . . . . . . . . . |  /                       <<02556>>54010000
    | Length of FROM array (0)      | /                        <<02556>>54015000
    +-------------------------------+                          <<02556>>54020000
                                                               <<02556>>54025000
  Detail of message array for MANAGEWRITECONVERSATION:         <<02556>>54030000
                                                               <<02556>>54035000
                         1 1 1 1 1 1                           <<02556>>54040000
     0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5      WORD                 <<02556>>54045000
    +---------------+---------------+                          <<02556>>54050000
    |      "R"      |      "F"      |       0                  <<02556>>54055000
    +---------------+---------------+                          <<02556>>54060000
    |      "A"      |     blank     |       1                  <<02556>>54065000
    +---------------+---------------+                          <<02556>>54070000
    | LOCAL'FAILURE | FDEVICECONTROL|       2                  <<02556>>54075000
    |               | DS-code (=%65)|                          <<02556>>54080000
    +---------------+---------------+                          <<02556>>54085000
    | RFA file number               |       3                  <<02556>>54090000
    +-------------------------------+                          <<02556>>54095000
    | TCOUNT parameter              |       4                  <<02556>>54100000
    +-------------------------------+                          <<02556>>54105000
    | CTRL (controlcode) parameter  |       5                  <<02556>>54110000
    +-------------------------------+                          <<02556>>54115000
    | P1 parameter                  |       6                  <<02556>>54120000
    +-------------------------------+                          <<02556>>54125000
    | P2 parameter                  |       7                  <<02556>>54130000
    +-------------------------------+                          <<02556>>54135000
                                                               <<02556>>54140000
The DS interface generates three reply structures:             <<02556>>54145000
  a)  A Head Section, used only by DS, which we never see.     <<02556>>54150000
  b)  An Appendage  section  consisting  only  of  the  remote <<02556>>54155000
      FDEVICECONTROL status word (word 0) and ERRNUM parameter <<02556>>54160000
      (word 1). They overlay (words 0 and 1 of) our appendage, <<02556>>54165000
      that is, our message array and are available  after  the <<02556>>54170000
      second call to MANAGEWRITECONVERSATION.                  <<02556>>54175000
  c)  The one-word result of MANAGEWRITECONVERSATION, which is <<02556>>54180000
      discarded for both calls.                                <<02556>>54185000
;                                                              <<02556>>54190000
      LOCAL'FAILURE := GET'ERROR;   << Past sins hurt now.  >> <<02556>>54195000
      IF LOCAL'FAILURE <> 0 THEN TCOUNT := 0;                  <<02556>>54200000
                                                               <<02556>>54205000
      SETRFAPTR;     << Build message array on TOS.         >> <<02556>>54210000
      RFALEN := 8;   << Length of message array (appendage) >> <<02556>>54215000
      TOS := "RFA ";                                           <<02556>>54220000
      TOS := %65;    << FDEVCTRL DS code = intrinsic number >> <<02556>>54225000
      LOAD'ERROR;    << Add LOCAL'FAILURE in left byte.     >> <<02556>>54230000
      TOS := RFAFILE;                                          <<02556>>54235000
      TOS := TCOUNT;                                           <<02556>>54240000
      TOS := CTRL;                                             <<02556>>54245000
      TOS := P1;                                               <<02556>>54250000
      TOS := P2;                                               <<02556>>54255000
      GETMWCPARMS;   << Stack MANAGEWRITE... boilerplate.   >> <<02556>>54260000
      TOS := 0D;     << TARGET, TCOUNT omitted first time.  >> <<02556>>54265000
      TOS := 0D;     << Parameters of received    data.     >> <<02556>>54270000
      TOS := MWCPLABEL;                                        <<02556>>54275000
      ASSEMBLE (PCAL 0);   << Never thought we'd get here!  >> <<02556>>54280000
      DEL;                 << Don't need transfer length.   >> <<02556>>54285000
      CHECKXFER;   << Checks for DS err, not FDEVCTRL error >> <<02556>>54290000
      IF LOCAL'FAILURE = 0 THEN                                <<02556>>54295000
         BEGIN   << O.K. to do second MWC call.                <<02556>>54300000
         RFALEN := 0;   << No appendage required this time. >> <<02556>>54305000
         GETMWCPARMS;   << Stack MWC boilerplate again.     >> <<02556>>54310000
         TOS := @TARGET;   << Send TARGET, TCOUNT this time >> <<02556>>54315000
         TOS := TCOUNT;                                        <<02556>>54320000
         TOS := 0D;        << No data coming back.          >> <<02556>>54325000
         TOS := MWCPLABEL;                                     <<02556>>54330000
         ASSEMBLE (PCAL 0);                                    <<02556>>54335000
         DEL;                                                  <<02556>>54340000
         CHECKXFER;                                            <<02556>>54345000
         RFALEN := 8;   << Leave it like we found it.       >> <<02556>>54350000
         END;           << of second MWC call.              >> <<02556>>54355000
                                                               <<02556>>54360000
<< The following kludge is here only to  make  DELAPPENDAGE >> <<02556>>54365000
<< work but leave two words on the stack. It usually leaves >> <<02556>>54370000
<< only one.                                                >> <<02556>>54375000
                                                               <<02556>>54380000
      RFALEN := RFALEN - 1;                                    <<02556>>54385000
      DELAPPENDAGE;   << Cut back stack to status, errnum.  >> <<02556>>54390000
      ASSEMBLE (XCH);                                          <<02556>>54395000
      ERRNUM := S1;   << This is remote FDEVCTRL ERRNUM.    >> <<02556>>54400000
      TOS := TOS.CC;  << And this is remote FDEVCTRL CC.    >> <<02556>>54405000
      END;    << 1 -- remote file.                          >> <<02556>>54410000
                                                               <<02556>>54415000
    END;   << CASE statement.                               >> <<02556>>54420000
                                                               <<02556>>54425000
EXIT:                                                                   54430000
   CONDCODE := TOS;                                            <<02556>>54435000
   RESETCRITICAL(CRIT);                                                 54440000
   ERROREXIT (INTRINEXIT, S0, 0);                              <<02556>>54445000
   END;                                                                 54450000
$PAGE " FSETMODE "                                                      54455000
$CONTROL SEGMENT = FILESYS2   << FSETMODE >>                            54460000
PROCEDURE FSETMODE(FN,FLAGS);                                           54465000
   << Used to change access mode flags for the specified file.          54470000
                                                                        54475000
     Input variables:                                                   54480000
         FN - file number                                               54485000
         FLAGS - new access modes                                       54490000
            BIT 12 - report tape error recovery                         54495000
            BIT 13 - inhibit terminal CR/LF (line control)              54500000
            BIT 14 - critical output verification                       54505000
                                                                        54510000
     Condition code:                                                    54515000
         CCE - request granted                                          54520000
         CCL - request denied because of error.                         54525000
                                                                        54530000
     All modes must be re-specified on each call.   >>                  54535000
VALUE FN,FLAGS;                                                         54540000
INTEGER FN;                                                             54545000
LOGICAL FLAGS;                                                          54550000
OPTION PRIVILEGED;                                                      54555000
   BEGIN                                                                54560000
   INTEGER CRIT;        << for SETCRITICAL >>                           54565000
                                                                        54570000
   << Remote file access (RFA) variables: >>                            54575000
                                                                        54580000
   INTEGER POINTER RFAPTR;    << appendage pointer >>                   54585000
   INTEGER RFALEN;            << appendage length >>                    54590000
   INTEGER DEV'SUBTYPE;                                        <<07285>>54595000
   DOUBLE ATTIO'STATUS;                                        <<07285>>54600000
   INTEGER WAITIO'STATUS = ATTIO'STATUS;                       <<07285>>54605000
   DEFINE IO'ERR'STAT    = WAITIO'STATUS.(8:8)#;               <<07285>>54610000
                                                                        54615000
<< Following LOC'ACB params must be in order: >>                        54620000
   INTEGER ACBMQ;                                              <<06511>>54625000
   INTEGER AFTE;       << AFT entry word 0 >>                           54630000
   DOUBLE  PACBV;                                              <<06511>>54635000
   DOUBLE  LACBV;                                              <<06511>>54640000
   INTEGER IOQX;                                                        54645000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>54650000
BUILD'ACB;                                                     <<06511>>54655000
                                                                        54660000
   INTEGER DSTX;       << User's DB setting - must be last >>           54665000
                                                                        54670000
$  IF X0 = ON                                                           54675000
   IF MONCALLABLE THEN                                                  54680000
      BEGIN       << monitoring >>                                      54685000
      FTITLE("FSET","MODE",0D,0D);                                      54690000
      DEBUG                                                             54695000
      END;                                                              54700000
$  IF                                                                   54705000
                                                                        54710000
   ERRORON;                                                             54715000
   CRIT := SETCRITICAL;                                                 54720000
   GET'ACB'Q'LOC;                                              <<06511>>54725000
   LOC'ACB(*,ACBMQ,FN,UMODE);    << get ACB >>                 <<06511>>54730000
   IF < THEN                                                            54735000
      BEGIN          << Invalid file number >>                          54740000
      TOS := INVFN;  << error nr. >>                                    54745000
      TOS := CCL;    << error condition code >>                         54750000
      GO EXIT                                                           54755000
      END;                                                              54760000
   IF > THEN                                                            54765000
      BEGIN         << File is $NULL >>                                 54770000
      TOS := 0;    << No error >>                                       54775000
      TOS := CCE;  << OK condition code >>                              54780000
      GO EXIT                                                           54785000
      END;                                                              54790000
   CASE * FTYPE OF                                                      54795000
   BEGIN                                                                54800000
                                                                        54805000
   BEGIN     << Conventional file >>                                    54810000
   IF IOQX <> 0 THEN                                                    54815000
      BEGIN       << No-wait I/O pending. >>                            54820000
      TOS := IOPENDING;                                                 54825000
      ACB'ERROR := S0;  << error nr. >>                                 54830000
      TOS := CCL;     << error condition code >>                        54835000
      GO UNLK                                                           54840000
      END;                                                              54845000
   ACB'SETMODE := FLAGS;  << Update the mode >>                <<06048>>54850000
                                                               <<07285>>54855000
   <<------------------------------------------------------->> <<07285>>54860000
   << For HP7974 and HP7978, we can turn on or off the      >> <<07285>>54865000
   << immediate reporing facility using the critical output >> <<07285>>54870000
   << verification bit sent by the user.  We use ATTIO func >> <<07285>>54875000
   << 29 and P2=1 means turn off, P2=0 mean leave it on.    >> <<07285>>54880000
   << The default is to have immediate reporting on.        >> <<07285>>54885000
   <<------------------------------------------------------->> <<07285>>54890000
                                                               <<07285>>54895000
   ACB'ERROR := 0;                                             <<07285>>54900000
   DEV'SUBTYPE := LDEVTOSUBTYPE(ACB'DADDR);                    <<07285>>54905000
   IF ACB'DTYPE = MTAPE AND (DEV'SUBTYPE = HP7974 OR           <<07285>>54910000
                             DEV'SUBTYPE = HP7978) THEN        <<07285>>54915000
      BEGIN   << Proper tape drives, set the reporting.     >> <<07285>>54920000
      ATTIO'STATUS := ATTACHIO(ACB'DADDR,0,0,0,29,0,0,         <<07285>>54925000
                               ACB'QUIESCE,BFLAGS);            <<07285>>54930000
      IF IO'ERR'STAT <> 1 THEN                                 <<07285>>54935000
         ACB'ERROR := IOSTAT(IO'ERR'STAT);                     <<07285>>54940000
      END;                                                     <<07285>>54945000
   TOS := ACB'ERROR;             << Set up ERROREXIT parms, >> <<07285>>54950000
   TOS := IF ACB'ERROR = 0       << error and CC.           >> <<07285>>54955000
             THEN CCE                                          <<07285>>54960000
             ELSE CCL;                                         <<07285>>54965000
                                                                        54970000
   <<* * * Measurement data on FSETMODE ** * *>>                        54975000
                                                                        54980000
$  IF X3 = ON                                                           54985000
   IF MEAS'TAPE'ON THEN BEGIN                                           54990000
   IF ACB'ACCCL = DIRACC THEN                                  <<06958>>54995000
      MMSTAT'(EFSETMODE,FN,FLAGS,0,0,0,0);                     <<06958>>55000000
   END;    << of MEAS'TAPE'ON>>                                         55005000
$  IF                                                                   55010000
                                                                        55015000
UNLK:                                                                   55020000
   UNLOC'ACB(ACBMQ,0);       << release ACB >>                 <<06511>>55025000
   END;      << conventional file >>                                    55030000
                                                                        55035000
   BEGIN    << Remote file >>                                           55040000
   SETRFAPTR;                                                  <<DS.00>>55045000
   RFALEN := 5;                                                <<DS.00>>55050000
   TOS := "RFA ";                                              <<DS.00>>55055000
   TOS := 16;                                                  <<DS.00>>55060000
   TOS := RFAFILE;                                             <<DS.00>>55065000
   TOS := FLAGS;                                               <<DS.00>>55070000
   MWCNOBUF;                                                   <<DS.00>>55075000
   CHECKXFER;                                                  <<DS.00>>55080000
   DELAPPENDAGE;                                               <<DS.00>>55085000
   PREPRETURN;                                                 <<DS.00>>55090000
   END;     << Remote file >>                                           55095000
                                                                        55100000
      << dummy 2 >>;                                                    55105000
      << dummy 3 >>;                                                    55110000
      << dummy 4 >>;                                                    55115000
      << dummy 5 >>;                                                    55120000
   BEGIN   << KSAM file >>                                              55125000
   KSETMODE(FN,FLAGS);                                         <<KS.00>>55130000
   PUSH(STATUS);                                               <<KS.00>>55135000
   TOS := TOS.CC;    << report condition code >>               <<KS.00>>55140000
   ASMB(ZERO,XCH);                                             <<KS.00>>55145000
   END;  << KSAM file >>                                       <<KS.00>>55150000
   <<DUMMY>>;                                                  <<HM.00>>55155000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>55160000
   TOS:=0;                                                     <<HM.00>>55165000
   TOS:=CCE;                                                   <<HM.00>>55170000
   UNLOC'ACB(ACBMQ,0);   <<RELEASE THE ACB>>                   <<06511>>55175000
   END;                                                        <<HM.00>>55180000
   END;       << FTYPE case >>                                          55185000
                                                                        55190000
EXIT:                                                                   55195000
   CONDCODE := TOS;  << Report condition code >>                        55200000
   RESETCRITICAL(CRIT);                                                 55205000
   ERROREXIT(2,S0,0)                                                    55210000
   END;          << procedure FSETMODE >>                               55215000
$PAGE " FRELATE "                                                       55220000
$CONTROL SEGMENT = FILESYS2   << FRELATE >>                             55225000
LOGICAL PROCEDURE FRELATE(FN1,FN2);                                     55230000
VALUE FN1,FN2;                                                          55235000
INTEGER FN1,FN2;                                                        55240000
OPTION PRIVILEGED;                                                      55245000
   BEGIN                                                                55250000
   INTEGER CRIT;       << for SETCRITICAL >>                            55255000
   INTEGER LD1;        << FN1's log. dev. nr.>>                         55260000
   INTEGER LD2;        << FN2's log. dev. nr.>>                         55265000
   INTEGER TEMP;      << Default output log. dev. nr. for LD1>>         55270000
   INTEGER PCBGLOBLOC;                                         <<06510>>55275000
   LOGICAL LTEMP;                                              <<06510>>55280000
<< Following LOC'ACB params must be in order: >>                        55285000
   INTEGER ACBMQ;                                              <<06511>>55290000
   INTEGER AFTE;                                                        55295000
   DOUBLE  PACBV;                                              <<06511>>55300000
   DOUBLE  LACBV;                                              <<06511>>55305000
   INTEGER IOQX;                                                        55310000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>55315000
    BUILD'ACB;                                                 <<06511>>55320000
   INTEGER DSTX;       << user's buffer DST >>                          55325000
   << End of LOC'ACB params >>                                          55330000
                                                                        55335000
   INTEGER SUBROUTINE LDN (FN);                                         55340000
      << Returns the logical device number from the ACB for the         55345000
         specified file number.                                         55350000
                                                                        55355000
        Input variables:                                                55360000
            FN - file number                                            55365000
                                                                        55370000
        Output variables:                                               55375000
            LDN - logical device number                                 55380000
                                                                        55385000
       Returns 0 for invalid files; exits the procedure with CCG if     55390000
       the file is $NULL.        >>                                     55395000
                                                                        55400000
   VALUE FN;                                                            55405000
   INTEGER FN;                                                          55410000
      BEGIN                                                             55415000
      GET'ACB'Q'LOC;                                           <<06511>>55420000
      LOC'ACB(0,ACBMQ,FN,UMODE);                               <<06511>>55425000
      DEL;      << don't need DSTX >>                                   55430000
      IF < THEN GO SXIT;    << invalid file nr. >>                      55435000
      IF > THEN                                                         55440000
         BEGIN       << File is $NULL >>                                55445000
         TOS := 0;   << no error >>                                     55450000
         TOS := CCG;                                                    55455000
         GO EXIT                                                        55460000
         END;                                                           55465000
      IF KSTYPE THEN                                           <<KS.00>>55470000
         BEGIN     << KSAM file >>                             <<KS.00>>55475000
         TOS := 0;                                             <<KS.00>>55480000
         TOS := CCE;                                           <<KS.00>>55485000
         FRELATE := 0;                                         <<KS.00>>55490000
         GO TO EXIT;      << done >>                           <<KS.00>>55495000
         END;    << KSAM file >>                               <<KS.00>>55500000
      IF RFTYPE THEN                                           <<DS.00>>55505000
         BEGIN                                                 <<DS.00>>55510000
         LDN := -1;                                            <<DS.00>>55515000
         RETURN;                                               <<DS.00>>55520000
         END;                                                  <<DS.00>>55525000
      LDN := ACB'DADDR;   << Log. device nr. >>                <<06511>>55530000
      UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<06511>>55535000
SXIT: END;     << subroutine LDN >>                                     55540000
                                                                        55545000
$  IF X0 = ON                                                           55550000
   IF MONCALLABLE THEN                                                  55555000
      BEGIN                                                             55560000
      FTITLE("FREL","ATE ",0D,0D);                                      55565000
      DEBUG                                                             55570000
      END;                                                              55575000
$  IF                                                                   55580000
                                                                        55585000
  PXGLOBAL;                                                    <<06510>>55590000
   ERRORON;                                                             55595000
   CRIT := SETCRITICAL;                                                 55600000
   TOS := LDN(FN1);     << get FN1's log. dev. nr. >>                   55605000
   ASMB(TEST);                                                          55610000
   IF = THEN                                                            55615000
      BEGIN      << Invalid file nr. >>                                 55620000
INVAL:TOS := INVFN;                                                     55625000
      TOS := CCL;                                                       55630000
      GO EXIT;                                                          55635000
      HELP;  << dummy call >>                                  <<00117>>55640000
      END;                                                              55645000
   LD1 := TOS;    << File 1's log. dev. nr. >>                          55650000
   IF RFTYPE THEN TEMP := 0 ELSE                                        55655000
      BEGIN                                                             55660000
      TOS := EXCHANGEDB(LDT);  << Set DB to LDT >>                      55665000
      TEMP := ADB0(LD1*LDTENTRY+LDTNO); ! Default Output LDEV  <<06512>>55670000
      ASMB(ZERO,XCH);     << for result of EXCHANGEDB >>                55675000
      EXCHANGEDB(*);      << Reset DB to orig. DST >>                   55680000
      END;                                                              55685000
   TOS := LDN(FN2);       << Get FN2's log. dev. nr. >>                 55690000
   ASMB(TEST);                                                          55695000
   IF = THEN GO INVAL;    << invalid file nr. >>                        55700000
   LD2 := TOS;                                                          55705000
                                                                        55710000
   TOS := EXCHANGEDB(0);  << set DB to stack >>                         55715000
   IF LD1 = PXG'INPUTLDEV AND LD2 = PXG'OUTPUTLDEV THEN        <<06510>>55720000
      BEGIN                                                    <<06510>>55725000
         LTEMP.(0:1):=PXG'DUPLICATIVE;                         <<06510>>55730000
         LTEMP.(1:1):=PXG'INTERACTIVE;                         <<06510>>55735000
         TOS:=LTEMP;  << D,I in bits 0,1>>                     <<06510>>55740000
      END                                                      <<06510>>55745000
   ELSE IF LD2 = TEMP THEN    << Default output device? >>              55750000
      TOS := LPDT(LOGICAL(LD1)*LPDTENTRY + 1) & LSL(5)         <<04321>>55755000
   ELSE      << No relation >>                                          55760000
      TOS := 0;                                                         55765000
   FRELATE := TOS&ASR(14) LAND %100001;  <<D--------------I>>           55770000
   ASMB(ZERO,XCH);    << for result of EXCHANGEDB >>                    55775000
   EXCHANGEDB(*);     << Reset DB to orig. DST >>                       55780000
   TOS := 0;          << No error >>                                    55785000
   TOS := CCE;        << OK condition code >>                           55790000
                                                                        55795000
EXIT:                                                                   55800000
   CONDCODE := TOS;    << Report condition code >>                      55805000
   RESETCRITICAL(CRIT);                                                 55810000
   ERROREXIT(2,S0,0)                                                    55815000
   END;     << procedure FRELATE >>                                     55820000
$PAGE " FCHECK "                                                        55825000
$CONTROL SEGMENT = FILESYS3   << FCHECK >>                              55830000
PROCEDURE FCHECK(FILENUM,ERRORCODE,TLOG,BLKNUM,NUMRECS);                55835000
VALUE FILENUM;                                                          55840000
INTEGER FILENUM,ERRORCODE,TLOG,NUMRECS;                                 55845000
DOUBLE BLKNUM;                                                          55850000
OPTION VARIABLE,PRIVILEGED;                                             55855000
   BEGIN                                                                55860000
   LOGICAL PMAP = Q-4;   << parameter bit map >>                        55865000
   EQUATE UBND = -10; <<Q rel upper bound for bounds check>>   <<03059>>55870000
   INTEGER CRIT;         << for SETCRITICAL >>                          55875000
   INTEGER EC := 0;      << error nr. >>                                55880000
   INTEGER TL := 0;      << transmission log >>                         55885000
   INTEGER NR := 0;      << blocking factor >>                          55890000
   DOUBLE BN := 0D;      << block nr. >>                                55895000
   DOUBLE RN := 0D;      << record nr. >>                               55900000
   LOGICAL SPOOLED := FALSE;                                            55905000
   INTEGER ERR := 0;                                                    55910000
   INTEGER POINTER PXFILE;                                              55915000
                                                                        55920000
<< Remote file access (RFA) variables: >>                               55925000
                                                                        55930000
   INTEGER POINTER RFAPTR;  << appendage pointer >>                     55935000
   INTEGER RFALEN;          << appendage length >>                      55940000
                                                                        55945000
<< Following LOC'ACB params must be in order: >>                        55950000
   INTEGER ACBMQ;                                              <<06511>>55955000
   INTEGER AFTE;                                                        55960000
   DOUBLE  PACBV;                                              <<06511>>55965000
   DOUBLE  LACBV;                                              <<06511>>55970000
   INTEGER IOQX;                                                        55975000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>55980000
                                                               <<06511>>55985000
   BUILD'ACB;                                                           55990000
                                                                        55995000
   INTEGER DSTX;       << user's buffer DST >>                          56000000
   << End of LOC'ACB params >>                                          56005000
                                                                        56010000
$  IF X0 = ON                                                           56015000
   IF MONCALLABLE THEN                                                  56020000
      BEGIN                                                             56025000
      FTITLE("FCHE","CK  ",0D,0D);                                      56030000
      DEBUG                                                             56035000
      END;                                                              56040000
$  IF                                                                   56045000
                                                                        56050000
   ERRORON;                                                             56055000
   CRIT := SETCRITICAL;                                                 56060000
   TOS := PMAP;     << parameter bit map >>                             56065000
   IF NOT LS0.(11:1) OR (FILENUM = 0) THEN                              56070000
      BEGIN            << Return last error from FOPEN. >>              56075000
      DSTX := EXCHANGEDB(0);    << set DB to stack >>                   56080000
      SETPXFILE;          << init. PXFILE pointer >>                    56085000
      EC := PXFFOPEN;     << Last FOPEN error nr. >>                    56090000
      TOS := PXFKOPEN;                                         <<KS.00>>56095000
      EC.(0:8) := TOS;                                         <<KS.00>>56100000
      EXCHANGEDB(DSTX)  << Reset DB to user's DST >>                    56105000
      END                                                               56110000
   ELSE                                                                 56115000
      BEGIN       << Return last I/O error. >>                          56120000
      DEL;        << PMAP >>                                            56125000
      GET'ACB'Q'LOC;                                           <<06511>>56130000
      LOC'ACB(*,ACBMQ,FILENUM,UMODE);                          <<06511>>56135000
      IF < THEN                                                         56140000
         BEGIN      << Invalid file nr. >>                              56145000
         ERR := INVFN;                                                  56150000
         GO CCLEX                                                       56155000
         END;                                                           56160000
      IF > THEN GO NULLF;  <<$NULL?>>                                   56165000
      CASE * FTYPE OF                                                   56170000
      BEGIN                                                             56175000
                                                                        56180000
      BEGIN   << Conventional file >>                                   56185000
      BN:=ACB'BTFRCT;                                          <<06511>>56190000
CONVENTIONAL:                                                  <<HM.00>>56195000
      EC := ACB'ERROR;                                                  56200000
      TL := ACB'TLOG;                                                   56205000
      NR := ACB'BLKFACT;                                                56210000
      RN := ACB'RTFRCT;                                        <<06511>>56215000
      SPOOLED := ACB'SPOOLED;    << for BLKNUM >>                       56220000
                                                                        56225000
      <<* * * Measurement data on FCHECK * * *>>                        56230000
                                                                        56235000
$     IF X3 = ON                                                        56240000
      IF MEAS'TAPE'ON THEN BEGIN                                        56245000
      IF ACB'ACCCL = DIRACC THEN                                        56250000
         MMSTAT'(EFCHECK,FILENUM,EC,0,0,0,0);                  <<06958>>56255000
      END; << OF MEAS'TAPE'ON>>                                         56260000
$     IF                                                                56265000
                                                                        56270000
      UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<06511>>56275000
      END;      << conventional file >>                                 56280000
                                                               <<DS.00>>56285000
      BEGIN    << Remote file >>                               <<DS.00>>56290000
      SETRFAPTR;                                               <<DS.00>>56295000
      RFALEN := 5;                                             <<DS.00>>56300000
      TOS := "RFA ";                                           <<DS.00>>56305000
      TOS := 14;                                               <<DS.00>>56310000
      TOS := RFAFILE;                                          <<DS.00>>56315000
      TOS := PMAP;                                             <<DS.00>>56320000
      TOS := 0D;     << for FCHECK return >>                   <<DS.00>>56325000
      MWCNOBUF;                                                <<DS.00>>56330000
      IF <> THEN                                               <<DS.00>>56335000
         BEGIN                                                 <<DS.00>>56340000
         TOS := 0;                                             <<DS.00>>56345000
         TOS := RFALINE;                                       <<DS.00>>56350000
         TOS := DSCHKPLABEL;                                   <<DS.00>>56355000
         ASMB(PCAL 0);                                         <<DS.00>>56360000
         ERR := TOS;                                           <<DS.00>>56365000
$   IF X1 = ON                                                 <<DS.00>>56370000
         IF <> THEN FTROUBLE(486);                             <<KJ.03>>56375000
$   IF                                                         <<DS.00>>56380000
         GO CCLEX;                                             <<DS.00>>56385000
         END;                                                  <<DS.00>>56390000
      DEL; << MASK >>                                          <<DS.00>>56395000
      NR := TOS;                                               <<DS.00>>56400000
      BN := TOS;                                               <<DS.00>>56405000
      TL := TOS;                                               <<DS.00>>56410000
      EC := S0;                                                <<DS.00>>56415000
      ERR := TOS;                                              <<DS.00>>56420000
      IF TOS.CC = CCL THEN GO CCLEX;                           <<DS.00>>56425000
      END;     << remote file >>                                        56430000
         << dummy 2 >>;                                                 56435000
         << dummy 3 >>;                                                 56440000
         << dummy 4 >>;                                                 56445000
         << dummy 5 >>;                                                 56450000
      BEGIN    << KSAM file >>                                          56455000
      DSTX := EXCHANGEDB(0);  << Set DB to stack >>         <<KS.01.06>>56460000
      KCHECK(FILENUM,EC,TL,BN,NR);                             <<KS.00>>56465000
      PUSH(STATUS);                                            <<KS.00>>56470000
      EXCHANGEDB(DSTX);    << back to original DST >>       <<KS.01.06>>56475000
      IF TOS.CC = CCL THEN GO CCLEX;                           <<KS.00>>56480000
      END;    <<KSAM file >>                                   <<KS.00>>56485000
                                                               <<HM.00>>56490000
      <<DUMMY 7>>;                                             <<HM.00>>56495000
                                                               <<HM.00>>56500000
      BEGIN    <<MSG FILE>>                                    <<HM.00>>56505000
      BN:=IF ACB'READ THEN 0D ELSE ACB'BLK;                    <<06511>>56510000
      GO CONVENTIONAL;                                         <<HM.00>>56515000
      END;                                                     <<HM.00>>56520000
                                                                        56525000
      END;     << FTYPE CASE >>                                         56530000
      END;     << return last I/O error >>                              56535000
                                                                        56540000
   <<* * * Return requested values * * *>>                              56545000
                                                                        56550000
NULLF:                                                                  56555000
   TOS := PMAP;    << Parameter bit map >>                              56560000
   IF LS0.(12:1) THEN                                                   56565000
      BEGIN       << Error nr. wanted >>                                56570000
      IF NOT FBNDCHK(@ERRORCODE,1,UBND) THEN GO BERR;          <<03059>>56575000
      IF KSTYPE THEN ERRORCODE := EC ELSE                      <<KS.00>>56580000
        ERRORCODE := EC.(8:8);                                          56585000
      END;                                                              56590000
   IF LS0.(13:1) THEN                                                   56595000
      BEGIN        << Transmission log wanted >>                        56600000
      IF NOT FBNDCHK(@TLOG,1,UBND) THEN GO BERR;               <<03059>>56605000
      TLOG := TL;                                                       56610000
      END;                                                              56615000
   IF LS0.(14:1) THEN                                                   56620000
      BEGIN        << Current block nr. wanted >>                       56625000
      IF NOT FBNDCHK(@BLKNUM,2,UBND) THEN GO BERR;             <<03059>>56630000
      BLKNUM := IF SPOOLED THEN RN ELSE BN;                             56635000
      END;                                                              56640000
   IF LS0.(15:1) THEN                                                   56645000
      BEGIN         << Blocking factor wanted >>                        56650000
      IF NOT FBNDCHK(@NUMRECS,1,UBND) THEN GO BERR;            <<03059>>56655000
      NUMRECS := NR;                                                    56660000
      END;                                                              56665000
   TOS := CCE;        << OK condition code >>                           56670000
   GO EXIT;                                                             56675000
                                                                        56680000
BERR:                                                                   56685000
   IF KSTYPE AND LOGICAL(PMAP.(11:1)) AND FILENUM <> 0 THEN             56690000
      FKSAMBNDVIOL(FILENUM);                                            56695000
   ERR := BNDVIOL;                                                      56700000
                                                                        56705000
CCLEX:                                                                  56710000
   IF PMAP.(12:1) AND FBNDCHK(@ERRORCODE,1,UBND) THEN          <<03059>>56715000
      ERRORCODE := ERR;                                                 56720000
   TOS := CCL;   << Error condition code >>                             56725000
EXIT:                                                                   56730000
   CONDCODE := TOS;  << report condition code >>                        56735000
   RESETCRITICAL(CRIT);                                                 56740000
   ERROREXIT(6,ERR,0);                                                  56745000
   END;        << procedure FCHECK >>                                   56750000
$PAGE " FGETINFO "                                                      56755000
$CONTROL SEGMENT = FILESYS3   << FGETINFO >>                            56760000
PROCEDURE FGETINFO(FILENUM,FILENAME,FOPTIONS,AOPTIONS,                  56765000
   RECSIZE,                                                             56770000
   DEVTYPE,LDNUM,HDADDR,FILECODE,RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,  56775000
   BLKSIZE,EXTSIZE,NUMEXTENTS,USERLABELS,CREATORID,DISKADR);            56780000
<< Must be called with DB set to the stack. >>                          56785000
VALUE FILENUM;                                                          56790000
INTEGER FILENUM,RECSIZE,DEVTYPE,FILECODE,BLKSIZE,NUMEXTENTS,            56795000
   USERLABELS;                                                          56800000
BYTE ARRAY FILENAME,CREATORID;                                          56805000
LOGICAL FOPTIONS,AOPTIONS,LDNUM,HDADDR,EXTSIZE;                         56810000
DOUBLE RECPTR,EOF,FLIMIT,LOGCOUNT,PHYSCOUNT,DISKADR;                    56815000
OPTION VARIABLE,PRIVILEGED;                                             56820000
   BEGIN                                                                56825000
   LOGICAL PMAP1 = Q-5;  << First parameter bit map >>                  56830000
   LOGICAL PMAP2 = Q-4;  << Second parameter bit map >>                 56835000
   EQUATE UBND = -26; << Q rel upper bound for bounds check>>  <<03059>>56840000
   INTEGER CRIT;         << for SETCRITICAL >>                          56845000
   INTEGER ERRS := 0;    << error nr. >>                                56850000
   BYTE POINTER BP1,BP2;                                                56855000
   LOGICAL ASC;                                                         56860000
   DOUBLE NM1,NM2;       << file name >>                                56865000
   LOGICAL FOREIGN := FALSE;                                   <<01115>>56870000
   LOGICAL MEASURE := FALSE;     << MMSTAT measurement? >>              56875000
   INTEGER POINTER AFT;                                        <<06756>>56880000
                                                                        56885000
                                                                        56890000
   << Local copies of requested parameters >>                           56895000
                                                                        56900000
   LOGICAL FOPT := 0;      << FOPTIONS >>                               56905000
   LOGICAL AOPT := 0;      << AOPTIONS >>                               56910000
   INTEGER RECSI := 0;     << record size >>                            56915000
   LOGICAL DEVT := 0;      << device type and subtype >>                56920000
   LOGICAL LDN := 0;       << logical device nr. >>                     56925000
   INTEGER FC := 0;        << File code >>                              56930000
   DOUBLE RPTR := 0D;      << record pointer >>                         56935000
   DOUBLE ENDF := 0D;      << EOF record nr. >>                         56940000
   DOUBLE FL := 0D;        << file limit record nr. >>                  56945000
   DOUBLE LCT := 0D;       << record transfer count >>                  56950000
   DOUBLE PCT := 0D;       << block transfer count >>                   56955000
   INTEGER BLKSI := 0;     << block size >>                             56960000
   INTEGER EXTSI := 0;     << extent size >>                            56965000
   INTEGER NE := 0;        << number of extents >>                      56970000
   INTEGER UL := 0;        << nr. user labels >>                        56975000
   INTEGER DRTU := 0;      << device nr. & unit >>                      56980000
                                                                        56985000
<< Following LOC'ACB params must be in order: >>                        56990000
   INTEGER ACBMQ;                                              <<06511>>56995000
   INTEGER AFTE;                                                        57000000
   DOUBLE  PACBV;                                              <<06511>>57005000
   DOUBLE  LACBV;                                              <<06511>>57010000
   INTEGER IOQX;                                                        57015000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>57020000
                                                               <<06511>>57025000
   BUILD'ACB;                                                           57030000
                                                                        57035000
   INTEGER DSTX;       << user's buffer DST >>                          57040000
   << End of LOC'ACB params >>                                          57045000
                                                                        57050000
   << FCB parameters >>                                                 57055000
                                                                        57060000
   LOGICAL FCBINFO := FALSE;  << FCB info read flag >>                  57065000
   LOGICAL NOFCB := FALSE;    << FCB exists >>                          57070000
   INTEGER ARRAY FCB(0:SIZEBFCB+2-1);  << FCB buffer >>                 57075000
   DOUBLE ARRAY FCBDBL(*) = FCB;                                        57080000
                                                                        57085000
   << File Label parameters >>                                          57090000
                                                                        57095000
   LOGICAL LABINFO := FALSE;  << File Label read flag >>                57100000
   DOUBLE LABADDR := 0D;      << file label sector address >>           57105000
   INTEGER P1 = LABADDR;      << first half >>                          57110000
   INTEGER POINTER FLAB;      << label buffer pointer >>                57115000
                                                               <<HM.00>>57120000
   <<MESSAGE FILE DECLARATIONS >>                              <<HM.00>>57125000
                                                               <<HM.00>>57130000
   LOGICAL MSGFILE:=FALSE;                                     <<HM.00>>57135000
   INTEGER MSGRECSIZE;                                         <<HM.00>>57140000
   DOUBLE  MSGEOF;                                             <<HM.00>>57145000
                                                                        57150000
   << Remote file access (RFA) variables: >>                            57155000
                                                                        57160000
   INTEGER POINTER RFAPTR;  << appendage pointer >>                     57165000
   INTEGER RFALEN;          << appendage length >>                      57170000
   ARRAY TOP(*)=FILENUM;    << for KSAM >>                              57175000
   ARRAY DUMMY(0:21);    <<for KSAM-must be last declaration >>         57180000
                                                                        57185000
   SUBROUTINE GETFCBINFO;                                               57190000
    << Initializes local variables with information from the            57195000
     FCB if the FCB has not already been read (FCBINFO=FALSE),          57200000
     otherwise does nothing.  DB must be at the stack.  >>              57205000
      BEGIN                                                             57210000
      IF (FSTYPE OR MSGFILE) AND NOT FCBINFO AND NOT NOFCB THEN<<HM.00>>57215000
         BEGIN                                                          57220000
         LOCK'CB(0,0,@FCB-@Q0,ACB'FCB);                        <<06511>>57225000
         TOS := SIZEBFCB+2;    << word count >>                         57230000
         MOVE'DS'6;            << FCB + first e-map entry >>            57235000
         X := FCB.(2:14);      << FCB size >>                           57240000
         IF BADFCBSIZE THEN FTROUBLE(62);                               57245000
         NE := FCBNUMEXTS+1;                                            57250000
         EXTSI := FCBEXTSIZE;                                           57255000
         TOS := FCBLABEL;      << LDEV and sector nr. >>                57260000
         BS1 := 0;             << clear LDEV >>                         57265000
         LABADDR := TOS;       << file label sector nr. >>              57270000
         UL := FCBLBL;                                                  57275000
         FL := FCBFLIM;                                                 57280000
         ENDF := FCBEOF;                                                57285000
         UNLOCK'CB(0,ACB'FCB);                                 <<06511>>57290000
         FCBINFO := TRUE     << set flag >>                             57295000
         END                                                            57300000
      END;                                                              57305000
                                                                        57310000
   SUBROUTINE RDLABEL;                                                  57315000
    << Reads the file label into the local buffer and sets the          57320000
     File Label flag (LABINFO).  >>                                     57325000
      BEGIN                                                             57330000
      IF NOT LABINFO THEN                                               57335000
         BEGIN             << File label not read yet >>                57340000
         X := TOS;         << save return address >>                    57345000
         ALLOCFLAB;        << allocate label buffer >>                  57350000
         TOS := X;         << restore return address >>                 57355000
         GETFCBINFO;       << Get file label address >>                 57360000
         TOS := FISIR;                                                  57365000
         TOS := GETSIR(FISIR);  << get File SIR >>                      57370000
         X := FLABIO(LDN,LABADDR,0,FLAB);  << read label >>             57375000
         RELSIR(*,*);         << Release File SIR >>                    57380000
         ASMB(LDXA,DEL);      << set CC on X >>                         57385000
         IF <> THEN                                                     57390000
            BEGIN     << Error. >>                                      57395000
            FLABIOERR(X,FILENUM);  << handle error >>                   57400000
            TOS := LBLIOERR;                                            57405000
            GO ERR                                                      57410000
            END;                                                        57415000
         LABINFO := TRUE    << set flag >>                              57420000
         END                                                            57425000
      END;                                                              57430000
                                                                        57435000
$  IF X0 = ON                                                           57440000
   IF MONCALLABLE THEN                                                  57445000
      BEGIN                                                             57450000
      FTITLE("FGET","INFO",0D,0D);                                      57455000
      DEBUG                                                             57460000
      END;                                                              57465000
$  IF                                                                   57470000
                                                                        57475000
   ERRORON;                                                             57480000
   CRIT := SETCRITICAL;                                                 57485000
   GET'ACB'Q'LOC;                                              <<06511>>57490000
   LOC'ACB(0,ACBMQ,FILENUM,UMODE);                             <<01672>>57495000
   DSTX := TOS;                                                         57500000
   IF < THEN                                                            57505000
      BEGIN        << Invalid file nr. >>                               57510000
      TOS := INVFN;                                                     57515000
      GO ERR                                                            57520000
      END;                                                              57525000
   IF > THEN                                                            57530000
      BEGIN      << file is $NULL >>                                    57535000
      FOPT.FOPDESIGNATORF := 6;    << make $NULL >>                     57540000
      NM1 := "$NUL"; NM2 := "L   ";                            <<00899>>57545000
      AOPT := 4;                                                        57550000
      NOFCB := TRUE;                                                    57555000
      GO RETVAL                                                         57560000
      END;                                                              57565000
   IF DSTX <> 0 THEN                                                    57570000
      BEGIN     << Split-stack mode - illegal. >>                       57575000
      TOS := ILLDB;                                                     57580000
      IF FSTYPE OR MSGFILE THEN                                <<01624>>57585000
         BEGIN   << Log FSERR in ACB and unlock it.         >> <<01624>>57590000
         ACB'ERROR := S0;                                      <<01624>>57595000
         UNLOC'ACB(ACBMQ,0);     << release ACB >>             <<01672>>57600000
         END;                                                  <<01624>>57605000
      GO ERR                                                            57610000
      END;                                                              57615000
   CASE * FTYPE OF                                                      57620000
   BEGIN                                                       <<DS.00>>57625000
                                                                        57630000
   BEGIN     << conventional file >>                                    57635000
                                                                        57640000
<<* * * Get data from ACB * * *>>                                       57645000
                                                                        57650000
CONVENTIONAL:                                                  <<HM.00>>57655000
   IF ACB'SPOOLED THEN                                                  57660000
      BEGIN           << Spoofle. >>                                    57665000
      FOPT  := ACB'SPFOPT;                                     <<06511>>57670000
      IF FOPT.FOPDESIGNATORF = 4 THEN   << spooled input >>    <<01155>>57675000
         IF ACB'LSTATE.READMODE = STDINXRD <<$STDINX device>>  <<01155>>57680000
          THEN FOPT.FOPDESIGNATORF := 5;                       <<01155>>57685000
      AOPT  := ACB'SPAOPT LAND %177357;                        <<06511>>57690000
      IF ACB'SPVDEV > 255 THEN                                          57695000
         LDN := 0              << Oops, too large >>                    57700000
      ELSE                                                              57705000
         LDN   := ACB'SPVDEV;                                  <<07992>>57710000
      RECSI := -ACB'SPREC;       << make -bytes >>             <<06511>>57715000
      DEVT  := ACB'SPTYPE;                                     <<06511>>57720000
                                                               <<04161>>57725000
      TOS := DEVT;      << Get ready to include the stype >>   <<04161>>57730000
      TOS.(0:8) := LPDT(LDN*LPDTENTRY+1).(12:4);               <<04161>>57735000
      DEVT := TOS;      << Subtype/Type >>                     <<04161>>57740000
                                                               <<04161>>57745000
      IF FOPT.FOPCONTROLF THEN RECSI := RECSI-1;                        57750000
      BLKSI := (RECSI-1)&ASR(1)&ASL(1);    << even bytes >>             57755000
      RPTR  := ACB'FPTR;                                                57760000
      LCT   := ACB'RTFRCT;                                     <<06511>>57765000
      PCT   := LCT;                                                     57770000
      NOFCB := TRUE;                                                    57775000
      END                                                               57780000
   ELSE                                                                 57785000
      BEGIN         << Not spoofle >>                                   57790000
      FOPT := ACB'FOPTIONS;                                             57795000
      AOPT := ACB'AOPTIONS;                                             57800000
      IF ACB'DADDR > 255 THEN                                           57805000
         LDN := 0                     << Oops, too big >>               57810000
      ELSE                                                              57815000
         LDN := ACB'DADDR;                                              57820000
      DEVT := ACB'DTYPE;                                                57825000
      FOREIGN := IF DEVT=FDISC THEN TRUE ELSE FALSE;                    57830000
      TOS := DEVT;       << device type >>                              57835000
      TOS.(0:8) := LPDT(LDN*LPDTENTRY+1).(12:4);  <<subtype>>           57840000
      DEVT := TOS;     << device type and subtype >>                    57845000
      NOFCB:=((DEVT LAND %70)<>DIRACC) LOR FOREIGN;            <<01115>>57850000
      DRTU := LDEVTODRT(LDN);                                  <<03052>>57855000
      ASC := FOPT.FOPASCIIF;                                            57860000
      IF MSGFILE THEN                                          <<HM.00>>57865000
         TOS:=MSGRECSIZE                                       <<HM.00>>57870000
      ELSE                                                     <<HM.00>>57875000
         BEGIN                                                 <<HM.00>>57880000
         TOS := ACB'RSIZE;                                     <<06511>>57885000
         IF ACB'VARIABLE AND NOT ACB'MSGFILE THEN TOS:=TOS-4;  <<01750>>57890000
         IF ACB'SPECVAR THEN TOS := TOS-8;                     <<HM.00>>57895000
         END;                                                  <<HM.00>>57900000
      IF ASC THEN TOS := -TOS ELSE TOS := (TOS+1)&LSR(1);               57905000
      RECSI := TOS;        << -bytes or +words >>                       57910000
      IF NOT ACB'RIO OR ACB'INHIBITBUF THEN                    <<00630>>57915000
         BEGIN      << Total block size >>                     <<00630>>57920000
         TOS := ACB'BSIZE;                                     <<06511>>57925000
         END                                                   <<00630>>57930000
      ELSE                                                     <<00630>>57935000
         BEGIN   << Data block size only (assume non-var.) >>  <<00630>>57940000
         TOS:=(ACB'RSIZE+1)/2 * ACB'BLKFACT;                   <<06511>>57945000
         END;                                                  <<00630>>57950000
      IF ASC THEN TOS := -(TOS&LSL(1));    << make -chars >>            57955000
      BLKSI := TOS;                                                     57960000
      IF MSGFILE THEN                                          <<HM.00>>57965000
         BEGIN                                                 <<HM.00>>57970000
         RPTR:=IF ACB'READ THEN 0D ELSE MSGEOF;                <<06511>>57975000
         END                                                   <<HM.00>>57980000
      ELSE                                                     <<HM.00>>57985000
         RPTR:=ACB'FPTR;                                       <<HM.00>>57990000
      LCT := ACB'RTFRCT;                                       <<06511>>57995000
      PCT := ACB'BTFRCT;                                       <<06511>>58000000
      GETFCBINFO;                                              <<HM.00>>58005000
      END;                                                              58010000
   NM1 := ACB'NAME1;     << file name - first half >>          <<06511>>58015000
   NM2 := ACB'NAME2;     << file name - second half >>         <<06511>>58020000
                                                                        58025000
$  IF X3 = ON                                                           58030000
   IF ACB'ACCCL = DIRACC THEN MEASURE := TRUE;                          58035000
$  IF                                                                   58040000
                                                                        58045000
   UNLOC'ACB(ACBMQ,0);       << release ACB >>                 <<01672>>58050000
   END;    << conventional file >>                                      58055000
                                                                        58060000
   BEGIN    << Remote file >>                                           58065000
   ALLOCRFABUF;                                                <<DS.00>>58070000
   RFALEN := 6;                                                <<DS.00>>58075000
   TOS := "RFA ";                                              <<DS.00>>58080000
   TOS := 13;                                                  <<DS.00>>58085000
   TOS := RFAFILE;                                             <<DS.00>>58090000
   TOS := PMAP1;                                               <<DS.00>>58095000
   TOS := PMAP2;                                               <<DS.00>>58100000
   ASMB(ADDS 38);    << for returned data >>                   <<DS.00>>58105000
   MWCNOBUF;                                                   <<DS.00>>58110000
   IF <> THEN                                                  <<DS.00>>58115000
      BEGIN                                                    <<DS.00>>58120000
      TOS := 0;                                                <<DS.00>>58125000
      TOS := RFALINE;                                          <<DS.00>>58130000
      TOS := DSCHKPLABEL;                                      <<DS.00>>58135000
      ASMB(PCAL 0);                                            <<DS.00>>58140000
$  IF X1 = ON                                                  <<DS.00>>58145000
      IF <> THEN FTROUBLE(486);                                <<KJ.03>>58150000
$  IF                                                          <<DS.00>>58155000
      GO ERR;                                                  <<DS.00>>58160000
      END;                                                     <<DS.00>>58165000
   IF RFAPTR.CC = CCL THEN                                     <<DS.00>>58170000
      BEGIN     << Remote failure >>                           <<DS.00>>58175000
      TOS := 0;                                                <<DS.00>>58180000
      GO TO ERR;                                               <<DS.00>>58185000
      END;                                                     <<DS.00>>58190000
   IF PMAP1.(13:1) THEN                                        <<DS.00>>58195000
      BEGIN     << File name wanted >>                         <<DS.00>>58200000
      IF NOT FBNDCHK(@FILENAME,-28,UBND) THEN GO BERR;         <<03059>>58205000
      TOS := @FILENAME;                                        <<DS.00>>58210000
      TOS := (@RFAPTR+1)&LSL(1);                               <<DS.00>>58215000
      MOVE * := *,(28);                                        <<DS.00>>58220000
      PMAP1.(13:1) := 0;                                       <<DS.00>>58225000
      END;                                                     <<DS.00>>58230000
   IF PMAP2.(14:1) THEN                                        <<DS.00>>58235000
      BEGIN    << Creator ID wanted >>                         <<DS.00>>58240000
      IF NOT FBNDCHK(@CREATORID,-8,UBND) THEN GO BERR;         <<03059>>58245000
      TOS := @CREATORID;                                       <<DS.00>>58250000
      TOS := (@RFAPTR+36)&LSL(1);                              <<DS.00>>58255000
      MOVE * := *,(8);                                         <<DS.00>>58260000
      PMAP2.(14:1) := 0;                                       <<DS.00>>58265000
      END;                                                     <<DS.00>>58270000
   DDEL; << PMAP'S >>                                          <<DS.00>>58275000
   TOS := PMAP2;                                               <<DS.00>>58280000
   IF TOS THEN                                                 <<DS.00>>58285000
      BEGIN    << Disk address wanted >>                       <<DS.00>>58290000
      IF NOT FBNDCHK(@DISKADR,1,UBND) THEN GO BERR;            <<03059>>58295000
      DISKADR := TOS;                                          <<DS.00>>58300000
      PMAP2.(15:1) := 0;                                       <<DS.00>>58305000
      END ELSE DDEL;                                           <<DS.00>>58310000
   ASMB(SUBS 4);   << creator ID >>                            <<DS.00>>58315000
   UL := TOS;                                                  <<DS.00>>58320000
   NE := TOS;                                                  <<DS.00>>58325000
   EXTSI := TOS;                                               <<DS.00>>58330000
   BLKSI := TOS;                                               <<DS.00>>58335000
   PCT := TOS;                                                 <<DS.00>>58340000
   LCT := TOS;                                                 <<DS.00>>58345000
   FL := TOS;                                                  <<DS.00>>58350000
   ENDF := TOS;                                                <<DS.00>>58355000
   RPTR := TOS;                                                <<DS.00>>58360000
   FC := TOS;                                                  <<DS.00>>58365000
   IF PMAP2.(3:1) THEN                                         <<DS.00>>58370000
      BEGIN    << return hardware address >>                   <<DS.00>>58375000
      IF NOT FBNDCHK(@HDADDR,2,UBND) THEN GO BERR;             <<03059>>58380000
      HDADDR := TOS;                                           <<DS.00>>58385000
      PMAP2.(3:1) := 0;                                        <<DS.00>>58390000
      END ELSE DEL;                                            <<DS.00>>58395000
   LDN := TOS;           ! Get remote LDEV number.             <<06756>>58400000
   TOS := RFALINE;       ! Use SETAFT' to set AFT to DS AFT    <<06756>>58405000
   SETAFT';              ! based on AFT number on TOS.         <<06756>>58410000
   IF AFTDSVIRTLDEV > 255 OR LDN = 0                           <<07992>>58415000
      THEN LDN := 0      ! Either > 255, no dice with LDEV.    <<06756>>58420000
      ELSE LDN.(0:8) := AFTDSVIRTLDEV; ! Insert virtual LDEV.  <<06756>>58425000
   DEVT := TOS;                                                <<DS.00>>58430000
   RECSI := TOS;                                               <<DS.00>>58435000
   AOPT := TOS;                                                <<DS.00>>58440000
   FOPT := TOS;                                                <<DS.00>>58445000
   ASMB(SUBS 15);    << delete name & status >>                <<DS.00>>58450000
   END;     << remote file >>                                           58455000
      << dummy 2 >>;                                                    58460000
      << dummy 3 >>;                                                    58465000
      << dummy 4 >>;                                                    58470000
      << dummy 5 >>;                                                    58475000
   BEGIN    << KSAM >>                                                  58480000
   MOVE DUMMY := TOP,(22);     << put param list on TOS >>     <<KS.00>>58485000
   ASMB(PCAL KGETINFO);                                        <<KS.00>>58490000
   PUSH(STATUS);     << Junk word to TOS.  CC unchanged >>     <<KS.00>>58495000
   IF <> THEN                                                  <<KS.00>>58500000
      GO TO ERR                                                <<KS.00>>58505000
   ELSE                                                        <<KS.00>>58510000
      BEGIN                                                    <<KS.00>>58515000
      CONDCODE := CCE;                                         <<KS.00>>58520000
      GO TO EXIT;                                              <<KS.00>>58525000
      END;                                                     <<KS.00>>58530000
   END;     << KSAM >>                                         <<KS.00>>58535000
   <<DUMMY 7>>;                                                <<HM.00>>58540000
   BEGIN  <<MSG FILE>>                                         <<HM.00>>58545000
   MSGFILE:=TRUE;                                              <<HM.00>>58550000
   TOS := FCRETURNINFO(0,ACBMQ);                               <<01689>>58555000
   MSGRECSIZE:=TOS; MSGEOF:=TOS;                               <<HM.00>>58560000
   GO CONVENTIONAL;                                            <<HM.00>>58565000
   END;                                                        <<HM.00>>58570000
                                                                        58575000
   END;    << FTYPE CASE >>                                             58580000
                                                                        58585000
<<* * * Return requested values * * *>>                                 58590000
                                                                        58595000
RETVAL:                                                                 58600000
   TOS := PMAP1;     << First parameter bit map >>                      58605000
   IF NOT LS0.(12:1) THEN                                               58610000
      BEGIN         << No file number. Barf! >>                         58615000
      TOS := INVFN;                                                     58620000
      GO ERR                                                            58625000
      END;                                                              58630000
   IF LS0.(13:1) THEN                                                   58635000
      BEGIN          << File name requested >>                          58640000
      IF NOT FBNDCHK(@FILENAME,-28,UBND) THEN GO BERR;         <<03059>>58645000
      FILENAME := " ";                                                  58650000
      MOVE FILENAME(1) := FILENAME,(27);                                58655000
      @BP1 := @NM1&LSL(1);                                              58660000
      IF INTEGER(BP1) <> %40 THEN                                       58665000
         BEGIN                                                          58670000
         MOVE FILENAME := BP1,(8);                                      58675000
         END                                                            58680000
      ELSE                                                              58685000
         MOVE FILENAME := "....";                                       58690000
      IF NOT NOFCB THEN                                                 58695000
         BEGIN          << Disk file. >>                                58700000
         RDLABEL;                                                       58705000
         @BP1 := @FLLOCNAME&LSL(1);                                     58710000
         MOVE FILENAME := BP1,(8);                                      58715000
         SCAN FILENAME UNTIL " ",1;                                     58720000
         @BP2 := TOS;                                                   58725000
         BP2 := ".";                                                    58730000
         @BP1 := @FLGRPNAME&LSL(1);                                     58735000
         MOVE BP2(1) := BP1,(8);                                        58740000
         SCAN BP2 UNTIL " ",1;                                          58745000
         @BP2 := TOS;                                                   58750000
         BP2 := ".";                                                    58755000
         @BP1 := @FLACCTNAME&LSL(1);                                    58760000
         MOVE BP2(1) := BP1,(8);                                        58765000
         END;                                                           58770000
      END;        << file name requested >>                             58775000
   TOS := PMAP1;     << First parameter bit map >>                      58780000
   IF LS0.(14:1) THEN                                                   58785000
      BEGIN       << FOPTIONS wanted >>                                 58790000
      IF NOT FBNDCHK (@FOPTIONS,1,UBND) THEN GO BERR;          <<03059>>58795000
      FOPTIONS := FOPT;                                                 58800000
      END;                                                              58805000
   IF TOS THEN                                                          58810000
      BEGIN        << AOPTIONS wanted >>                                58815000
      IF NOT FBNDCHK (@AOPTIONS,1,UBND) THEN GO BERR;          <<03059>>58820000
      AOPTIONS := AOPT;                                                 58825000
      END;                                                              58830000
   TOS := PMAP2;   << Second parameter bit map >>                       58835000
   IF < THEN                                                            58840000
      BEGIN         << Record size wanted >>                            58845000
      IF NOT FBNDCHK (@RECSIZE,1,UBND) THEN GO BERR;           <<03059>>58850000
      RECSIZE := RECSI;                                                 58855000
      END;                                                              58860000
   IF LS0.(1:1) THEN                                                    58865000
      BEGIN         << Device type and subtype wanted >>                58870000
      IF NOT FBNDCHK(@DEVTYPE,1,UBND) THEN GO BERR;            <<03059>>58875000
      DEVTYPE := DEVT;    << device type and subtype >>                 58880000
      END;                                                              58885000
   IF LS0.(2:1) THEN                                                    58890000
      BEGIN          << Logical device nr. wanted >>                    58895000
      IF NOT FBNDCHK(@LDNUM,1,UBND) THEN GO BERR;              <<03059>>58900000
      LDNUM := LDN;                                                     58905000
      END;                                                              58910000
   IF LS0.(3:1) THEN                                                    58915000
      BEGIN       << DRT and unit wanted. >>                            58920000
      IF NOT FBNDCHK(@HDADDR,1,UBND) THEN GO BERR;             <<03059>>58925000
      IF DRTU.(7:1) <> 0 THEN   << Check if DRT # > 255 >>     <<03052>>58930000
         BEGIN                                                 <<03052>>58935000
         HDADDR.(8:8) := DRTU.(0:7);  << Deposit UNIT # >>     <<03052>>58940000
         IF FSTYPE OR MSGFILE THEN                             <<03052>>58945000
            BEGIN                                              <<03052>>58950000
            LOC'ACB(*,ACBMQ,FILENUM,UMODE);                    <<03052>>58955000
            ACB'ERROR := TOOBIGDRT;   << Insert error code >>  <<03052>>58960000
            UNLOC'ACB(ACBMQ,0);       << Release ACB >>        <<03052>>58965000
            END;                                               <<03052>>58970000
         GOTO ERR;                                             <<03052>>58975000
         END;                                                  <<03052>>58980000
      HDADDR := DRTU.(0:7);          << Deposit UNIT # >>      <<03052>>58985000
      HDADDR.(0:8) := DRTU.(8:8);    << Deposit DRT # >>       <<03052>>58990000
      END;                                                              58995000
   IF LS0.(4:1) THEN                                                    59000000
      BEGIN        << Filecode wanted. >>                               59005000
      IF NOT FBNDCHK(@FILECODE,1,UBND) THEN GO BERR;           <<03059>>59010000
      IF FSTYPE OR MSGFILE THEN                                <<HM.00>>59015000
        IF NOFCB THEN TOS := 0    << not officially a disk file >>      59020000
        ELSE                                                            59025000
         BEGIN     << A real disk file. >>                              59030000
         RDLABEL;  << Read file label >>                                59035000
         TOS := FLFILECODE                                              59040000
         END                                                   <<DS.00>>59045000
      ELSE IF RFTYPE THEN TOS := FC;                           <<DS.00>>59050000
      FILECODE := TOS;                                                  59055000
      END;                                                              59060000
   TOS := PMAP2;     << second parameter bit map >>                     59065000
   IF LS0.(5:1) THEN                                                    59070000
      BEGIN       << Record pointer wanted >>                           59075000
      IF NOT FBNDCHK(@RECPTR,2,UBND) THEN GO BERR;             <<03059>>59080000
      RECPTR := RPTR;                                                   59085000
      END;                                                              59090000
   IF LS0.(6:1) THEN                                                    59095000
      BEGIN       << EOF pointer wanted >>                              59100000
      IF NOT FBNDCHK(@EOF,2,UBND) THEN GO BERR;                <<03059>>59105000
      IF MSGFILE THEN                                          <<HM.00>>59110000
         EOF:=MSGEOF                                           <<HM.00>>59115000
      ELSE                                                     <<HM.00>>59120000
         BEGIN                                                 <<HM.00>>59125000
         GETFCBINFO;                                           <<HM.00>>59130000
         EOF := ENDF;                                          <<HM.00>>59135000
         END;                                                  <<HM.00>>59140000
      END;                                                              59145000
   IF LS0.(7:1) THEN                                                    59150000
      BEGIN        << file limit pointer wanted >>                      59155000
      IF NOT FBNDCHK(@FLIMIT,2,UBND) THEN GO BERR;             <<03059>>59160000
      IF FOREIGN THEN FLIMIT := DISCSIZE(LDN)                  <<01115>>59165000
        ELSE                                                   <<01115>>59170000
         BEGIN                                                 <<01115>>59175000
         GETFCBINFO;                                           <<01115>>59180000
         FLIMIT := FL;                                         <<01115>>59185000
         END;                                                  <<01115>>59190000
      END;                                                              59195000
   IF LS0.(8:1) THEN                                                    59200000
      BEGIN       << Record transfer count wanted. >>                   59205000
      IF NOT FBNDCHK(@LOGCOUNT,2,UBND) THEN GO BERR;           <<03059>>59210000
      LOGCOUNT := LCT;                                                  59215000
      END;                                                              59220000
   IF LS0.(9:1) THEN                                                    59225000
      BEGIN         << Block transfer count wanted. >>                  59230000
      IF NOT FBNDCHK(@PHYSCOUNT,2,UBND) THEN GO BERR;          <<03059>>59235000
      PHYSCOUNT := PCT;                                                 59240000
      END;                                                              59245000
   IF LS0.(10:1) THEN                                                   59250000
      BEGIN        << Block size wanted. >>                             59255000
      IF NOT FBNDCHK(@BLKSIZE,1,UBND) THEN GO BERR;            <<03059>>59260000
      BLKSIZE := BLKSI;                                                 59265000
      END;                                                              59270000
   IF LS0.(11:1) THEN                                                   59275000
      BEGIN        << Extent size wanted. >>                            59280000
      IF NOT FBNDCHK(@EXTSIZE,1,UBND) THEN GO BERR;            <<03059>>59285000
      GETFCBINFO;                                                       59290000
      EXTSIZE := EXTSI;                                                 59295000
      END;                                                              59300000
   IF LS0.(12:1) THEN                                                   59305000
      BEGIN       << Number of extents wanted. >>                       59310000
      IF NOT FBNDCHK(@NUMEXTENTS,1,UBND) THEN GO BERR;         <<03059>>59315000
      GETFCBINFO;                                                       59320000
      NUMEXTENTS := NE;                                                 59325000
      END;                                                              59330000
   IF LS0.(13:1) THEN                                                   59335000
      BEGIN      << Number of user labels wanted. >>                    59340000
      IF NOT FBNDCHK(@USERLABELS,1,UBND) THEN GO BERR;         <<03059>>59345000
      GETFCBINFO;                                                       59350000
      USERLABELS := UL;                                                 59355000
      END;                                                              59360000
   IF LS0.(14:1) THEN                                                   59365000
      BEGIN       << Creator I. D. wanted >>                            59370000
      IF NOT FBNDCHK(@CREATORID,-8,UBND) THEN GO BERR;         <<03059>>59375000
      CREATORID := " ";                                                 59380000
      MOVE CREATORID(1) := CREATORID,(7);                               59385000
      IF NOT NOFCB THEN                                                 59390000
         BEGIN          << Disk file. Get data from label >>            59395000
         RDLABEL;                                                       59400000
         TOS := @CREATORID; TOS := @FLUSERID&LSL(1);                    59405000
         MOVE * := *,(8)                                                59410000
         END;                                                           59415000
      END;                                                              59420000
   TOS := PMAP2;    << Second parameter bit map >>                      59425000
   IF TOS THEN                                                          59430000
      BEGIN       << File label address wanted. >>                      59435000
      IF NOT FBNDCHK(@DISKADR,1,UBND) THEN GO BERR;            <<03059>>59440000
      GETFCBINFO;                                                       59445000
      P1.(0:8) := LDN;                                                  59450000
      DISKADR := LABADDR;                                               59455000
      END;                                                              59460000
                                                                        59465000
   <<* * * Measurement data on FGETINFO * * *>>                         59470000
                                                                        59475000
$  IF X3 = ON                                                           59480000
   IF MEAS'TAPE'ON THEN BEGIN                                           59485000
   IF MEASURE                                                  <<06958>>59490000
      THEN MMSTAT'(EFGETINFO,FILENUM,PMAP1,PMAP2,0,0,0);       <<06958>>59495000
   END; << OF MEAS'TAPE'ON>>                                            59500000
$  IF                                                                   59505000
                                                                        59510000
   CONDCODE := CCE;                                                     59515000
   GO EXIT;                                                             59520000
                                                                        59525000
BERR:     << Bounds violation >>                                        59530000
   IF KSTYPE THEN FKSAMBNDVIOL(FILENUM);                       <<KS.00>>59535000
   IF FSTYPE OR MSGFILE THEN                                   <<HM.00>>59540000
      BEGIN                                                    <<HM.00>>59545000
      LOC'ACB(*,ACBMQ,FILENUM,UMODE);                          <<01672>>59550000
      ACB'ERROR := BNDVIOL;  << insert error nr. >>                     59555000
      UNLOC'ACB(ACBMQ,0);    << release ACB >>                 <<01672>>59560000
      END;                                                              59565000
                                                                        59570000
ERR:                                                                    59575000
   ERRS := TOS;    << Error nr. >>                                      59580000
   CONDCODE := CCL;                                                     59585000
                                                                        59590000
EXIT:                                                                   59595000
   RESETCRITICAL(CRIT);                                                 59600000
   ERROREXIT(22,ERRS,0)                                                 59605000
   END;           << procedure FGETINFO >>                              59610000
$PAGE " FGETPVINFO "                                                    59615000
$CONTROL SEGMENT = FILESYS3   << FGETPVINFO >>                          59620000
INTEGER PROCEDURE FGETPVINFO(FILENUM);                         <<00211>>59625000
VALUE FILENUM;  INTEGER FILENUM;                                        59630000
OPTION UNCALLABLE;                                                      59635000
   BEGIN                                                                59640000
   INTEGER CRIT;                                                        59645000
   LOGICAL DIRECTACCESS;                                                59650000
<< Following LOC'ACB params must be in order: >>                        59655000
   INTEGER ACBMQ;                                              <<06511>>59660000
   INTEGER AFTE;                                                        59665000
   DOUBLE  PACBV;                                              <<06511>>59670000
   DOUBLE  LACBV;                                              <<06511>>59675000
   INTEGER IOQX;                                                        59680000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>59685000
BUILD'ACB;                                                     <<06511>>59690000
   INTEGER DSTX;       << user's buffer DST >>                          59695000
   << End of LOC'ACB params >>                                          59700000
                                                                        59705000
   CRIT := SETCRITICAL;                                                 59710000
   GET'ACB'Q'LOC;                                              <<06511>>59715000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<06511>>59720000
   IF < THEN                                                            59725000
      CONDCODE := CCL    << invalid FILENUM >>                          59730000
   ELSE IF = THEN                                                       59735000
      BEGIN      << Valid file number >>                                59740000
      IF FTYPE >= 1  AND  FTYPE <= 5 THEN                      <<04877>>59745000
         BEGIN          <<  Remote, DS, or CS >>               <<04877>>59750000
         FGETPVINFO := -1;                                     <<04877>>59755000
         CONDCODE := CCE;                                      <<04877>>59760000
         RESETCRITICAL(CRIT);                                  <<04877>>59765000
         RETURN;                                               <<04877>>59770000
         END;                                                  <<04877>>59775000
      CONDCODE := CCE;                                                  59780000
      DIRECTACCESS :=                                          <<06511>>59785000
               (ACB'ACCCL=DIRACC) LAND (ACB'DTYPE <> FDISC);   <<06511>>59790000
      IF DIRECTACCESS THEN                                              59795000
         BEGIN                                                          59800000
         TOS := GETFCB'INFO(ACB'FCB,9);                                 59805000
         DEL;      << extra half of double >>                           59810000
         FGETPVINFO := TOS;                                             59815000
         END;                                                           59820000
      UNLOC'ACB(ACBMQ,0);                                      <<06511>>59825000
      END ELSE CONDCODE := CCE;  << $NULL >>                            59830000
   RESETCRITICAL(CRIT);                                                 59835000
   END;      << procedure FGETPVINFO >>                                 59840000
$PAGE "FVERSION"                                               <<*8760>>59845000
$CONTROL SEGMENT=FILESYS3                                      <<*8760>>59850000
INTEGER PROCEDURE FVERSION;                                    <<*8760>>59855000
<< This procedure returns the current version of the file >>   <<*8760>>59860000
<< system.  This version is necessary for those cases when>>   <<*8760>>59865000
<< an enhancement is required to know if the remote       >>   <<*8760>>59870000
<< machine also knows about this enchancement for a remote>>   <<*8760>>59875000
<< procedure call (such as a new ffileinfo number).  The  >>   <<*8760>>59880000
<< number is from 1 to 255 and is incremented each time   >>   <<*8760>>59885000
<< such an enhancement is made.                           >>   <<*8760>>59890000
BEGIN                                                          <<*8760>>59895000
FVERSION := 2;                                                 <<*8760>>59900000
END;                                                           <<*8760>>59905000
                                                               <<*8760>>59910000
$PAGE " FFILEINFO "                                                     59915000
$CONTROL SEGMENT=FILESYS3   << FFILEINFO >>                    <<00630>>59920000
                                                                        59925000
PROCEDURE FFILEINFO(FILENUM,ITEMNUM1,ITEMVAL1,                 <<00630>>59930000
                    ITEMNUM2,ITEMVAL2,ITEMNUM3,ITEMVAL3,                59935000
                    ITEMNUM4,ITEMVAL4,ITEMNUM5,ITEMVAL5);               59940000
VALUE FILENUM,ITEMNUM1,ITEMNUM2,ITEMNUM3,ITEMNUM4,ITEMNUM5;             59945000
INTEGER FILENUM,ITEMNUM1,ITEMNUM2,ITEMNUM3,ITEMNUM4,                    59950000
        ITEMNUM5;                                                       59955000
BYTE ARRAY ITEMVAL1,ITEMVAL2,ITEMVAL3,ITEMVAL4,ITEMVAL5;                59960000
OPTION VARIABLE,PRIVILEGED;                                             59965000
   BEGIN                                                                59970000
                                                                        59975000
   EQUATE                                                               59980000
      CALLSEQSIZE = 12,   << # words incl PARMMASK >>                   59985000
      FILEPARM = 10,     << LSR for "FILE" PARMMASK bit >>              59990000
      ITEM1PARM = 9;     << LSR for "ITEMNUM1" PARMMASK bit >>          59995000
   INTEGER ARRAY                                                        60000000
      PARM(*) = Q-5;                                                    60005000
   LOGICAL                                                              60010000
      PARMMASK = Q-4;                                          <<03059>>60015000
   EQUATE                                                      <<03059>>60020000
      UBND =   -16; << Q rel upper bound for user addresses>>  <<03059>>60025000
                                                                        60030000
   DEFINE                                                               60035000
      DEALLOCFLAB =                                                     60040000
         BEGIN                                                          60045000
         FLAB := 0;                                                     60050000
         MOVE FLAB(1) := FLAB,(127);                                    60055000
         ASSEMBLE(SUBS 128);                                            60060000
         END #;                                                         60065000
   DEFINE                                                               60070000
      STD'QINFOPTR =                                                    60075000
         BEGIN     << store Double from TOS >>                          60080000
         ASSEMBLE(XCH);                                                 60085000
         AQ0(QINFOPTR) := TOS;                                          60090000
         AQ0(X:=X+1) := TOS;                                            60095000
         END #;                                                         60100000
   DEFINE                                                      <<01115>>60105000
      FGIERR=                                                           60110000
         BEGIN                                                          60115000
         IF <> THEN                                                     60120000
            BEGIN                                                       60125000
            TOS := 0;  <<ignore error -- set by FGETINFO>>              60130000
            TOS := CCL;                                                 60135000
            GO EXIT;                                                    60140000
            END;                                                        60145000
         END#;                                                 <<01115>>60150000
   EQUATE                                                               60155000
      INFOSIZE = 6,     << INFODESC entry size >>              <<01864>>60160000
      NULLAOP = 4,      << for $NULL >>                                 60165000
      NULLFOP = %60;    << for $NULL >>                                 60170000
   DEFINE SPULAB'LAST'ENV = ULABEL(11)#;                                60175000
                                                                        60180000
   BYTE POINTER                                                         60185000
      ITEMVAL;                                                          60190000
   DOUBLE                                                               60195000
      FLABADDR := 0D,  << LDEV=0 ==> unknown addr >>                    60200000
      SECTOR;                                                           60205000
   ARRAY                                                       <<07284>>60210000
      LDT'DEN'TO'REAL'DEN(0:3)=PB := -1,1600,6250,800;         <<07284>>60215000
   INTEGER                                                              60220000
      TERM'TYPE,                 ! Return from GET'DSDEVICE.   <<07234>>60225000
      CRIT,                                                             60230000
      I,                                                                60235000
      INFOLIMIT,     << LAST+1 index for INFODESC >>                    60240000
      ITEMNUM,                                                          60245000
      ITEMSIZE,                                                         60250000
      LDEV,                                                             60255000
      LDT'DENW,       << LDT entry density info, used for 46 >><<02560>>60260000
      LDT'DEVTYPE,    << dev type from LDT >>                  <<01115>>60265000
      LDEV'SUBTYPE,   << dev subtype from LPDT >>              <<07284>>60270000
      PINDEX,         << LSR/INDEX for PARMMASK/PARM>>                  60275000
      QINFODESC,      << Q-rel addr of INFODESC>>                       60280000
      QINFOINDEX,     << Q-rel index into INFODESC>>                    60285000
      QINFOLIMIT,     << Q-rel addr of INFODESC(INFOLIMIT)>>            60290000
      QINFOPTR,                                                         60295000
      TABLEITEM,                                                        60300000
      TABLENUM;                                                         60305000
   INTEGER POINTER AFT;  ! For pointing to DS AFT.             <<06756>>60310000
                                                               <<*8760>>60315000
   << declarations for remote file node name info >>           <<*8760>>60320000
   EQUATE MAX'REMOTE'LEN = 52;                                 <<*8760>>60325000
   BYTE ARRAY REMOTE'STRING(*);<< entire string for remote  >> <<*8760>>60330000
                               << string                    >> <<*8760>>60335000
                                                               <<01864>>60340000
COMMENT --                                                     <<01864>>60345000
  The following array, INFODESC, holds per-item data which is  <<01864>>60350000
used to retrieve the needed information from wherever it re-   <<01864>>60355000
sides, gather it in a local buffer INFO, then move it to       <<01864>>60360000
wherever the user wants it.                                    <<01864>>60365000
  An entry in INFODESC currently has six words.  Since all     <<01864>>60370000
references to entry size are through use of the equated length <<01864>>60375000
INFOSIZE (see below), it is quite easy to change the length of <<01864>>60380000
an entry.  A typical entry is shown below:                     <<01864>>60385000
                                                               <<01864>>60390000
   Entry-                                                      <<01864>>60395000
   relative                                                    <<01864>>60400000
   word      Identifier   Description                          <<01864>>60405000
   --------  ----------   -----------                          <<01864>>60410000
                                                               <<01864>>60415000
      0      TABLENUM     Arbitrarily assigned number of a     <<01864>>60420000
                          system table where the desired       <<01864>>60425000
                          information can be found.  See the   <<01864>>60430000
                          Equates in the Item Descriptor       <<01864>>60435000
                          Tables section.                      <<01864>>60440000
                                                               <<01864>>60445000
      1      TABLEITEM    Item within the TABLENUM table where <<01864>>60450000
                          the info actually lives.  New items  <<01864>>60455000
                          are assigned sequentially.           <<01864>>60460000
                                                               <<01864>>60465000
      2      QINFOPTR     See below.  Points to area of Info   <<01864>>60470000
                          where information retrieved from     <<01864>>60475000
                          TABLEITEM is placed before being     <<01864>>60480000
                          moved to caller's stack.             <<01864>>60485000
                                                               <<01864>>60490000
      3      @ITEMVAL     Ultimate destination of information  <<01864>>60495000
                          (in caller's stack) for this item.   <<01864>>60500000
                          A byte address.                      <<01864>>60505000
                                                               <<01864>>60510000
      4      ITEMSIZE     Length in bytes of the desired       <<01864>>60515000
                          information.  Defined further below. <<01864>>60520000
                                                               <<01864>>60525000
      5      ITEMNUM      The sequentially assigned number in  <<01864>>60530000
                          ITEMDESC, a table of all supported   <<01864>>60535000
                          FFILEINFO items.  Used when the      <<01864>>60540000
                          target file is remote.               <<01864>>60545000
                                                               <<01864>>60550000
Various  identifiers  starting  with  "[Q]INFO"  ("Q"  denotes <<01864>>60555000
Q-relative  versions  of the Q-less names) are associated with <<01864>>60560000
this array:                                                    <<01864>>60565000
                                                               <<01864>>60570000
  INFOSIZE     -- The length of each entry in INFODESC.  Since <<01864>>60575000
                  there are five entries (to  accommodate  the <<01864>>60580000
                  maximum  five  caller parameter pairs), this <<01864>>60585000
                  leads naturally to the INFODESC declaration. <<01864>>60590000
                                                               <<01864>>60595000
  QINFOINDEX   -- Pointer to the first word in the current en- <<01864>>60600000
                  try.                                         <<01864>>60605000
                                                               <<01864>>60610000
  [Q]INFOLIMIT -- Points to  next  available  INFODESC  entry, <<01864>>60615000
                  thereby  defining  the end of valid informa- <<01864>>60620000
                  tion in INFODESC.                            <<01864>>60625000
                                                               <<01864>>60630000
  QINFOPTR     -- Q-relative pointer to  INFO,  a  dynamically <<01864>>60635000
                  built  local  buffer which holds information <<01864>>60640000
                  retrieved from various locations in the sys- <<01864>>60645000
                  tem before it is moved to its final destina- <<01864>>60650000
                  tions in the user's stack.  QINFOPTR  serves <<01864>>60655000
                  two  purposes:   1) It points to the area of <<01864>>60660000
                  INFO where information for the current INFO- <<01864>>60665000
                  DESC entry is placed, and 2) it defines  the <<01864>>60670000
                  size of INFO after PREPROCESS finishes find- <<01864>>60675000
                  ing out what the (total) size is of all the  <<01864>>60680000
                  parameter items supplied by the user.        <<01864>>60685000
;                                                              <<01864>>60690000
   INTEGER ARRAY                                                        60695000
      INFODESC(0:INFOSIZE*5-1);                                         60700000
   INTEGER POINTER                                                      60705000
      FCB,                                                              60710000
      FLAB,                                                             60715000
      ULABEL=FLAB,                                                      60720000
      XDDEP,    << Spoolfile entry pointer >>                  <<00483>>60725000
      INFO;                                                             60730000
   LOGICAL                                                              60735000
      NOFCB,                                                            60740000
      NULLFILE := FALSE,                                                60745000
      SPOOLED;                                                          60750000
   DOUBLE POINTER                                                       60755000
      FCBDBL = FCB,                                                     60760000
      FLABDBL = FLAB;                                                   60765000
   INTEGER                                                              60770000
      ISECTOR = SECTOR;                                                 60775000
                                                               <<*7845>>60780000
   EQUATE                                                      <<*7845>>60785000
      LAST'MPE4'ITEM = 49;  << last MPE4 supported item num >> <<*7845>>60790000
   INTEGER                                                     <<*7845>>60795000
      REMOTE'VERSION; << MPE version on remote system.      >> <<*7845>>60800000
                                                               <<*8760>>60805000
EQUATE  MPEV5'FVERSION = 1;  << MPEV/E File system version >>  <<*8760>>60810000
                                                                        60815000
                                                               <<01864>>60820000
<< Remote File Access (RFA) Variables.                      >> <<01864>>60825000
                                                               <<01864>>60830000
EQUATE                                                         <<01864>>60835000
  REMOTE'FILE = 1;  << FTYPE of remote file.                >> <<01864>>60840000
                                                               <<01864>>60845000
INTEGER POINTER                                                <<01864>>60850000
  RFAPTR;           << Message array (appendage) pointer.   >> <<01864>>60855000
                                                               <<01864>>60860000
INTEGER                                                        <<01864>>60865000
  RFA'BUF'LENGTH,   << Length of data to be returned by DS. >> <<01864>>60870000
  RFALEN,           << Length of appendage.                 >> <<01864>>60875000
  RFA'PARMMASK;     << Parameter mask to remote FFILEINFO.  >> <<01864>>60880000
                                                                        60885000
   << Following LOC'ACB params must be in order: >>                     60890000
   INTEGER ACBMQ;                                              <<06511>>60895000
   INTEGER AFTE;      << AFT entry word 0 >>                            60900000
   DOUBLE  PACBV;                                              <<06511>>60905000
   DOUBLE  LACBV;                                              <<06511>>60910000
   INTEGER IOQX;                                                        60915000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q + ACBMQ >>     <<06511>>60920000
                                                               <<06511>>60925000
   BUILD'ACB;                                                           60930000
   LOGICAL DSTX;     << DST nr. of caller's buffer >>                   60935000
   << end of LOC'ACB params >>                                          60940000
                                                                        60945000
                                                                        60950000
   <<******************************>>                                   60955000
   <<  Item Descriptor Tables      >>                                   60960000
   <<******************************>>                                   60965000
                                                                        60970000
   COMMENT:                                                             60975000
      When adding new item, must update the following:                  60980000
         MAXITEMNUM = last valid item number                            60985000
         ITEMDESC   = determines item size & system table.              60990000
      When adding new (system) table, must update following:            60995000
         MAXTABLENUM = last valid table number.                         61000000
      ;                                                                 61005000
                                                                        61010000
   EQUATE                                                               61015000
      DESCSIZE = 2,     << ITEMDESC entry size >>                       61020000
      MAXITEMNUM = 61,                                         <<*8760>>61025000
      INTSIZE = 2,      << # bytes in integer >>                        61030000
      LOGSIZE = 2,      << # bytes in logical >>                        61035000
      DBLSIZE = 4;      << # bytes in double >>                         61040000
   EQUATE                                                               61045000
      ADHOCTABLE = 1,                                                   61050000
      ACBTABLE = 2,                                                     61055000
      FCBTABLE = 3,                                                     61060000
      FLABTABLE = 4,                                                    61065000
      TAPETABLE = 5,                                           <<01864>>61070000
      MAXTABLENUM=TAPETABLE;                                   <<01864>>61075000
   LOGICAL ARRAY                                                        61080000
      ACCESSTABLE(0:MAXTABLENUM);  << TRUE if table accessed >>         61085000
                                                                        61090000
   COMMENT:                                                             61095000
      "ITEMDESC" is indexed by ITEMNUM.  Entry format is:               61100000
         ITEMSIZE, [8/TABLENUM, 8/TABLEITEM]                            61105000
         ITEMSIZE  = # bytes in ITEM.  Used for bounds check on         61110000
                     ITEMVAL, so set to 0 if unknown or variable.       61115000
                                                                        61120000
         TABLENUM  = arbitrary number denoting sys table from           61125000
                     which item is retrieved.  Use "ADHOCTABLE"         61130000
                     (atble #0) if table unknown                        61135000
         TABLEITEM = corresponds to CASE-stmt index for table           61140000
                     retrieval.  TABLEITEM #0 of table #0 means         61145000
                     undefined item number.                             61150000
      Note that ITEMNUM #0 indicates a parameter which is to be         61155000
      ignored, just as if the ITEMNUM/VAL pair were missing.            61160000
      TABLENUM #0 must be mapped into another table number ...          61165000
      if mapped back to TABLENUM #0, this denotes an undefined          61170000
      item.                                                             61175000
      ;                                                                 61180000
                                                                        61185000
   EQUATE                                                               61190000
      ACBFOPITEM = 0,  <<item # in ACBTABLE>>                           61195000
      ACBAOPITEM = 1;  <<item # in ACBTABLE>>                           61200000
                                                                        61205000
   INTEGER ARRAY ITEMDESC(*) = PB :=                                    61210000
                                                                        61215000
              << FGETINFO items >>                                      61220000
                                                                        61225000
      <<000>> 0,       [8/0,          8/00], <<"missing">>              61230000
      <<001>> 28,      [8/ADHOCTABLE, 8/00], <<FNAME>>                  61235000
      <<002>> LOGSIZE, [8/ACBTABLE,   8/00], <<FOPS>>                   61240000
      <<003>> LOGSIZE, [8/ACBTABLE,   8/01], <<AOPS>>                   61245000
      <<004>> INTSIZE, [8/ADHOCTABLE, 8/01], <<RECSIZE>>                61250000
      <<005>> INTSIZE, [8/ADHOCTABLE, 8/02], <<DEVTYPE>>                61255000
      <<006>> LOGSIZE, [8/ACBTABLE,   8/02], <<LDEV>>                   61260000
      <<007>> LOGSIZE, [8/ADHOCTABLE, 8/03], <<UNIT,DRT>>               61265000
      <<008>> INTSIZE, [8/FLABTABLE,  8/03], << file code >>   <<00483>>61270000
      <<009>> DBLSIZE, [8/ACBTABLE,   8/03], <<RECPTR>>                 61275000
      <<010>> DBLSIZE, [8/FCBTABLE,   8/00], <<EOF>>                    61280000
      <<011>> DBLSIZE, [8/ADHOCTABLE, 8/06], <<FLIMIT>>        <<01864>>61285000
      <<012>> DBLSIZE, [8/ACBTABLE,   8/04], <<LOGCNT>>                 61290000
      <<013>> DBLSIZE, [8/ACBTABLE,   8/05], <<PHYCNT>>                 61295000
      <<014>> INTSIZE, [8/ADHOCTABLE, 8/05], <<BLKSIZE>>                61300000
      <<015>> LOGSIZE, [8/FCBTABLE,   8/02], <<EXTSIZE>>                61305000
      <<016>> INTSIZE, [8/FCBTABLE,   8/03], <<NUMEXT>>                 61310000
      <<017>> INTSIZE, [8/FCBTABLE,   8/04], <<ULABELS>>                61315000
      <<018>> 8,       [8/FLABTABLE,  8/00], <<CREATOR>>                61320000
      <<019>> DBLSIZE, [8/FCBTABLE,   8/05], <<LBLADDR>>                61325000
                                                                        61330000
              << Relative I/O >>                                        61335000
                                                                        61340000
      <<020>> INTSIZE, [8/ACBTABLE,   8/06], <<BLKFACT>>                61345000
      <<021>> INTSIZE, [8/ACBTABLE,   8/07], <<PHY BSIZE>>              61350000
      <<022>> INTSIZE, [8/ACBTABLE,   8/08], <<DATA BSIZE>>             61355000
      <<023>> INTSIZE, [8/ACBTABLE,   8/09], <<DATA OFFSET>>            61360000
      <<024>> INTSIZE, [8/ACBTABLE,   8/10], <<ART OFFSET>>             61365000
      <<025>> INTSIZE, [8/ACBTABLE,   8/11], <<ART SIZE>>               61370000
                                                                        61375000
              << Labeled tapes >>                                       61380000
                                                                        61385000
      <<026>> 6,       [8/TAPETABLE,  8/00], <<VOL ID>>        <<00828>>61390000
      <<027>> 6,       [8/TAPETABLE,  8/01], <<VOL SET ID>>    <<00828>>61395000
      <<028>> INTSIZE, [8/TAPETABLE,  8/02], <<EXP DATE>>      <<00828>>61400000
      <<029>> INTSIZE, [8/TAPETABLE,  8/03], <<FILE SEQ NUM>>  <<00828>>61405000
      <<030>> INTSIZE, [8/TAPETABLE,  8/04], <<REEL NUM>>      <<00828>>61410000
      <<031>> INTSIZE, [8/TAPETABLE,  8/05], <<SEQ TYPE>>      <<00828>>61415000
      <<032>> INTSIZE, [8/TAPETABLE,  8/06], <<CREATE DATE>>   <<00828>>61420000
      <<033>> INTSIZE, [8/TAPETABLE,  8/07], <<LABEL TYPE>>    <<00828>>61425000
                                                                        61430000
              << Interprocess communication >>                          61435000
                                                                        61440000
      <<034>> INTSIZE, [8/ACBTABLE,   8/13], <<# WRITERS>>     <<HM.00>>61445000
      <<035>> INTSIZE, [8/ACBTABLE,   8/14], <<# READERS>>     <<HM.00>>61450000
                                                                        61455000
              << Miscellaneous >>                                       61460000
                                                                        61465000
      <<036>> LOGSIZE, [8/FLABTABLE,  8/01], << Alloc date >>           61470000
      <<037>> DBLSIZE, [8/FLABTABLE,  8/02], << Alloc time >>           61475000
      <<038>> LOGSIZE, [8/ACBTABLE,   8/12], << DevfileID >>   <<00483>>61480000
      <<039>> LOGSIZE, [8/FCBTABLE,   8/06], <<first nz extnt>>         61485000
      <<040>> DBLSIZE, [8/ADHOCTABLE, 8/04], << disk status >> <<01115>>61490000
      <<041>> INTSIZE, [8/ADHOCTABLE, 8/07], << LDT type >>    <<01115>>61495000
      <<042>> INTSIZE, [8/ADHOCTABLE, 8/08], << LPDT subtype >><<01115>>61500000
      <<043>> 36,      [8/ADHOCTABLE, 8/09], << spoofle environment >>  61505000
      <<044>> INTSIZE, [8/FCBTABLE,   8/01], << nr. of last extent >>   61510000
      <<045>> 17,      [8/TAPETABLE,  8/08], << tapefile name>><<02545>>61515000
      <<046>> INTSIZE, [8/ADHOCTABLE, 8/10], << density >>     <<02560>>61520000
      <<047>> LOGSIZE, [8/ACBTABLE,   8/15], << DRT >>         <<03052>>61525000
      <<048>> LOGSIZE, [8/ACBTABLE,   8/16], << UNIT >>        <<03052>>61530000
      <<049>> INTSIZE, [8/ACBTABLE,   8/17], <<softint plabel>><<03657>>61535000
      <<050>> LOGSIZE, [8/ACBTABLE,   8/02], << LDEV        >> <<06756>>61540000
      <<051>> LOGSIZE, [8/ADHOCTABLE, 8/11], << Virt. ldev  >> <<06756>>61545000
      <<052>> DBLSIZE, [8/FLABTABLE,  8/04], << Mod. time   >> <<07234>>61550000
      <<053>> LOGSIZE, [8/FLABTABLE,  8/05], << Mode date   >> <<07234>>61555000
      <<054>> LOGSIZE, [8/FLABTABLE,  8/06], << Create date >> <<07234>>61560000
      <<055>> LOGSIZE, [8/FLABTABLE,  8/07], << Last access >> <<07234>>61565000
      <<056>> DBLSIZE, [8/FCBTABLE,   8/07], << Var blks.   >> <<07234>>61570000
      <<057>> INTSIZE, [8/FCBTABLE,   8/08], << User labels >> <<07234>>61575000
      <<058>> INTSIZE, [8/FCBTABLE,   8/09], << Output cnt. >> <<07234>>61580000
      <<059>> INTSIZE, [8/FCBTABLE,   8/10], << Input cnt.  >> <<07234>>61585000
      <<060>> INTSIZE, [8/ADHOCTABLE, 8/12], << Term type   >> <<07234>>61590000
      <<061>> MAX'REMOTE'LEN, [8/ADHOCTABLE, 8/13],<< node >>  <<*8760>>61595000
              0;  << Dummy -- always last >>                            61600000
ARRAY TOP(*)=FILENUM; <<FOR KSAM>>                             <<04876>>61605000
ARRAY DUMMY(0:11); <<FOR KSAM, must be last declaration)       <<04876>>61610000
                                                               <<07234>>61615000
!------------------------------------------------------------- <<07234>>61620000
! This array maps the return value from GET'DSDEVICE into an   <<07234>>61625000
! FFILEINFO return value for item 60.  3 is a DS psuedo term-  <<07234>>61630000
! inal, 4 is a PAD terminal, 5 & 6 are reserved for future.    <<07234>>61635000
!------------------------------------------------------------- <<07234>>61640000
INTEGER ARRAY DSDEVICE'MAP(-2:6) = PB := 0,0,0,0,0,3,4,0,0;    <<07234>>61645000
                                                                        61650000
                                                                        61655000
   <<******************************>>                                   61660000
   <<  Subroutine CHECKPARM        >>                                   61665000
   <<******************************>>                                   61670000
                                                                        61675000
   INTEGER SUBROUTINE CHECKPARM;                                        61680000
      BEGIN                                                             61685000
      COMMENT:                                                          61690000
         On entry, PINDEX is PARMMASK LSR & parm index to next          61695000
         ITEMNUM/VAL pair.  Returns -1 if pair valid or missing.        61700000
         Otherwise, returns file sys error number.  ITEMNUM=0           61705000
         if both parameters missing.                                    61710000
         ;                                                              61715000
      CHECKPARM := -1;                                                  61720000
      IF PARMMASK&LSR(PINDEX-1) XOR PARMMASK&LSR(PINDEX) THEN           61725000
         BEGIN    << Not both present or missing. >>                    61730000
         CHECKPARM := NONPAIR;                                          61735000
         RETURN;                                                        61740000
         END;                                                           61745000
      ITEMNUM := PARM(-PINDEX);                                         61750000
      @ITEMVAL := PARM(X:=X+1);                                         61755000
      IF NOT PARMMASK&LSR(PINDEX) THEN ITEMNUM := 0;                    61760000
                             << both parameters missing >>              61765000
      IF ITEMNUM <> 0 THEN                                              61770000
         BEGIN                                                          61775000
         IF NOT (1 <= ITEMNUM <= MAXITEMNUM) THEN                       61780000
            BEGIN                                                       61785000
            CHECKPARM := NONITEM;                                       61790000
            RETURN;                                                     61795000
            END;                                                        61800000
         ITEMSIZE := ITEMDESC(ITEMNUM*DESCSIZE);                        61805000
         TABLENUM := ITEMDESC(X:=X+1).(0:8);                            61810000
         TABLEITEM := ITEMDESC(X).(8:8);                                61815000
         IF NOT FBNDCHK(@ITEMVAL,-ITEMSIZE,UBND) THEN          <<03059>>61820000
            BEGIN                                                       61825000
            CHECKPARM := BNDVIOL;                                       61830000
            RETURN;                                                     61835000
            END;                                                        61840000
         END;                                                           61845000
      END;    << subroutine CHECKPARM >>                                61850000
                                                                        61855000
                                                                        61860000
   <<******************************>>                                   61865000
   <<  Subroutine FINDINFO         >>                                   61870000
   <<******************************>>                                   61875000
                                                                        61880000
   LOGICAL SUBROUTINE FINDINFO(TABLENUM);                               61885000
   VALUE TABLENUM;                                                      61890000
   INTEGER TABLENUM;                                                    61895000
      BEGIN                                                             61900000
      COMMENT:                                                          61905000
         On entry, QINFOINDEX points to where we left off in            61910000
         search.  Search INFODESC for next parameter which is           61915000
         retrieved from table "TABLENUM".                               61920000
                                                                        61925000
         NOTE:  DB need not be at stack.                                61930000
         ;                                                              61935000
      WHILE (QINFOINDEX := QINFOINDEX+INFOSIZE) < QINFOLIMIT DO         61940000
         BEGIN                                                          61945000
         IF AQ0(QINFOINDEX) = TABLENUM THEN                             61950000
            BEGIN                                                       61955000
            TABLEITEM := AQ0(X:=X+1);                                   61960000
            QINFOPTR := AQ0(X:=X+1);                                    61965000
            ITEMSIZE := AQ0(X:=X+2);                                    61970000
            FINDINFO := TRUE;                                           61975000
            RETURN;                                                     61980000
            END;                                                        61985000
         END;                                                           61990000
      QINFOINDEX := QINFODESC-INFOSIZE;                                 61995000
                        << Reset to search from 1st param again >>      62000000
      FINDINFO := FALSE;                                                62005000
      END;    << subroutine FINDINFO >>                                 62010000
   <<******************************>>                                   62015000
   <<  Subroutine ZEROITEM         >>                                   62020000
   <<******************************>>                                   62025000
                                                                        62030000
   SUBROUTINE ZEROITEM;                                                 62035000
      BEGIN                                                             62040000
      COMMENT:                                                          62045000
         DB need not be at the stack.                                   62050000
         ;                                                              62055000
      I := (ITEMSIZE+1)/2;  <<ITEMSIZE in words>>                       62060000
      X := QINFOPTR-1;                                         <<00657>>62065000
      WHILE (I:=I-1) >= 0 DO AQ0(X:=X+1) := 0;                 <<00657>>62070000
      END;     << subroutine ZEROITEM >>                                62075000
                                                                        62080000
                                                                        62085000
   <<******************************>>                                   62090000
   <<  Main procedure body         >>                                   62095000
   <<******************************>>                                   62100000
                                                                        62105000
$  IF X0=ON                                                             62110000
   IF MONCALLABLE THEN                                                  62115000
      BEGIN                                                             62120000
      FTITLE("FFIL","EINF","O   ",0D);                                  62125000
      DEBUG;                                                            62130000
      END;                                                              62135000
$  IF                                                                   62140000
                                                                        62145000
   ERRORON;                                                             62150000
   CRIT := SETCRITICAL;                                                 62155000
                                                                        62160000
   IF NOT PARMMASK&LSR(FILEPARM) THEN                                   62165000
      BEGIN    << FILENUM missing -- can't do anything. >>              62170000
      TOS := INVFN;                                                     62175000
      TOS := CCL;                                                       62180000
      GO EXIT2;                                                         62185000
      END;                                                              62190000
   GET'ACB'Q'LOC;                                              <<06511>>62195000
   LOC'ACB(0,ACBMQ,FILENUM,UMODE);                             <<01672>>62200000
   DSTX := TOS;                                                         62205000
   IF < THEN                                                            62210000
      BEGIN      << Bad FNUM. >>                                        62215000
      TOS := INVFN;                                                     62220000
      TOS := CCL;                                                       62225000
      GO EXIT2;                                                         62230000
      END;                                                              62235000
   IF > THEN                                                            62240000
      BEGIN    << file is $NULL >>                                      62245000
      NULLFILE := TRUE;                                                 62250000
      ACB'FCB := 0D;                                           <<06511>>62255000
      LDEV := 0;                                                        62260000
      SPOOLED := 0;                                                     62265000
      AFTE := 0;                                               <<02028>>62270000
      NOFCB := TRUE;                                                    62275000
      LDT'DEVTYPE := 0;                                        <<02676>>62280000
      LDEV'SUBTYPE := 0;                                       <<07284>>62285000
                                                               <<06042>>62290000
      END;                                                              62295000
                                                                        62300000
   IF DSTX <> 0 THEN                                                    62305000
      BEGIN      << DB not at stack. Barf >>                            62310000
      TOS := ILLDB;                                                     62315000
NFG:                                                                    62320000
      TOS := CCL;                                                       62325000
      GO EXIT;                                                          62330000
      END;                                                              62335000
   IF NULLFILE THEN      << Skip over CASE for $NULL file.  >> <<06042>>62340000
      GO PREPROCESS;                                           <<06042>>62345000
   CASE * FTYPE OF                                                      62350000
      BEGIN                                                             62355000
      <<0>> BEGIN  << conventional file >>                              62360000
            END;                                                        62365000
                                                                        62370000
      <<1>> BEGIN  << remote file >>                                    62375000
            END;                                                        62380000
                                                                        62385000
      <<2>> GOTO BADFTYPE;                                              62390000
      <<3>> GOTO BADFTYPE;                                              62395000
      <<4>> GOTO BADFTYPE;                                              62400000
                                                                        62405000
      <<5>> BEGIN                                                       62410000
BADFTYPE:                                                               62415000
            TOS := SYSTEM;                                              62420000
            GOTO NFG;                                                   62425000
            END;                                                        62430000
                                                                        62435000
      <<6>> BEGIN  << KSAM file >>                                      62440000
              MOVE DUMMY:=TOP,(12); <<PARAM LIST ON TOS>>      <<04876>>62445000
              ASMB(PCAL KFILEINFO);                            <<04876>>62450000
              PUSH (STATUS);                                   <<04876>>62455000
              IF <> THEN                                       <<04876>>62460000
                CONDCODE:=CCL                                  <<04876>>62465000
              ELSE                                             <<04876>>62470000
                CONDCODE:=CCE;                                 <<04876>>62475000
              GO TO E2;                                        <<04876>>62480000
            END;                                                        62485000
      <<7>> GOTO BADFTYPE;                                     <<HM.00>>62490000
      <<8>> BEGIN  <<MSG FILE>>                                <<HM.00>>62495000
            END;                                               <<HM.00>>62500000
      END;  <<file type CASES>>                                         62505000
                                                                        62510000
                                                                        62515000
   <<******************************>>                                   62520000
   <<  Preprocess parameters       >>                                   62525000
   <<******************************>>                                   62530000
                                                                        62535000
   COMMENT:                                                             62540000
      Save any globally required info from ACB.                         62545000
      ;                                                                 62550000
   SPOOLED := ACB'SPOOLED;                                              62555000
   IF SPOOLED                                                  <<04161>>62560000
     THEN LDEV := ACB'SPVDEV    << Virtual Ldev for spoolfile>><<06511>>62565000
   ELSE LDEV := ACB'DADDR;      << Real ldev for non spooled >><<04161>>62570000
                                                               <<04161>>62575000
   IF SPOOLED THEN @XDDEP := ACB'SPXDDX;                       <<06511>>62580000
   LDT'DEVTYPE := LDEVTOTYPE(LDEV);                            <<01115>>62585000
   LDEV'SUBTYPE := LDEVTOSUBTYPE(LDEV);                        <<07284>>62590000
   NOFCB := IF SPOOLED OR (ACB'DTYPE=FDISC) THEN TRUE          <<01115>>62595000
            ELSE (ACB'DTYPE LAND %70) <> DIRACC;                        62600000
PREPROCESS:                                                             62605000
                                                                        62610000
   COMMENT:                                                             62615000
Preprocess parameter list to simplify table manipulation                62620000
later.  All bounds and consistency checking is done here.               62625000
We also determine table from which info is to be extracted.  In         62630000
most cases, this is a table look-up.  In a few cases, we must           62635000
make some decisions.                                                    62640000
   We build two tables here.  INFODESC, which is allocated              62645000
Q-relative at procedure entry, has six words per               <<01864>>62650000
entry, identifying what values the user wants, where he                 62655000
wants them, and how big they are.  Following this we allot              62660000
QINFODESC, which is local storage for the values to be                  62665000
returned.  INFODESC is built with pointers into QINFODESC.              62670000
                                                                        62675000
   Note:  Top of stack must be same before/after WHILE-loop             62680000
since we build "INFO" space there.       ;                              62685000
                                                                        62690000
   ACCESSTABLE := 0;                                                    62695000
   MOVE ACCESSTABLE(1) := ACCESSTABLE,(MAXTABLENUM);                    62700000
   INFOLIMIT := 0;                                                      62705000
   @INFO := @S0+1;                                                      62710000
   QINFOPTR := @INFO-@Q0;    << Q-relative pointer >>                   62715000
                                                                        62720000
   PINDEX := ITEM1PARM+2;                                               62725000
   WHILE (PINDEX := PINDEX-2) >= 0 DO                                   62730000
      BEGIN                                                             62735000
      X := CHECKPARM;                                                   62740000
      IF X >= 0 THEN                                                    62745000
         BEGIN                                                          62750000
         TOS := X;                                                      62755000
         GOTO NFG;                                                      62760000
         END;                                                           62765000
      IF ITEMNUM <> 0 THEN                                              62770000
         BEGIN     << process item >>                                   62775000
         IF TABLENUM = 0 THEN                                           62780000
            BEGIN   << handle special cases >>                          62785000
            COMMENT:                                                    62790000
   Handle cases where table from which info is retrieved                62795000
depends on conditions.  Each case will redefine TABLENUM and            62800000
TABLEITEM.  Actual retrieval of info is below as usual.   ;             62805000
                                                                        62810000
            CASE TABLEITEM OF                                           62815000
               BEGIN                                                    62820000
               <<00>> TABLENUM := 0;  <<invalid ITEMNUM>>               62825000
               END;                                                     62830000
            END;    << special cases >>                                 62835000
                                                                        62840000
         IF TABLENUM = 0 THEN                                           62845000
            BEGIN     << Invalid ITEMNUM. >>                            62850000
            TOS := NONITEM;                                             62855000
            GOTO NFG;                                                   62860000
            END;                                                        62865000
         IF NOT (1 <= TABLENUM <= MAXTABLENUM) THEN                     62870000
            BEGIN                                                       62875000
            TOS := SYSTEM;                                              62880000
            GOTO NFG;                                                   62885000
            END;                                                        62890000
         INFODESC(INFOLIMIT) := TABLENUM;                               62895000
         INFODESC(X:=X+1) := TABLEITEM;                                 62900000
         INFODESC(X:=X+1) := QINFOPTR;                                  62905000
         INFODESC(X:=X+1) := @ITEMVAL;                                  62910000
         INFODESC(X:=X+1) := ITEMSIZE;                                  62915000
         INFODESC(X:=X+1) := ITEMNUM;                          <<01864>>62920000
         INFOLIMIT := X+1;    << next INFODESC entry >>                 62925000
         ACCESSTABLE(TABLENUM) := TRUE;                                 62930000
         QINFOPTR := (ITEMSIZE+1)/2 + QINFOPTR;  << next addr >>        62935000
         END;     << process item >>                                    62940000
      END;     <<WHILE>>                                                62945000
   TOS := QINFOPTR-(@INFO-@Q0);   << allocate info space >>             62950000
   RFA'BUF'LENGTH := S0;   << Need length here too for DS.  >> <<01864>>62955000
   ASSEMBLE(ADDS 0);                                                    62960000
   QINFODESC := @INFODESC-@Q0;    << Q-relative pntrs >>                62965000
   QINFOINDEX := QINFODESC-INFOSIZE;                                    62970000
   QINFOLIMIT := QINFODESC+INFOLIMIT;                                   62975000
                                                                        62980000
   IF FTYPE = REMOTE'FILE THEN                                 <<01864>>62985000
      BEGIN                                                    <<01864>>62990000
                                                               <<01864>>62995000
<<******************************>>                             <<01864>>63000000
<<   FFILEINFO on remote file   >>                             <<01864>>63005000
<<******************************>>                             <<01864>>63010000
                                                               <<01864>>63015000
COMMENT --                                                     <<01864>>63020000
  This section builds the message array for the  DS  interface <<01864>>63025000
procedure  MANAGEWRITECONVERSATION,  calls  the  procedure and <<01864>>63030000
then processes the results.  In keeping with the other intrin- <<01864>>63035000
sics, the message array will be built on the top of stack, al- <<01864>>63040000
though maintenance of such a structure can be quite difficult. <<01864>>63045000
The other side of the coin is that the array is allocated only <<01864>>63050000
when needed (that is, for accessing a remote file), thus  con- <<01864>>63055000
serving the stack.                                             <<01864>>63060000
  In addition to the message array, we pass DS the DB-relative <<01864>>63065000
address of the INFO array (@INFO).  The remote FFILEINFO  sets <<01864>>63070000
its  output  in  here and returns, making it seem as though we <<01864>>63075000
had done it.  We can then proceed directly to COPY'DATA.       <<01864>>63080000
  The fully-built stack (just before the call to  MANAGEWRITE- <<01864>>63085000
CONVERSATION) looks like this:                                 <<01864>>63090000
                                                               <<01864>>63095000
    +-------------------------------+                          <<01864>>63100000
    | INFO - space for returned data|                          <<01864>>63105000
    +-------------------------------+                          <<01864>>63110000
    | Message array (appendage) for |                          <<01864>>63115000
    | MANAGEWRITECONVERSATION       |                          <<01864>>63120000
    | (see below)                   |                          <<01864>>63125000
    +-------------------------------+                          <<01864>>63130000
    | DS parameters                 | \                        <<01864>>63135000
    | . . . . . . . . . . . . . . . |  \                       <<01864>>63140000
    | @appendage (stack-DB-relative)|   |                      <<01864>>63145000
    | . . . . . . . . . . . . . . . |   |                      <<01864>>63150000
    | Length of appendage           |   |                      <<01864>>63155000
    | . . . . . . . . . . . . . . . |   |                      <<01864>>63160000
    | @data array TO remote (0)     |   |  MANAGEWRITE-        <<01864>>63165000
    | . . . . . . . . . . . . . . . |    > CONVERSATION        <<01864>>63170000
    | Length of TO array (0)        |   |  parameters          <<01864>>63175000
    | . . . . . . . . . . . . . . . |   |                      <<01864>>63180000
    | @data array FROM remote       |   |                      <<01864>>63185000
    | (@INFO)                       |   |                      <<01864>>63190000
    | . . . . . . . . . . . . . . . |   |                      <<01864>>63195000
    | Length of FROM array          |  /                       <<01864>>63200000
    | (RFA'BUF'LENGTH)              | /                        <<01864>>63205000
    +-------------------------------+                          <<01864>>63210000
                                                               <<01864>>63215000
  Detail of message array for MANAGEWRITECONVERSATION:         <<01864>>63220000
                                                               <<01864>>63225000
                         1 1 1 1 1 1                           <<01864>>63230000
     0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5                           <<01864>>63235000
    +-------------------------------+                          <<01864>>63240000
    |      "R"      |      "F"      |                          <<01864>>63245000
    +-------------------------------+                          <<01864>>63250000
    |      "A"      |     blank     |                          <<01864>>63255000
    +-------------------------------+                          <<01864>>63260000
    | FFILEINFO DS-code (= %64)     |                          <<01864>>63265000
    +-------------------------------+                          <<01864>>63270000
    | RFA file number               |                          <<01864>>63275000
    +-------------------------------+                          <<01864>>63280000
    | ITEMNUM1 parameter            |                          <<01864>>63285000
    +-------------------------------+                          <<01864>>63290000
    | ITEMVALUE1 data length        |                          <<01864>>63295000
    +-------------------------------+                          <<01864>>63300000
    | ITEMNUM2 parameter            |                          <<01864>>63305000
    +-------------------------------+                          <<01864>>63310000
    | ITEMVALUE2 data length        |                          <<01864>>63315000
    +-------------------------------+                          <<01864>>63320000
    | ITEMNUM3 parameter            |                          <<01864>>63325000
    +-------------------------------+                          <<01864>>63330000
    | ITEMVALUE3 data length        |                          <<01864>>63335000
    +-------------------------------+                          <<01864>>63340000
    | ITEMNUM4 parameter            |                          <<01864>>63345000
    +-------------------------------+                          <<01864>>63350000
    | ITEMVALUE4 data length        |                          <<01864>>63355000
    +-------------------------------+                          <<01864>>63360000
    | ITEMNUM5 parameter            |                          <<01864>>63365000
    +-------------------------------+                          <<01864>>63370000
    | ITEMVALUE5 data length        |                          <<01864>>63375000
    +-------------------------------+                          <<01864>>63380000
    | OPTION VARIABLE mask          |                          <<01864>>63385000
    +-------------------------------+                          <<01864>>63390000
                                                               <<01864>>63395000
Note that "data length" of ITEMVALUE is passed rather than the <<01864>>63400000
ITEMVALUE itself or its address.  This fixes the length of the <<01864>>63405000
message array and makes remote buffer management easier. Since <<01864>>63410000
all items are optional, the "data length" of all unused  items <<01864>>63415000
is  set  to 0, in addition to clearing appropriate bits in the <<01864>>63420000
OPTION VARIABLE mask.  In addition, items in the message array <<01864>>63425000
are "crunched", that is, all items which are present appear in <<01864>>63430000
the lower-numbered "ITEMNUM's" above.  This is  a  consequence <<01864>>63435000
of the PREPROCESS code just before ours.                       <<01864>>63440000
                                                               <<01864>>63445000
The DS interface generates four reply structures:              <<01864>>63450000
  a)  A Head Section, used only by DS, which we never see.     <<01864>>63455000
  b)  An Appendage section consisting only of the remote       <<01864>>63460000
      FFILEINFO  status word.  It overlays (the first word of) <<01864>>63465000
      our appendage, that is, our message array.               <<01864>>63470000
  c)  A Data section, which goes into INFO.                    <<01864>>63475000
  d)  The one-word result of MANAGEWRITECONVERSATION, which is <<01864>>63480000
      the actual length of the data placed in RFA'BUFFER. This <<01864>>63485000
      result is discarded.                                     <<01864>>63490000
;                                                              <<01864>>63495000
      IF INFOLIMIT = 0 THEN                                    <<01864>>63500000
         BEGIN   << No parameters, skip the DS call.        >> <<01864>>63505000
         TOS := 0;                                             <<01864>>63510000
         TOS := CCE;                                           <<01864>>63515000
         GO EXIT;                                              <<01864>>63520000
         END;                                                  <<01864>>63525000
      SETRFAPTR;     << Build message array on TOS.         >> <<01864>>63530000
      RFALEN := 15;  << Length of message array (appendage) >> <<01864>>63535000
      TOS := "RFA ";                                           <<01864>>63540000
      TOS := %64;    << FFILEINFO DS code = intrinsic no.   >> <<01864>>63545000
      TOS := RFAFILE;                                          <<01864>>63550000
                                                               <<01864>>63555000
COMMENT --                                                     <<01864>>63560000
  Stack parameters actually present, then add 0 for others.    <<01864>>63565000
Account for presence or absence of parameters in RFA'PARMMASK. <<01864>>63570000
We can't use FFILEINFO's PARMMASK because PREPROCESS may  have <<01864>>63575000
crunched our parameters.  We can't use FOR loops because we're <<01864>>63580000
diddling the stack.                                            <<01864>>63585000
;                                                              <<01864>>63590000
      TOS := RFALINE; << Use SETAFT' to set @AFT based on TOS>><<*7845>>63595000
      SETAFT';        << to DS AFT                           >><<*7845>>63600000
                                                               <<*7845>>63605000
      TOS := 0;  << space for return value >>                  <<*7845>>63610000
      TOS := RFALINE;                                          <<*7845>>63615000
      GET'REMOTE'MPE'PLABEL;  << Places the plabel on TOS >>   <<*7845>>63620000
      ASSEMBLE(PCAL 0);                                        <<*7845>>63625000
      << Note that return code is not checked, if the call >>  <<*7845>>63630000
      << failed either a 0 or -1 is returned.   In this    >>  <<*7845>>63635000
      << case we will treat it like the remote machine is  >>  <<*7845>>63640000
      << running without tables expansion.                 >>  <<*7845>>63645000
                                                               <<*7845>>63650000
      REMOTE'VERSION := TOS;  << 5 iff tables expansion   >>   <<*7845>>63655000
      RFA'PARMMASK := 1;   << FILENUM is always there.      >> <<01864>>63660000
      I := 5;                                                  <<01864>>63665000
      WHILE I < INFOLIMIT DO                                   <<01864>>63670000
         BEGIN   << Stack existing parameters >>               <<01864>>63675000
<<----------------------------------------------------------->><<*7845>>63680000
<< Stack item number on top of stack.  If the remote file is >><<*7845>>63685000
<< not MPEV/E or greater then we must send an ffileinfo 6 to >><<*7845>>63690000
<< get the ldev of the remote file.  The packed ldevs is then>><<*7845>>63695000
<< unpacked below.                                           >><<*7845>>63700000
<<----------------------------------------------------------->><<*7845>>63705000
                                                               <<*7845>>63710000
         IF INFODESC(I) > LAST'MPE4'ITEM AND                   <<*7845>>63715000
                  REMOTE'VERSION < MPEV5'FVERSION THEN         <<*8760>>63720000
            BEGIN                                              <<*7845>>63725000
            IF INFODESC(I) = 51 OR INFODESC(I) = 50 THEN       <<*7845>>63730000
               TOS := 6         << get ldev and virtldev >>    <<*7845>>63735000
            ELSE IF INFODESC(I) = 61 THEN                      <<*8760>>63740000
               TOS := 6  << Dummy call for remote string >>    <<*8760>>63745000
            ELSE                                               <<*7845>>63750000
               BEGIN                                           <<*7845>>63755000
               TOS := REMOTE'ITEM'NOT'SUPPORTED;               <<*7845>>63760000
               GO NFG;                                         <<*7845>>63765000
               END;                                            <<*7845>>63770000
            END                                                <<*7845>>63775000
         ELSE TOS := INFODESC(I);                              <<*7845>>63780000
         TOS := INFODESC(X := X-1);    << Current ITEMSIZE. >> <<01864>>63785000
         RFA'PARMMASK := RFA'PARMMASK&LSL(2)+3;                <<01864>>63790000
         I := I + INFOSIZE;            << Next entry.       >> <<01864>>63795000
         END;                                                  <<01864>>63800000
      WHILE I < 5*INFOSIZE DO                                  <<01864>>63805000
         BEGIN   << Stack 0 for missing parameters.         >> <<01864>>63810000
         TOS := 0D;                                            <<01864>>63815000
         RFA'PARMMASK := RFA'PARMMASK & LSL(2);                <<01864>>63820000
         I := I + INFOSIZE;                                    <<01864>>63825000
         END;   << of stacking omitted parameters.          >> <<01864>>63830000
      TOS := RFA'PARMMASK;                                     <<01864>>63835000
      GETMWCPARMS;      << Stack MANAGEWRITE... boilerplate.>> <<01864>>63840000
      TOS := 0D;        << Not passing any data.            >> <<01864>>63845000
      TOS := @INFO;            << But we're getting...      >> <<01864>>63850000
      TOS := RFA'BUF'LENGTH;   << ...some back.             >> <<01864>>63855000
      TOS := MWCPLABEL;                                        <<01864>>63860000
      ASSEMBLE (PCAL 0);       << Thar she blows!           >> <<01864>>63865000
      DEL;                     << Don't need xfr length.    >> <<01864>>63870000
      CHECKXFER;   << Checks for DS err, not FFILEINFO err. >> <<01864>>63875000
      DELAPPENDAGE;   << Cut back stack except for status.  >> <<01864>>63880000
      TOS := TOS.CC;   << This is remote FFILEINFO CC.      >> <<01864>>63885000
      ASSEMBLE(ZERO,XCH);     << Report no FSERR here.      >> <<01864>>63890000
      IF S0 <> CCE THEN GO EXIT;   << Remote FFILEINFO err. >> <<01864>>63895000
      DDEL;              << Don't need status, FSERR here.  >> <<01864>>63900000
                                                               <<06756>>63905000
      !------------------------------------------------------- <<06756>>63910000
      ! There exists two items that must be dealt with from    <<06756>>63915000
      ! the local side, items 6 and 51.  These contain the     <<06756>>63920000
      ! virtual ldev number.  First, find the DS AFT.  Then    <<06756>>63925000
      ! search the INFODESC array for these item numbers.  If  <<06756>>63930000
      ! found, update the array.  If the real or virtual LDEV  <<06756>>63935000
      ! is > 255, then item 6 is returned with a 0.            <<06756>>63940000
      !------------------------------------------------------- <<06756>>63945000
                                                               <<06756>>63950000
      FOR I:=0 STEP INFOSIZE UNTIL INFOLIMIT-1 DO              <<06756>>63955000
         BEGIN                 ! Step through info table.      <<06756>>63960000
         QINFOPTR := INFODESC(I+2);                            <<06756>>63965000
         IF INFODESC(I+5) = 51 THEN                            <<06756>>63970000
            AQ0(QINFOPTR) := AFTDSVIRTLDEV                     <<06756>>63975000
         ELSE IF INFODESC(I+5) = 61 THEN   <<just virt. class>><<*8760>>63980000
            BEGIN   << get device class of remote node >>      <<*8760>>63985000
            @REMOTE'STRING := (@AQ0 + QINFOPTR)*2;             <<*8760>>63990000
            TOS := RFALINE;  TOS := @REMOTE'STRING;            <<*8760>>63995000
            CALL'GETDS'NODENAME;<<GETDS'NODENAME(RFALINE,REM)>><<*8760>>64000000
            REMOTE'STRING(8) := " ";                           <<*8760>>64005000
            MOVE REMOTE'STRING(9) := REMOTE'STRING(8),         <<*8760>>64010000
                                      (MAX'REMOTE'LEN - 9);    <<*8760>>64015000
            END                                                <<*8760>>64020000
         ELSE IF INFODESC(I+5) = 6 THEN                        <<06756>>64025000
            BEGIN                                              <<*7845>>64030000
            IF AQ0(QINFOPTR) > 255 OR AFTDSVIRTLDEV > 255      <<06756>>64035000
               THEN AQ0(QINFOPTR) := 0  ! No dice, done fit.   <<06756>>64040000
               ELSE AQ0(QINFOPTR).(0:8) := AFTDSVIRTLDEV;      <<06756>>64045000
            END                                                <<*7845>>64050000
         ELSE IF INFODESC(I+5) = 50 AND REMOTE'VERSION <       <<*8783>>64055000
                               MPEV5'FVERSION THEN             <<*8783>>64060000
            AQ0(QINFOPTR) := AQ0(QINFOPTR).(8:8);              <<*7845>>64065000
            << Unpack return from MPE4 >>                      <<*7845>>64070000
         END;                  ! Stepping through tables.      <<06756>>64075000
      GO COPY'DATA;      << Copy data to user's buffer, exit>> <<01864>>64080000
      END;               << of FFILEINFO to remote file.    >> <<01864>>64085000
                                                                        64090000
   <<******************************>>                                   64095000
   <<  Ad Hoc information          >>                                   64100000
   <<******************************>>                                   64105000
                                                                        64110000
   COMMENT:                                                             64115000
      To expedite first implementation, FGETINFO parameters             64120000
      are handled by calling FGETINFO for each.  This is                64125000
      grossly inefficient.  A second-pass implementation                64130000
      should copy relevant portions of FGETINFO into here.              64135000
      Ideally, body of FGETINFO should be replaced by calls             64140000
      to FFILEINFO to avoid code duplication.                           64145000
      ;                                                                 64150000
                                                                        64155000
   IF NOT ACCESSTABLE(ADHOCTABLE) THEN GOTO END'ADHOC;                  64160000
   FINDINFO(ADHOCTABLE);                                                64165000
LOOP'ADHOC:                                                             64170000
   CASE TABLEITEM OF                                                    64175000
      BEGIN                                                             64180000
      <<00>> BEGIN  << file name >>                            <<01115>>64185000
             FGETINFO(FILENUM,AQ0(QINFOPTR)); FGIERR;          <<01115>>64190000
             END;                                                       64195000
                                                                        64200000
      <<01>> BEGIN  << record size >>                          <<01115>>64205000
             FGETINFO(FILENUM,,,,AQ0(QINFOPTR)); FGIERR;       <<01115>>64210000
             END;                                              <<01115>>64215000
                                                                        64220000
      <<02>> BEGIN  << device type >>                          <<01115>>64225000
             FGETINFO(FILENUM,,,,,AQ0(QINFOPTR)); FGIERR;      <<01115>>64230000
             END;                                              <<01115>>64235000
                                                                        64240000
      <<03>> BEGIN  <<HDADDR>>                                 <<01115>>64245000
             FGETINFO(FILENUM,,,,,,,AQ0(QINFOPTR));            <<03052>>64250000
             IF <> THEN GO TO NFG;                             <<03092>>64255000
             END;                                              <<01115>>64260000
                                                                        64265000
      <<04>> BEGIN  << disc status >>                          <<01115>>64270000
             IF NOT NULLFILE AND                               <<01115>>64275000
                (LDT'DEVTYPE=0 OR LDT'DEVTYPE=2)               <<01115>>64280000
               THEN TOS := REQSTATUS(LDEV)                     <<01115>>64285000
               ELSE TOS := 0D;                                 <<01115>>64290000
             STD'QINFOPTR;                                     <<01115>>64295000
             END;                                              <<01115>>64300000
                                                                        64305000
                                                                        64310000
      <<05>> BEGIN  << Logical block size >>                            64315000
             FGETINFO(FILENUM,,,,,,,,,,,,,,AQ0(QINFOPTR)); FGIERR;      64320000
             END;                                                       64325000
                                                                        64330000
      <<06>> BEGIN   << file limit >>                          <<01115>>64335000
             FGETINFO(FILENUM,,,,, ,,,,, , AQ0(QINFOPTR));FGIERR;<<FDF>>64340000
             END;                                              <<01115>>64345000
      <<07>> AQ0(QINFOPTR):=LDT'DEVTYPE;                       <<01115>>64350000
      <<08>> AQ0(QINFOPTR):=LDEV'SUBTYPE;                      <<07284>>64355000
      <<09>> BEGIN                                                      64360000
             IF SPOOLED                                        <<04611>>64365000
               THEN BEGIN                                      <<04611>>64370000
                 ALLOCFLAB;                                    <<04611>>64375000
                 FREADLABEL(FILENUM,ULABEL,128,0);             <<04611>>64380000
                 IF <> THEN                                    <<04611>>64385000
                    BEGIN       << Error. >>                   <<04611>>64390000
                    ASMB(SUBS 128);   << deallocate buffer >>  <<04611>>64395000
                    TOS := LBLIOERR;                           <<04611>>64400000
                    GO NFG;                                    <<04611>>64405000
                    END;                                       <<04611>>64410000
                 MOVE AQ0(QINFOPTR) := SPULAB'LAST'ENV,(18);   <<04611>>64415000
                 ASMB(SUBS 128);    << deallocate buffer >>    <<04611>>64420000
                 END                                           <<04611>>64425000
               ELSE MOVE AQ0(QINFOPTR) := "                  ";<<04611>>64430000
             END;                                                       64435000
      <<10>> BEGIN             << Tape file density >>         <<02676>>64440000
                                                               <<02676>>64445000
             << If file does not reside on a variable   >>     <<02676>>64450000
             << density tape drive, then return a zero. >>     <<02676>>64455000
                                                               <<02676>>64460000
             IF NULLFILE OR LDT'DEVTYPE <> MTAPE OR            <<02676>>64465000
               (NOT'VARIABLE'DENSITY) THEN                     <<07284>>64470000
                ZEROITEM                                       <<02676>>64475000
             ELSE                                              <<02676>>64480000
                BEGIN   << Variable density drive. >>          <<02676>>64485000
                                                               <<02676>>64490000
                << Get density word from LDT >>                <<02676>>64495000
                TOS := @LDT'DENW;                              <<02676>>64500000
                TOS := LDT;                                    <<02676>>64505000
                TOS := LDEV*LDTENTRY + DENSITYW;               <<02676>>64510000
                TOS := 1;                                      <<02676>>64515000
                ASSEMBLE( MFDS 4 );                            <<02676>>64520000
                                                               <<02676>>64525000
                << Return actual tape density unless at load >><<02676>>64530000
                << point and access is other than read only. >><<02676>>64535000
                IF LPDT'BOT AND ACB'ACTYPE <> 0 THEN           <<02676>>64540000
                   I := REQUEST'DENSITY                        <<07284>>64545000
                ELSE                                           <<02676>>64550000
                   I := TAPE'DENSITY;                          <<07284>>64555000
                                                               <<02676>>64560000
                << Return density as BPI >>                    <<02676>>64565000
                IF I <> DEN'DEFAULT THEN                       <<07284>>64570000
                   AQ0(QINFOPTR) := LDT'DEN'TO'REAL'DEN(I)     <<07284>>64575000
                ELSE IF LDEV'SUBTYPE = HP7974 THEN             <<07284>>64580000
                   AQ0(QINFOPTR) := 1600  << 7974 default   >> <<07284>>64585000
                ELSE                                           <<07284>>64590000
                   AQ0(QINFOPTR) := 6250; << 7976 or 7978   >> <<07284>>64595000
                END;   << of variable density drive >>         <<02676>>64600000
             END;   << of tape file density >>                 <<02676>>64605000
      <<11>> AQ0(QINFOPTR) := 0; ! Virtual ldev on non RFA.    <<07234>>64610000
      <<12>> BEGIN               ! Terminal type.              <<07234>>64615000
             IF ACB'DTYPE <> TERMINAL THEN                     <<07234>>64620000
                AQ0(QINFOPTR) := 0                             <<07234>>64625000
             ELSE                                              <<07234>>64630000
                BEGIN            ! Its some type of terminal.  <<07234>>64635000
                TERM'TYPE := GET'DSDEVICE(ACB'DADDR);          <<07234>>64640000
                IF TERM'TYPE <> 0 AND TERM'TYPE <> -2 THEN     <<07234>>64645000
                   AQ0(QINFOPTR) := DSDEVICE'MAP(TERM'TYPE)    <<07234>>64650000
                ELSE                                           <<07234>>64655000
                   BEGIN         ! Not a DS device.            <<07234>>64660000
                   IF LPDT'SUBTYPE = MODEM'SUBTYPE THEN        <<07234>>64665000
                      AQ0(QINFOPTR) := 2                       <<07234>>64670000
                   ELSE IF LPDT'SUBTYPE = NORMAL'SUBTYPE THEN  <<07234>>64675000
                      AQ0(QINFOPTR) := 1                       <<07234>>64680000
                   ELSE                                        <<07234>>64685000
                      AQ0(QINFOPTR):=0;! Unknown term subtype. <<07234>>64690000
                   END;                                        <<07234>>64695000
                END;                                           <<07234>>64700000
             END;                                              <<07234>>64705000
      <<13>> BEGIN               ! Remote name (none here)     <<*8760>>64710000
            << terminating condition for recursive  >>         <<*8760>>64715000
            << getnodename calls across dsline, since >>       <<*8760>>64720000
            << this is the home node of the file, no  >>       <<*8760>>64725000
            << remote name is returned >>                      <<*8760>>64730000
             AQ0(QINFOPTR) := "  ";  << no remote node >>      <<*8760>>64735000
             MOVE AQ0(QINFOPTR+1) := AQ0(QINFOPTR),            <<*8760>>64740000
                                    ((MAX'REMOTE'LEN-1)/2);    <<*8760>>64745000
             END;                                              <<*8760>>64750000
      END;                                                              64755000
   IF FINDINFO(ADHOCTABLE) THEN GOTO LOOP'ADHOC;                        64760000
END'ADHOC:                                                              64765000
                                                                        64770000
                                                                        64775000
   <<******************************>>                                   64780000
   <<  ACB information             >>                                   64785000
   <<******************************>>                                   64790000
                                                                        64795000
   IF NOT ACCESSTABLE(ACBTABLE) THEN GOTO END'ACB;                      64800000
   IF NULLFILE THEN                                                     64805000
      BEGIN      << $NULL >>                                            64810000
      WHILE FINDINFO(ACBTABLE) DO                              <<00899>>64815000
         BEGIN                                                 <<00899>>64820000
         IF TABLEITEM = ACBFOPITEM THEN                        <<00899>>64825000
            AQ0(QINFOPTR) := NULLFOP                           <<00899>>64830000
         ELSE IF TABLEITEM = ACBAOPITEM THEN                   <<00899>>64835000
            AQ0(QINFOPTR) := NULLAOP                           <<00899>>64840000
         ELSE ZEROITEM;                                        <<00899>>64845000
         END;      << WHILE-DO on FINDINFO >>                  <<00899>>64850000
      GOTO END'ACB;                                                     64855000
      END;       << $NULL >>                                            64860000
   FINDINFO(ACBTABLE);                                                  64865000
LOOP'ACB:                                                               64870000
   CASE TABLEITEM OF                                                    64875000
      BEGIN                                                             64880000
      <<00>> AQ0(QINFOPTR) := IF SPOOLED THEN ACB'SPFOPT       <<06511>>64885000
                              ELSE ACB'FOPTIONS;                        64890000
                                                                        64895000
      <<01>> AQ0(QINFOPTR) := IF SPOOLED THEN ACB'SPAOPT       <<06511>>64900000
                 LAND %177357 ELSE ACB'AOPTIONS;                        64905000
                                                                        64910000
      <<02>> BEGIN   << logical device nr. >>                           64915000
             AQ0(QINFOPTR) := LDEV;                            <<04161>>64920000
             END;                                                       64925000
                                                                        64930000
      <<03>> BEGIN   << record pointer >>                               64935000
             TOS := ACB'FPTR;                                           64940000
             STD'QINFOPTR;                                              64945000
             END;                                                       64950000
                                                                        64955000
      <<04>> BEGIN   << record [logical] transfer count >>              64960000
             TOS := ACB'RTFRCT;                                <<06511>>64965000
             STD'QINFOPTR;                                              64970000
             END;                                                       64975000
                                                                        64980000
      <<05>> BEGIN   << block [physical] transfer count >>              64985000
             TOS := IF SPOOLED THEN ACB'RTFRCT ELSE ACB'BTFRCT;<<06511>>64990000
             STD'QINFOPTR;                                              64995000
             END;                                                       65000000
                                                                        65005000
      <<06>> AQ0(QINFOPTR) := ACB'BLKFACT;                              65010000
      <<07>> AQ0(QINFOPTR) := ACB'BSIZE;  << phys blk size >>  <<06511>>65015000
                                                                        65020000
      <<08>> BEGIN   << data block size >>                              65025000
             AQ0(QINFOPTR) := (ACB'RSIZE+1)/2 * ACB'BLKFACT;   <<06511>>65030000
             END;                                                       65035000
                                                                        65040000
      <<09>> AQ0(QINFOPTR) := 0;  << offset to blk data >>              65045000
                                                                        65050000
      <<10>> BEGIN    << RIO "ART" offset >>                            65055000
             AQ0(QINFOPTR) := IF NOT ACB'RIO THEN 0            <<06511>>65060000
                              ELSE (ACB'RSIZE+1)/2*ACB'BLKFACT;<<06511>>65065000
             END;                                                       65070000
                                                                        65075000
      <<11>> BEGIN    << RIO "ART" size >>                              65080000
             AQ0(QINFOPTR) := IF NOT ACB'RIO THEN 0            <<06511>>65085000
                              ELSE (ACB'BLKFACT+15)/16;        <<06511>>65090000
             END;                                                       65095000
                                                                        65100000
      <<12>> BEGIN   << Spooled devicefileID >>                <<00483>>65105000
                     << Always return zero if not spooled >>            65110000
             AQ0(QINFOPTR) := IF SPOOLED THEN LOGICAL(         <<00483>>65115000
               XDDSPOOLINFO(0D, %4000, XDDEP)) ELSE 0;         <<00483>>65120000
             END;                                              <<00483>>65125000
      <<13>> BEGIN   << Number of writers >>                   <<HM.00>>65130000
             AQ0(QINFOPTR):=(ACB'SHCNT-ACB'SHCNTIN);           <<06511>>65135000
             END;                                              <<HM.00>>65140000
                                                               <<HM.00>>65145000
      <<14>> BEGIN   << Number of readers >>                   <<HM.00>>65150000
             AQ0(QINFOPTR):=ACB'SHCNTIN;                       <<06511>>65155000
             END;                                              <<HM.00>>65160000
      <<15>> BEGIN   << DRT >>                                 <<03052>>65165000
             AQ0(QINFOPTR) := IF SPOOLED THEN 0 ELSE           <<03052>>65170000
             LDEVTODRT(ACB'DADDR).(7:9);                       <<03052>>65175000
             END;                                              <<03052>>65180000
      <<16>> BEGIN   << UNIT >>                                <<03052>>65185000
             AQ0(QINFOPTR) := IF SPOOLED THEN 0 ELSE           <<03052>>65190000
             LDEVTODRT(ACB'DADDR)&LSR(9);                      <<03052>>65195000
             END;                                              <<03052>>65200000
      <<17>> BEGIN  << SOFTWARE INTERRUPT PLABEL >>            <<03657>>65205000
             IF NOT ACB'MSGFILE THEN                           <<06511>>65210000
                AQ0(QINFOPTR):=0                               <<03038>>65215000
             ELSE                                              <<03038>>65220000
                FCGETINFO(ACBMQ,0,AQ0(QINFOPTR));              <<03038>>65225000
             END;                                              <<03038>>65230000
      END;                                                     <<03038>>65235000
   IF FINDINFO(ACBTABLE) THEN GOTO LOOP'ACB;                            65240000
END'ACB:                                                                65245000
                                                                        65250000
                                                                        65255000
   <<******************************>>                                   65260000
   <<  FCB information             >>                                   65265000
   <<******************************>>                                   65270000
                                                                        65275000
   IF NOT ACCESSTABLE(FCBTABLE) THEN GOTO END'FCB;                      65280000
   IF NOFCB THEN                                                        65285000
      BEGIN       << Return zero for all FCB items. >>                  65290000
      WHILE FINDINFO(FCBTABLE) DO                              <<00899>>65295000
         BEGIN                                                 <<00899>>65300000
         ZEROITEM;                                             <<00899>>65305000
         END;                                                  <<00899>>65310000
      GOTO END'FCB;                                                     65315000
      END;                                                              65320000
   ALLOC'D'FCB;                                                <<06511>>65325000
   LOCK'CB(0,0,@FCB-@Q0,ACB'FCB);                              <<06511>>65330000
   TOS := SIZEBFCB;                                                     65335000
   MOVE'DS'1;         << Copy FCB to stack >>                           65340000
   TOS := (FCBNUMEXTS+1)&LSL(1);                               <<01672>>65345000
   MOVE'DS'6;         << Get E-map too >>                               65350000
   FINDINFO(FCBTABLE);                                                  65355000
LOOP'FCB:                                                               65360000
   CASE TABLEITEM OF                                                    65365000
      BEGIN                                                             65370000
      <<00>> BEGIN                                                      65375000
             TOS := FCBEOF;                                             65380000
             STD'QINFOPTR;                                              65385000
             END;                                                       65390000
                                                                        65395000
      <<01>> BEGIN     << Last extent used >>                           65400000
             TOS := FCBNUMEXTS;   << extent index >>           <<02675>>65405000
             TOS := @FCBEXTMAP+FCBNUMEXTS&LSL(1);  << e-map ptr >>      65410000
             WHILE DPS0 = 0D DO                                <<02675>>65415000
                BEGIN     << Look for existing extent. >>               65420000
                S0 := S0-2;     << Decr XMAP pointer >>                 65425000
                S1 := S1-1;     << decr index >>                        65430000
                END;                                                    65435000
             DEL;          << discard pointer >>                        65440000
             AQ0(QINFOPTR) := TOS+1;                           <<02675>>65445000
             END;                                              <<*****>>65450000
                                                                        65455000
      <<02>> AQ0(QINFOPTR) := FCBEXTSIZE;                               65460000
      <<03>> AQ0(QINFOPTR) := FCBNUMEXTS+1;                             65465000
      <<04>> AQ0(QINFOPTR) := FCBLBL;  << user labels >>                65470000
                                                                        65475000
      <<05>> BEGIN                                                      65480000
             TOS := FLABADDR := FCBLABEL;                               65485000
             STD'QINFOPTR;                                              65490000
             END;                                                       65495000
      <<06>> BEGIN     << First nonzero extent (spoofle) >>    <<*****>>65500000
             TOS := 0;   << extent index >>                             65505000
             TOS := @FCBEXTMAP;   << extent map pointer >>              65510000
             IF FCBNUMEXTS >= 2 THEN                           <<01624>>65515000
                DO BEGIN     << Look for existing extent. >>            65520000
                S0 := S0+2;     << Bump XMAP pointer >>                 65525000
                S1 := S1+1;     << bump index >>                        65530000
                END UNTIL DPS0 <> 0D;                                   65535000
             DEL;          << discard pointer >>                        65540000
             IF S0 = 1 THEN S0 := 0;   << All exts present >>           65545000
             AQ0(QINFOPTR) := TOS;                                      65550000
             END;                                              <<*****>>65555000
      <<07>> BEGIN     ! Number of blocks, variable file.      <<07234>>65560000
             IF NOT ACB'VARIABLE THEN                          <<07234>>65565000
                TOS := 0D             ! Not a variable file.   <<07234>>65570000
             ELSE                                              <<07234>>65575000
                BEGIN  ! It is a variable length file.         <<07234>>65580000
                IF SPOOLED THEN                                <<07234>>65585000
                   TOS := ACB'BTFRCT  ! For spool files.       <<07234>>65590000
                ELSE IF FCBEOF = 0D THEN                       <<07234>>65595000
                   TOS := 0D          ! No data blocks.        <<07234>>65600000
                ELSE                                           <<07234>>65605000
                   TOS := FCBEND-FCBSTART+1D;                  <<07234>>65610000
                END;                                           <<07234>>65615000
             STD'QINFOPTR;                                     <<07234>>65620000
             END;                                              <<07234>>65625000
      <<08>> AQ0(QINFOPTR) := FCBLBLEOF;                       <<07234>>65630000
      <<09>> AQ0(QINFOPTR) := FCBOCNTOUT;                      <<07234>>65635000
      <<10>> AQ0(QINFOPTR) := FCBOCNTIN;                       <<07234>>65640000
      END;                                                              65645000
   IF FINDINFO(FCBTABLE) THEN GOTO LOOP'FCB;                            65650000
   UNLOCK'CB(0,ACB'FCB);                                       <<06511>>65655000
   ASMB(SUBS SIZEDFCB);                                                 65660000
END'FCB:                                                                65665000
                                                                        65670000
   <<******************************>>                                   65675000
   <<  File label information      >>                                   65680000
   <<******************************>>                                   65685000
                                                                        65690000
   IF NOT ACCESSTABLE(FLABTABLE) THEN GOTO END'FLAB;                    65695000
   ALLOCFLAB;                                                           65700000
   IF NOFCB THEN                                                        65705000
      BEGIN     << Zero file label. >>                                  65710000
      FLAB := 0;                                                        65715000
      MOVE FLAB(1) := FLAB,(127);                                       65720000
      GO FIRST'FLAB;                                                    65725000
      END;                                                              65730000
                                                                        65735000
   IF FLABADDR = 0D THEN                                                65740000
      FLABADDR := GETFCB'INFO (ACB'FCB, SIZEBFCB);             <<01624>>65745000
   SECTOR := FLABADDR;                                                  65750000
   ISECTOR.(0:8) := 0;    << clear LDEV >>                              65755000
   TOS := FISIR;          << for "RELSIR">>                             65760000
   TOS := GETSIR(FISIR);                                                65765000
   X := FLABIO(LDEV,SECTOR,0,FLAB);                                     65770000
   RELSIR(*,*);                                                         65775000
   IF X <> 0 THEN                                                       65780000
      BEGIN                                                             65785000
      FLABIOERR(X,FILENUM);  << flag directory >>                       65790000
      DEALLOCFLAB;                                                      65795000
      TOS := LBLIOERR;                                                  65800000
      GOTO NFG;                                                         65805000
      END;                                                              65810000
FIRST'FLAB:                                                             65815000
   FINDINFO(FLABTABLE);                                                 65820000
LOOP'FLAB:                                                              65825000
   CASE TABLEITEM OF                                                    65830000
      BEGIN                                                             65835000
      <<00>> BEGIN     << Creator ID >>                                 65840000
             IF NOFCB THEN MOVE AQ0(QINFOPTR) := "        "             65845000
             ELSE MOVE AQ0(QINFOPTR) := FLUSERID,(4);                   65850000
             END;                                                       65855000
                                                                        65860000
      <<01>> AQ0(QINFOPTR) := FLALLOCDATE;                              65865000
                                                                        65870000
      <<02>> BEGIN                                                      65875000
             TOS := FLALLOCTIME;                                        65880000
             STD'QINFOPTR;                                              65885000
             END;                                                       65890000
      <<03>> AQ0(QINFOPTR) := FLFILECODE;  << file code >>     <<00483>>65895000
      <<04>> BEGIN          ! Last modify time.                <<07234>>65900000
             TOS := FLMODTIME;                                 <<07234>>65905000
             STD'QINFOPTR;                                     <<07234>>65910000
             END;                                              <<07234>>65915000
      <<05>> AQ0(QINFOPTR) := FLLASTMOD;                       <<07234>>65920000
      <<06>> AQ0(QINFOPTR) := FLCREATE;                        <<07234>>65925000
      <<07>> AQ0(QINFOPTR) := FLLASTACC;                       <<07234>>65930000
      END;                                                              65935000
   IF FINDINFO(FLABTABLE) THEN GOTO LOOP'FLAB;                          65940000
   DEALLOCFLAB;                                                         65945000
END'FLAB:                                                               65950000
                                                                        65955000
   <<********************************>>                        <<00828>>65960000
   <<  Tape label table information  >>                        <<00828>>65965000
   <<********************************>>                        <<00828>>65970000
                                                               <<00828>>65975000
   IF NOT ACCESSTABLE(TAPETABLE) OR NULLFILE THEN GO ENDTAPE;  <<06045>>65980000
   FINDINFO(TAPETABLE);                                        <<00828>>65985000
LOOPTAPE:                                                      <<00828>>65990000
   TGETINFO(LDEV,AQ0(QINFOPTR),TABLEITEM);    << DB at stack >><<02545>>65995000
   IF FINDINFO(TAPETABLE) THEN GOTO LOOPTAPE;                  <<00828>>66000000
ENDTAPE:                                                       <<00828>>66005000
                                                                        66010000
   <<******************************>>                                   66015000
<< Now copy the accumulated data to the user's buffers. >>              66020000
   <<******************************>>                                   66025000
                                                                        66030000
COPY'DATA:                                                     <<01864>>66035000
   FOR I := 0 STEP INFOSIZE UNTIL INFOLIMIT-1 DO                        66040000
      BEGIN                                                             66045000
      QINFOPTR := INFODESC(I+2);                                        66050000
      TOS := INFODESC(X:=X+1);                                          66055000
      TOS := @AQ0(QINFOPTR)&LSL(1);                                     66060000
      MOVE * := *,(INFODESC(I+4));                                      66065000
      END;                                                              66070000
   TOS := 0;     << no error >>                                         66075000
   TOS := CCE;                                                          66080000
                                                                        66085000
EXIT:                                                                   66090000
   COMMENT:                                                             66095000
      S-1 = Filesys error number                                        66100000
      S-0 = condition code                                              66105000
      DB  = at stack.  We must not have anything locked.                66110000
      ;                                                                 66115000
   IF NOT NULLFILE AND                                         <<02068>>66120000
     (FTYPE = FS'TYPE OR FTYPE = MSG'TYPE) THEN                <<02068>>66125000
      BEGIN   << Log any FSERR and unlock ACB.              >> <<01624>>66130000
      ACB'ERROR := S1;                                         <<01624>>66135000
      UNLOC'ACB(ACBMQ,0);                                      <<01672>>66140000
      END;                                                     <<01624>>66145000
EXIT2:                                                                  66150000
   CONDCODE := TOS;                                                     66155000
E2:RESETCRITICAL(CRIT);                                        <<04876>>66160000
   ERROREXIT(CALLSEQSIZE,S0,0);                                         66165000
   END;  << procedure FFILEINFO >>                                      66170000
$PAGE " FREADLABEL - FWRITELABEL "                                      66175000
$CONTROL SEGMENT = FILESYS3   << FREADLABEL/FWRITELABEL >>              66180000
PROCEDURE FREADLABEL(FN,TARGET,TCOUNT,LBL);<<and FWRITELABEL>>          66185000
VALUE FN,TCOUNT,LBL;                                                    66190000
INTEGER FN,TCOUNT,LBL;                                                  66195000
ARRAY TARGET;                                                           66200000
OPTION PRIVILEGED,VARIABLE;                                             66205000
   BEGIN                                                                66210000
   ENTRY FWRITELABEL;                                                   66215000
   EQUATE UBND =  -9; <<Q rel upper bound for bound check>>    <<03059>>66220000
   LOGICAL PMAP = Q-4;    << Param. bit map >>                          66225000
   LOGICAL CODE;          << Read (0) or Write (1)>>                    66230000
   DEFINE READ = NOT CODE#,                                             66235000
          WRITE = CODE#;                                                66240000
   INTEGER CRIT;          << for SETCRITICAL >>                         66245000
   INTEGER ACCTYPE;       << access class >>                            66250000
   INTEGER DTYPE;         << device type >>                    <<01115>>66255000
   DOUBLE STKADR,FCBADR;                                                66260000
   INTEGER LDEV;           << User label LDEV >>                        66265000
   DOUBLE DISKADR;         << User label sector nr. >>                  66270000
   INTEGER P1 = DISKADR;   << sector nr. - first half >>                66275000
   INTEGER P2 = DISKADR+1;  << sector nr. - second half >>              66280000
   INTEGER ATTIOFLAGS;                                         <<06961>>66285000
   DEFINE ATTIOFLAG'SERIAL = ATTIOFLAGS.(5:1)#;                <<06961>>66290000
                                                                        66295000
   << Remote file access (RFA) variables: >>                            66300000
                                                                        66305000
   INTEGER POINTER RFAPTR;   << appendage pointer >>           <<DS.00>>66310000
   INTEGER RFALEN;           << appendage length >>            <<DS.00>>66315000
                                                                        66320000
<< Following LOC'ACB params must be in order: >>                        66325000
   INTEGER ACBMQ;                                              <<06511>>66330000
   INTEGER AFTE;                                                        66335000
   DOUBLE  PACBV;                                              <<06511>>66340000
   DOUBLE  LACBV;                                              <<06511>>66345000
   INTEGER IOQX;                                                        66350000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<06511>>66355000
BUILD'ACB;                                                     <<06511>>66360000
                                                                        66365000
   INTEGER DSTX;       << user's buffer DST >>                          66370000
   << End of LOC'ACB params >>                                          66375000
                                                                        66380000
   INTEGER FCBMQ;                                              <<06511>>66385000
   INTEGER ARRAY FCB(0:SIZEBFCB-1) = Q;   << Q+FCBMQ >>        <<06511>>66390000
   DOUBLE DFCB = FCB;                                                   66395000
                                                                        66400000
                                                                        66405000
<< **  FREAD/WRITELABEL: Begin execution  ** >>                         66410000
                                                                        66415000
   TOS := 0;     << Read label >>                                       66420000
   GO CONT;                                                             66425000
   HELP;  << dummy call >>                                     <<00117>>66430000
                                                                        66435000
FWRITELABEL:                                                            66440000
   TOS := 1;     << Write label >>                                      66445000
                                                                        66450000
CONT:                                                                   66455000
   CODE := TOS;     << Read/Write code >>                               66460000
                                                                        66465000
$  IF X0 = ON                                                           66470000
   IF MONCALLABLE THEN                                                  66475000
      BEGIN                                                             66480000
      FTITLE("FR/W","LABE","L   ",0D);                                  66485000
      DEBUG                                                             66490000
      END;                                                              66495000
$  IF                                                                   66500000
                                                                        66505000
   ERRORON;                                                             66510000
   CRIT := SETCRITICAL;                                                 66515000
   IF PMAP < %14 THEN                                                   66520000
      BEGIN   << File number or buffer address missing. Boo! >>         66525000
      TOS := ACCVIOL;                                                   66530000
      TOS := CCL;                                                       66535000
      GO EXIT                                                           66540000
      END;                                                              66545000
   IF PMAP.(14:1) THEN      << TCOUNT specified? >>            <<DS.00>>66550000
      BEGIN                                                             66555000
      TOS := TCOUNT;                                           <<DS.00>>66560000
      IF < THEN TOS := -(TOS&ASR(1));                          <<DS.00>>66565000
      TCOUNT := TOS;      << +words >>                         <<DS.00>>66570000
      END ELSE TCOUNT := 128;                                  <<DS.00>>66575000
   GET'ACB'Q'LOC;                                              <<06511>>66580000
   LOC'ACB(0,ACBMQ,FN,UMODE);                                  <<06511>>66585000
   DSTX := TOS;                                                         66590000
   IF < THEN                                                            66595000
      BEGIN     << Invalid file number >>                               66600000
      TOS := INVFN;                                                     66605000
      TOS := CCL;                                                       66610000
      GO EXIT                                                           66615000
      END;                                                              66620000
   IF > THEN                                                            66625000
      BEGIN     << File is $NULL >>                                     66630000
      TOS := 0;   << No error >>                                        66635000
      TOS := IF WRITE THEN CCE ELSE CCG;                                66640000
      GO EXIT                                                           66645000
      END;                                                              66650000
   CASE * FTYPE OF                                                      66655000
   BEGIN                                                                66660000
                                                                        66665000
   BEGIN       << conventional file >>                                  66670000
CONVENTIONAL:                                                  <<HM.00>>66675000
   IF IOQX <> 0 THEN                                                    66680000
      BEGIN        << NO-WAIT I/O pending. >>                           66685000
      TOS := IOPENDING;                                                 66690000
      GO ERREX                                                          66695000
      END;                                                              66700000
   IF FBNDVIOL(@TARGET,TCOUNT,UBND) OR TCOUNT > 128 THEN       <<03059>>66705000
      BEGIN      << Bounds violation >>                                 66710000
      TOS := BNDVIOL;                                          <<DS.00>>66715000
      GO ERREX;                                                         66720000
      END;                                                     <<DS.00>>66725000
   ACCTYPE := ACB'ACCCL;     << access class >>                         66730000
   DTYPE := ACB'DTYPE;       << device type >>                 <<01115>>66735000
   IF NOT PMAP THEN LBL := 0;     << default label nr. >>               66740000
   IF ACCTYPE = DIRACC THEN                                             66745000
      BEGIN       << Disk. >>                                           66750000
      IF ACB'FCB=0D THEN GO ILDEV;    << Foreign disk loses. >><<06511>>66755000
      GET'FCB'Q'LOC;                                           <<06511>>66760000
      LOCK'CB(0,0,FCBMQ,ACB'FCB);                              <<06511>>66765000
      FCBADR := DS1;                                                    66770000
      STKADR := DS3;                                                    66775000
      TOS := SIZEBFCB;                                                  66780000
      MOVE'DS'6;        << get local copy of FCB >>                     66785000
      X := FCB.(2:14);                                                  66790000
      IF BADFCBSIZE THEN FTROUBLE(63);                                  66795000
      TOS := IF WRITE THEN FCBLBL ELSE FCBLBLEOF;  << limit >>          66800000
      IF LOGICAL(TOS) <= LOGICAL(LBL) THEN                              66805000
         BEGIN       << Beyond limit. >>                                66810000
         TOS := EOF;     << Error = EOF >>                              66815000
         TOS := CCG;    << flag EOF >>                                  66820000
         GO RELFCB                                                      66825000
         END;                                                           66830000
      IF WRITE AND (LBL+1) > FCBLBLEOF THEN FCBLBLEOF := LBL+1;         66835000
      TOS := FCBADR;                                                    66840000
      TOS := TOS+16;    << offset of FCBUSERLABEL >>                    66845000
      TOS := STKADR;                                                    66850000
      TOS := TOS+16;                                                    66855000
      TOS := 1;                                                         66860000
      MOVE'DS'5;        << update FCBLBLEOF >>                          66865000
      TOS := 0;         << for LDEV >>                                  66870000
      TOS := DOUBLE(LOGICAL(LBL+1));  << label sector offset >>         66875000
      TOS := FCBEXTSIZE;      << Extent size in sectors >>              66880000
      ASMB(LDIV,STBX; ZROB);                                            66885000
      TOS := STKADR;                                                    66890000
      TOS := FCBADR;                                                    66895000
      TOS := TOS+SIZEBFCB+X+X;                                          66900000
      TOS := 2;                                                         66905000
      MOVE'DS'5;         << fetch E-map entry >>                        66910000
      TOS := TOS+DFCB;   << add it to label index >>                    66915000
      TOS := TOS&TASL(8)&DLSR(8);    << separate LDEV >>                66920000
      DISKADR := TOS;       << user label sector nr. >>                 66925000
      LDEV := TOS;         << user label LDEV >>                        66930000
         ATTIOFLAGS := BFLAGS;                                 <<07235>>66935000
         ATTIOFLAG'SERIAL := ACB'SERIALIO;                     <<07235>>66940000
      TOS := ATTACHIO(LDEV,0,DSTX,@TARGET,CODE,TCOUNT,                  66945000
         P1,P2,ATTIOFLAGS);<< read or write user label >>      <<07235>>66950000
      DEL;                                                              66955000
      IF TOS.(8:8) <> 1 THEN                                            66960000
         BEGIN       << ATTACHIO reports error. >>                      66965000
         TOS := INVOP;                                                  66970000
         TOS := CCL;                                                    66975000
         GO RELFCB                                                      66980000
         END;                                                           66985000
                                                                        66990000
      <<* * * Measurement data on Disk FREAD/WRITELABEL * * *>>         66995000
                                                                        67000000
$  IF X3 = ON                                                           67005000
      IF MEAS'TAPE'ON THEN BEGIN                                        67010000
      MMSTAT'(IF READ THEN EFREADLABEL ELSE EFWRITELABEL,      <<06958>>67015000
         FN,TCOUNT,0,0,0,0);     << record measurement >>      <<06958>>67020000
      END; << OF MEAS'TAPE'ON>>                                         67025000
$  IF                                                                   67030000
                                                                        67035000
      TOS := 0;    << No error >>                                       67040000
      TOS := CCE;  << OK condition code >>                              67045000
RELFCB:                                                                 67050000
      UNLOCK'CB(0,ACB'FCB);                                    <<06511>>67055000
      END      << disk >>                                               67060000
                                                                        67065000
   ELSE IF LABEL'DEVICE THEN                                   <<03582>>67070000
      BEGIN         << Labeled tape >>                                  67075000
      IF NOT PMAP.(14:1) THEN TCOUNT := 40;                    <<02545>>67080000
      IF TCOUNT <> 40 THEN                                              67085000
         BEGIN    << Wrong size for label. >>                           67090000
         TOS := BNDVIOL;                                                67095000
         GO ERREX;                                                      67100000
         END;                                                           67105000
      LDEV := ACB'DADDR;                                                67110000
      IF WRITE THEN                                            <<02545>>67115000
         BEGIN       << FWRITELABEL >>                         <<02545>>67120000
         IF ACB'ACTYPE = 0 THEN GO ACV;  << read-only. >>      <<06511>>67125000
         TOS := CHECKUL(FN,3,0);                               <<02545>>67130000
         IF < THEN GO ERREX;                                   <<02545>>67135000
         DEL;                                                  <<02545>>67140000
         ATTACHIO(LDEV,0,DSTX,@TARGET,1,                       <<02545>>67145000
            TCOUNT,0,4,BFLAGS);    << write label >>           <<02693>>67150000
         END                                                   <<02545>>67155000
      ELSE                                                     <<02545>>67160000
         BEGIN        << FREADLABEL >>                         <<02545>>67165000
         IF ACB'ACTYPE <> 0 THEN                               <<06511>>67170000
            BEGIN     << write-access - can't read. >>         <<02545>>67175000
ACV:        TOS := ACCVIOL;                                    <<02545>>67180000
            GO ERREX;                                          <<02545>>67185000
            END;                                               <<02545>>67190000
         IF LBL < 0 AND NOT PRIVMODE THEN                      <<02693>>67195000
            BEGIN   << Must have PRIV for hdr/trlr labels >>   <<02693>>67200000
            TOS := PRIVVIOL;                                   <<02693>>67205000
            GO ERREX;                                          <<02693>>67210000
            END;                                               <<02693>>67215000
         TOS := CHECKUL(FN,2,LBL);      << position >>         <<02693>>67220000
         IF < THEN GO ERREX;                                   <<02545>>67225000
         DEL;                                                  <<02545>>67230000
         TOS := ATTACHIO(LDEV,0,DSTX,@TARGET,0,                <<02545>>67235000
            TCOUNT,0,0,BFLAGS);    << read label >>            <<02545>>67240000
         DEL;                                                           67245000
         IF TOS.(8:8) = EOFSTAT THEN                                    67250000
            BEGIN         << EOF; BSR over it >>               <<02545>>67255000
            ATTACHIO(LDEV,0,0,0,12,0,0,0,BFLAGS);              <<02545>>67260000
            TOS := 0;      << No error >>                               67265000
            TOS := CCG;    << Report EOF >>                             67270000
            GO RELACB;                                                  67275000
            END;    << EOF >>                                           67280000
         END;                                                  <<02545>>67285000
      TOS := 0;     << No error >>                                      67290000
      TOS := CCE;  << OK condition code >>                              67295000
      END         << labeled tape >>                                    67300000
   ELSE                                                                 67305000
      BEGIN                                                             67310000
ILDEV:TOS := DEVVIOL;      << other devices lose. >>                    67315000
ERREX:                                                                  67320000
      TOS := CCL;                                                       67325000
      END;                                                              67330000
                                                                        67335000
RELACB:                                                                 67340000
   ACB'ERROR := S1;                                                     67345000
   UNLOC'ACB(ACBMQ,0);    << release ACB >>                    <<06511>>67350000
   END;      << conventional file >>                                    67355000
                                                                        67360000
   BEGIN   << Remote file >>                                            67365000
   IF FBNDVIOL(@TARGET,TCOUNT,UBND) OR TCOUNT > 128 THEN       <<03059>>67370000
      BEGIN                                                             67375000
      TOS := CCL;                                                       67380000
      GO EXIT                                                           67385000
      END;                                                              67390000
   DSTX := EXCHANGEDB(0);   << set DB to stack >>              <<DS.00>>67395000
   ALLOCRFABUF;                                                <<DS.00>>67400000
   RFALEN := 7;                                                <<DS.00>>67405000
   TOS := "RFA ";                                              <<DS.00>>67410000
   TOS := 8;    << assume FREADLABEL >>                        <<DS.00>>67415000
   IF WRITE THEN TOS := TOS+1;   << WRITELABEL >>              <<DS.00>>67420000
   TOS := RFAFILE;                                             <<DS.00>>67425000
   TOS := TCOUNT;                                              <<DS.00>>67430000
   IF = THEN                                                            67435000
      BEGIN                                                             67440000
      TOS := 0;     << no error >>                                      67445000
      TOS := CCE;                                                       67450000
      GO EXIT                                                           67455000
      END;                                                              67460000
   TOS := LBL;                                                 <<DS.00>>67465000
   TOS := PMAP;                                                <<DS.00>>67470000
   IF WRITE THEN                                               <<DS.00>>67475000
      BEGIN                                                    <<DS.00>>67480000
      RFALEN := RFALEN+TCOUNT;                                 <<DS.00>>67485000
      TOS := TCOUNT;  << copy label to stack >>                <<DS.00>>67490000
      ASMB(ADDS 0);                                            <<DS.00>>67495000
      IF DSTX = 0 THEN                                         <<DS.00>>67500000
         MOVE RFAPTR(7) := TARGET,(TCOUNT)                     <<DS.00>>67505000
      ELSE                                                     <<DS.00>>67510000
         BEGIN   << User buffer is in XDS. >>                  <<DS.00>>67515000
         TOS := @RFAPTR(7);                                    <<DS.00>>67520000
         TOS := DSTX;                                          <<DS.00>>67525000
         TOS := @TARGET;                                       <<DS.00>>67530000
         TOS := TCOUNT;                                        <<DS.00>>67535000
         ASMB(MFDS 4);                                         <<DS.00>>67540000
         END                                                   <<DS.00>>67545000
      END                                                      <<DS.00>>67550000
   ELSE                                                                 67555000
      BEGIN     << Read >>                                     <<DS.00>>67560000
      TOS := TCOUNT-RFALEN+1;                                  <<DS.00>>67565000
      ASMB(ADDS 0);   << Leave space for return label >>       <<DS.00>>67570000
      END;                                                     <<DS.00>>67575000
   MWCNOBUF;                                                   <<DS.00>>67580000
   CHECKXFER;                                                  <<DS.00>>67585000
   IF WRITE THEN                                               <<DS.00>>67590000
      BEGIN                                                    <<DS.00>>67595000
      DELAPPENDAGE;                                            <<DS.00>>67600000
      END                                                      <<DS.00>>67605000
   ELSE      << Read >>                                                 67610000
      BEGIN    << Move label to user >>                        <<DS.00>>67615000
      IF RFAPTR.CC = CCE THEN                                  <<DS.00>>67620000
      IF DSTX = 0 THEN                                         <<DS.00>>67625000
         MOVE TARGET := RFAPTR(1),(TCOUNT)                     <<DS.00>>67630000
      ELSE                                                     <<DS.00>>67635000
         BEGIN   << User buffer in XDS. >>                     <<DS.00>>67640000
         TOS := DSTX;                                          <<DS.00>>67645000
         TOS := @TARGET;                                       <<DS.00>>67650000
         TOS := @RFAPTR(1);                                    <<DS.00>>67655000
         TOS := TCOUNT;                                        <<DS.00>>67660000
         ASMB(MTDS 4);                                         <<DS.00>>67665000
         END;                                                  <<DS.00>>67670000
      TOS := TCOUNT;                                           <<DS.00>>67675000
      ASMB(SUBS 0);   << delete appendage >>                   <<DS.00>>67680000
      END;                                                     <<DS.00>>67685000
   IF DSTX <> 0 THEN                                           <<DS.00>>67690000
      DSTX := EXCHANGEDB(DSTX);                                <<DS.00>>67695000
   PREPRETURN;                                                 <<DS.00>>67700000
   END;    << remote file >>                                            67705000
                                                                        67710000
      << dummy 2 >>;                                                    67715000
      << dummy 3 >>;                                                    67720000
      << dummy 4 >>;                                                    67725000
      << dummy 5 >>;                                                    67730000
   BEGIN   << KSAM file >>                                              67735000
   IF FBNDVIOL(@TARGET,TCOUNT,UBND) OR TCOUNT > 128 THEN       <<03059>>67740000
      BEGIN   << Bounds violation >>                                    67745000
      FKSAMBNDVIOL(FN);                                        <<KS.00>>67750000
      TOS := BNDVIOL;                                          <<DS.00>>67755000
      TOS := CCL;                                              <<DS.00>>67760000
      GO EXIT;                                                 <<DS.00>>67765000
      END;                                                     <<DS.00>>67770000
   IF READ THEN                                                <<KS.00>>67775000
      KREADLABEL(FN,TARGET,TCOUNT,LBL)                         <<KS.00>>67780000
   ELSE                                                        <<KS.00>>67785000
      KWRITELABEL(FN,TARGET,TCOUNT,LBL);                       <<KS.00>>67790000
   PUSH(STATUS);                                               <<KS.00>>67795000
   TOS := TOS.CC;     << condition code to report >>           <<KS.00>>67800000
   ASMB(ZERO,XCH);                                             <<KS.00>>67805000
   END;    << KSAM file >>                                     <<KS.00>>67810000
   <<DUMMY 7>>;                                                <<HM.00>>67815000
   GO CONVENTIONAL;                                            <<HM.00>>67820000
   END; << FTYPE CASE >>                                       <<DS.00>>67825000
                                                                        67830000
EXIT:                                                                   67835000
   CONDCODE := TOS;                                                     67840000
   RESETCRITICAL(CRIT);                                                 67845000
   ERROREXIT(5,S0,0)                                                    67850000
   END;    << procedure FREAD/FWRITELABEL >>                            67855000
$PAGE " FLOCK, FUNLOCK "                                                67860000
$CONTROL SEGMENT = FILESYS3   << FLOCK >>                               67865000
PROCEDURE FLOCK(FILENUM,T);                                             67870000
VALUE FILENUM,T;                                                        67875000
INTEGER FILENUM;                                                        67880000
LOGICAL T;                                                              67885000
OPTION PRIVILEGED;                                                      67890000
   BEGIN                                                                67895000
   INTEGER CODE,ERROR'NUM := 0;                                <<04559>>67900000
   INTEGER CRIT;      << for SETCRITICAL >>                             67905000
   DOUBLE FCBWORDS;                                                     67910000
      INTEGER FCB'RIN = FCBWORDS;                                       67915000
                                                                        67920000
<< Remote file access (RFA) variables: >>                               67925000
                                                                        67930000
   INTEGER POINTER RFAPTR;  << appendage pointer >>            <<DS.00>>67935000
   INTEGER RFALEN;          << appendage length >>             <<DS.00>>67940000
                                                                        67945000
<< Following LOC'ACB params must be last and in order: >>               67950000
   INTEGER ACBMQ;      << Q-relative displacement of ACB >>    <<04559>>67955000
   INTEGER AFTE;                                                        67960000
   DOUBLE  PACBV;                                              <<06511>>67965000
   DOUBLE  LACBV;                                              <<06511>>67970000
   INTEGER IOQX;                                                        67975000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q+ACBMQ >>       <<04559>>67980000
BUILD'ACB;                                                     <<06511>>67985000
   INTEGER DSTX;       << user's buffer DST >>                          67990000
   << End of LOC'ACB params >>                                          67995000
                                                                        68000000
   ENTRY KSLOCK;   << for KSAM'S KCLOSE procedure >>           <<Y1.03>>68005000
   CODE := 0;                                                           68010000
   GO TO CONTINUE;                                             <<Y1.03>>68015000
                                                                        68020000
KSLOCK:            << KSAM entry point >>                      <<Y1.03>>68025000
   CODE := 1;                                                           68030000
CONTINUE:                                                      <<Y1.03>>68035000
                                                                        68040000
$  IF X0 = ON                                                           68045000
   IF MONCALLABLE THEN                                                  68050000
      BEGIN                                                             68055000
      FTITLE("FLOC","K   ",0D,0D);                                      68060000
      DEBUG                                                             68065000
      END;                                                              68070000
$  IF                                                                   68075000
                                                                        68080000
   ERRORON;                                                             68085000
   CRIT := SETCRITICAL;                                                 68090000
   GET'ACB'Q'LOC;                                              <<04559>>68095000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<01672>>68100000
   IF < THEN                                                            68105000
      BEGIN         << Invalid file nr. >>                              68110000
      TOS := INVFN;                                                     68115000
      TOS := CCL;                                                       68120000
      GO EXIT                                                           68125000
      END;                                                              68130000
   IF > THEN                                                            68135000
      BEGIN         << File is $NULL >>                                 68140000
      TOS := 0;     << no error >>                                      68145000
      TOS := CCE;                                                       68150000
      GO EXIT                                                           68155000
      END;                                                              68160000
   CASE * FTYPE OF                                                      68165000
   BEGIN                                                                68170000
                                                                        68175000
   BEGIN     << Conventional file >>                                    68180000
CONVENTIONAL:                                                  <<HM.00>>68185000
                                                               <<04559>>68190000
   IF ACB'ACCCL <> DIRACC THEN                                 <<04559>>68195000
      ERROR'NUM := ACCVIOL    << Must be a disc file.       >> <<04559>>68200000
   ELSE                                                        <<04559>>68205000
      BEGIN                                                    <<04559>>68210000
      FCBWORDS := GETFCB'INFO(ACB'FCB,7);  << Get RIN #     >> <<04559>>68215000
      IF FCB'RIN = 0 THEN                                      <<04559>>68220000
         ERROR'NUM := ACCVIOL << No RIN, not opened for lock>> <<04559>>68225000
      ELSE IF NOT MRCAPOK(TRUE,FCB'RIN) AND CODE = 0 THEN      <<04559>>68230000
         ERROR'NUM := MRIN;   << Program not prepped w/ MR  >> <<04559>>68235000
      END;                                                     <<04559>>68240000
                                                               <<04559>>68245000
   ACB'ERROR := ERROR'NUM;                                     <<06511>>68250000
   UNLOC'ACB(ACBMQ,0);        << Unlock before impeding.    >> <<04559>>68255000
                                                               <<04559>>68260000
   IF ERROR'NUM <> 0 THEN                                      <<04559>>68265000
      BEGIN                                                    <<04559>>68270000
      TOS := ERROR'NUM;       << Set ERROREXIT parameter.   >> <<04559>>68275000
      TOS := CCL;             << Set CC for ERROREXIT       >> <<04559>>68280000
      END                                                      <<04559>>68285000
   ELSE                                                        <<04559>>68290000
      BEGIN                                                    <<04559>>68295000
      RLOCK(FCB'RIN,T);       << Lock that there RIN!       >> <<04559>>68300000
      IF < THEN                                                <<04559>>68305000
         BEGIN                                                 <<04559>>68310000
         MRCAPOK(FALSE);      << Reset Global RIN flag.     >> <<04559>>68315000
         TOS := ERROR'NUM;                                     <<04559>>68320000
         TOS := CCG;          << Signify can't get RIN.     >> <<04559>>68325000
         END                                                   <<04559>>68330000
      ELSE     << We have RIN locked.  Re-locate ACB for    >> <<04559>>68335000
         BEGIN << FQUIESCE'IO.                              >> <<04559>>68340000
         LOC'ACB(DSTX,ACBMQ,FILENUM,UMODE);                    <<04559>>68345000
         DEL;                 << Delete DSTX return parm.   >> <<04559>>68350000
         IF NOT ACB'INHIBITBUF                                 <<06511>>68355000
            THEN FQUIESCE'IO(0); << Clear buffers           >> <<04559>>68360000
         UNLOC'ACB(ACBMQ,0);                                   <<04559>>68365000
         TOS := ERROR'NUM;    << Report no error.           >> <<04559>>68370000
         TOS := CCE;                                           <<04559>>68375000
         END;                                                  <<04559>>68380000
      END;                                                     <<04559>>68385000
                                                               <<04559>>68390000
   <<* * * Measurement data on FLOCK * * *>>                   <<04559>>68395000
                                                               <<04559>>68400000
$  IF X3 = ON                                                  <<04559>>68405000
   IF MEAS'TAPE'ON AND ERROR'NUM = 0 THEN BEGIN                <<04559>>68410000
   IF ACB'ACCCL = DIRACC THEN  << measure? >>                  <<06958>>68415000
      MMSTAT'(EFLOCK,FILENUM,T,S0,0,0,0);                      <<06958>>68420000
   END; << OF MEAS'TAPE'ON>>                                   <<04559>>68425000
$  IF                                                          <<04559>>68430000
                                                               <<04559>>68435000
   END;    << conventional file >>                                      68440000
                                                                        68445000
   BEGIN   << Remote file >>                                            68450000
   IF NOT MRCAPOK(TRUE) THEN    << Prevent illegal locking       DS.2F>>68455000
      BEGIN                     << of multiple RINs across       DS.2F>>68460000
      TOS := MRIN;              << systems.                      DS.2F>>68465000
      TOS := CCL;                                              <<DS.2F>>68470000
      GO EXIT;                                                 <<DS.2F>>68475000
      END;                                                     <<DS.2F>>68480000
   SETRFAPTR;                                                  <<DS.00>>68485000
   RFALEN := 7;                                                <<DS.03>>68490000
   TOS := "RFA ";                                              <<DS.00>>68495000
   TOS := 19;                                                  <<DS.00>>68500000
   TOS := RFAFILE;                                             <<DS.00>>68505000
   TOS := T;                                                   <<DS.00>>68510000
   TOS := 0D;                                                           68515000
   MWCNOBUF;                                                   <<DS.00>>68520000
   CHECKXFER;                                                  <<DS.00>>68525000
   DDEL; DDEL;                                                 <<DS.03>>68530000
   DDEL;                                                                68535000
   PREPRETURN;                                                 <<DS.00>>68540000
   IF S0 = CCL THEN                                            <<DS.2F>>68545000
       MRCAPOK( FALSE );                                       <<DS.2F>>68550000
   END;   << remote file >>                                             68555000
                                                                        68560000
      << dummy 2 >>;                                                    68565000
      << dummy 3 >>;                                                    68570000
      << dummy 4 >>;                                                    68575000
      << dummy 5 >>;                                                    68580000
   BEGIN   << KSAM file >>                                              68585000
   KLOCK(FILENUM,T);                                           <<KS.00>>68590000
   PUSH(STATUS);                                               <<KS.00>>68595000
   TOS := TOS.CC;     << report condition code >>              <<KS.00>>68600000
   ASMB(ZERO,XCH);                                             <<KS.00>>68605000
   END;    << KSAM file >>                                     <<KS.00>>68610000
   <<DUMMY 7>>;                                                <<HM.00>>68615000
   GO CONVENTIONAL;                                            <<HM.00>>68620000
   END;     << FTYPE CASE >>                                   <<DS.00>>68625000
                                                                        68630000
EXIT:                                                                   68635000
   CONDCODE := TOS;  << report condition code >>                        68640000
   RESETCRITICAL(CRIT);                                                 68645000
   ERROREXIT(2,S0,0)                                                    68650000
   END;     << procedure FLOCK >>                                       68655000
$CONTROL SEGMENT = FILESYS3   << FUNLOCK >>                             68660000
PROCEDURE FUNLOCK(FILENUM);                                             68665000
VALUE FILENUM;                                                          68670000
INTEGER FILENUM;                                                        68675000
OPTION PRIVILEGED;                                                      68680000
   BEGIN                                                                68685000
   INTEGER CRIT;     << for SETCRITICAL >>                              68690000
   DOUBLE FCBWORDS;                                                     68695000
      INTEGER FCB'RIN = FCBWORDS;                                       68700000
                                                                        68705000
   << Remote file access (RFA) variables: >>                            68710000
                                                                        68715000
   INTEGER POINTER RFAPTR;   << appendage pointer >>                    68720000
   INTEGER RFALEN;           << appendage length >>                     68725000
                                                                        68730000
<< Following LOC'ACB params must be last and in order: >>               68735000
   INTEGER ACBMQ;      << Q-relative displacement of ACB >>    <<04591>>68740000
   INTEGER AFTE;                                                        68745000
   DOUBLE  PACBV;                                              <<06511>>68750000
   DOUBLE  LACBV;                                              <<06511>>68755000
   INTEGER IOQX;                                                        68760000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;    << Q + ACBMQ >>     <<04591>>68765000
BUILD'ACB;                                                     <<06511>>68770000
   INTEGER DSTX;       << user's buffer DST >>                          68775000
   << End of LOC'ACB params >>                                          68780000
                                                                        68785000
$  IF X0 = ON                                                           68790000
   IF MONCALLABLE THEN                                                  68795000
      BEGIN                                                             68800000
      FTITLE("FUNL","OCK ",0D,0D);                                      68805000
      DEBUG                                                             68810000
      END;                                                              68815000
$  IF                                                                   68820000
                                                                        68825000
   ERRORON;                                                             68830000
   CRIT := SETCRITICAL;                                                 68835000
   GET'ACB'Q'LOC;                                              <<04591>>68840000
   LOC'ACB(*,ACBMQ,FILENUM,UMODE);                             <<01672>>68845000
   IF > THEN                                                            68850000
      BEGIN       << File is $NULL >>                                   68855000
      TOS := 0;   << No error >>                                        68860000
      TOS := CCE;                                                       68865000
      GO EXIT                                                           68870000
      END;                                                              68875000
   IF < THEN                                                            68880000
      BEGIN       << Invalid file number >>                             68885000
      TOS := INVFN;                                                     68890000
      TOS := CCL;                                                       68895000
      GO EXIT                                                           68900000
      END;                                                              68905000
   CASE * FTYPE OF                                                      68910000
   BEGIN                                                                68915000
                                                                        68920000
   BEGIN     << Conventional file >>                                    68925000
CONVENTIONAL:                                                  <<HM.00>>68930000
   IF ACB'ACCCL <> DIRACC THEN GO VILE;   << must be disk >>   <<01672>>68935000
   FCBWORDS := GETFCB'INFO(ACB'FCB,7);  << Get RIN nr. from FCB >>      68940000
   IF FCB'RIN = 0 THEN                                                  68945000
      BEGIN    << No RIN - wasn't FOPENed for locking. >>               68950000
VILE: TOS := ACCVIOL;                                          <<01672>>68955000
      TOS := CCL;                                                       68960000
      GO UNLK;                                                          68965000
      END;                                                              68970000
   IF NOT ACB'INHIBITBUF THEN FQUIESCE'IO(0);                  <<06511>>68975000
   RUNLOCK(FCB'RIN);                                                    68980000
   PUSH(STATUS);                                                        68985000
   TOS := TOS.(6:2);          << report condition code >>      <<02354>>68990000
   IF = THEN TOS:=NOTLOCKED   << CCG (=0)  : file not locked >><<02354>>68995000
   ELSE IF S0 = CCE THEN      << CCE (=2)  : unlock OK       >><<02354>>69000000
           BEGIN                                               <<02354>>69005000
           MRCAPOK(FALSE);    << reset Global RIN flag >>      <<02354>>69010000
           TOS:=0;            << No error >>                   <<02354>>69015000
           END                                                 <<02354>>69020000
        ELSE TOS:=NORIN;      << CCL: Rin not allocated >>     <<02354>>69025000
   ASMB(XCH);                 << S-1: error #; S-0: CC >>      <<02354>>69030000
                                                               <<02354>>69035000
   <<* * * Measurement data on FUNLOCK * * *>>                          69040000
                                                                        69045000
$  IF X3 = ON                                                           69050000
   IF MEAS'TAPE'ON THEN BEGIN                                           69055000
   IF S0 = CCE AND ACB'ACCCL = DIRACC THEN                     <<06958>>69060000
      MMSTAT'(EFUNLOCK,FILENUM,0,0,0,0,0);                     <<06958>>69065000
   END; << OF MEAS'TAPE'ON>>                                            69070000
$  IF                                                                   69075000
                                                                        69080000
                                                                        69085000
UNLK:                                                                   69090000
   ACB'ERROR := S1;                                            <<06511>>69095000
   UNLOC'ACB(ACBMQ,0);     << Release ACB >>                   <<01672>>69100000
   END;   << conventional file >>                                       69105000
                                                                        69110000
   BEGIN     << Remote file >>                                 <<DS.00>>69115000
   SETRFAPTR;                                                  <<DS.00>>69120000
   RFALEN := 6;                                                <<DS.03>>69125000
   TOS := "RFA ";                                              <<DS.00>>69130000
   TOS := 20;                                                  <<DS.00>>69135000
   TOS := RFAFILE;                                             <<DS.00>>69140000
   TOS := 0D;                                                           69145000
   MWCNOBUF;                                                   <<DS.00>>69150000
   CHECKXFER;                                                  <<DS.00>>69155000
   DELAPPENDAGE;                                               <<DS.00>>69160000
   PREPRETURN;                                                 <<DS.00>>69165000
   IF S0 = CCE THEN                                            <<DS.2F>>69170000
       MRCAPOK( FALSE );                                       <<DS.2F>>69175000
   END;   << Remote file >>                                             69180000
                                                                        69185000
      << dummy 2 >>;                                                    69190000
      << dummy 3 >>;                                                    69195000
      << dummy 4 >>;                                                    69200000
      << dummy 5 >>;                                                    69205000
   BEGIN     << KSAM file >>                                   <<KS.00>>69210000
   KUNLOCK(FILENUM);                                           <<KS.00>>69215000
   PUSH(STATUS);                                               <<KS.00>>69220000
   TOS := TOS.CC;                                              <<KS.00>>69225000
   ASMB(ZERO,XCH);                                             <<KS.00>>69230000
   END;   << KSAM file >>                                      <<KS.00>>69235000
   <<DUMMY 7>>;                                                <<HM.00>>69240000
   GO CONVENTIONAL;  <<MSG FILE>>                              <<HM.00>>69245000
   END;     << FTYPE CASE >>                                            69250000
EXIT:                                                                   69255000
   CONDCODE := TOS;    << report condition code >>                      69260000
   RESETCRITICAL(CRIT);                                                 69265000
   ERROREXIT(1,S0,0)                                                    69270000
   END;     << procedure FUNLOCK >>                                     69275000
$PAGE " FALTSEC "                                                       69280000
$CONTROL SEGMENT = FILESYS3                                             69285000
   PROCEDURE FALTSEC(FILENUM,NEWSECUREFLAG,NEWMATRIX,                   69290000
                     OLDFLAG,OLDMATRIX,EXCOND);                         69295000
      << Must be called with DB at the stack.  >>                       69300000
   VALUE FILENUM;                                                       69305000
   LOGICAL NEWSECUREFLAG;                                               69310000
   INTEGER FILENUM,OLDFLAG,EXCOND;                                      69315000
   ARRAY NEWMATRIX,OLDMATRIX;                                           69320000
   OPTION PRIVILEGED,VARIABLE;                                          69325000
   BEGIN                                                                69330000
                                                                        69335000
<<                                                                      69340000
This procedure allows the caller to                                     69345000
          - release an open file ('RELEASE')                            69350000
          - secure an open file  ('SECURE')                             69355000
          - alter the security mask of an open file ('ALTSEC').         69360000
                                                                        69365000
                                                                        69370000
INPUT:                                                                  69375000
       FILENUM        - File number of currently open file              69380000
                        *** REQUIRED PARAMETER ***                      69385000
                                                                        69390000
       NEWSECUREFLAG  - Optional integer variable.  If present,         69395000
                        requests FALTSEC to set the secure flag bit     69400000
                        in the file label to either secure the file     69405000
                        (if NEWSECUREFLAG is 1) or release the file     69410000
                        (NEWSECUREFLAG is 0)                            69415000
                                                                        69420000
       NEWMATRIX      - Optional two word array containing the new      69425000
                        security information as follows:                69430000
                                                                        69435000
                                                                        69440000
WORD 0:                                                                 69445000
------                                                                  69450000
                                                                        69455000
  0    1   2   3   4   5   6   7   8   9   10  11  12  13  14  15       69460000
|____|____|___|___|___|___|___|___|___|___|___|___|___|___|___|___|     69465000
|    |    |   |   |   |   |   |   |   |   |   |   |   |   |   |   |     69470000
|Def-|Cre-|R  |R  |R  |R  |R  |R  |A  |A  |A  |A  |A  |A  |W  |W  |     69475000
|ault|ator|   |   |   |   |   |   |   |   |   |   |   |   |   |   |     69480000
|Sec |Sec |ANY|AC |AL |GU |GL |CR |ANY|AC |AL |GU |GL |CR |ANY|AC |     69485000
|____|____|___|___|___|___|___|___|___|___|___|___|___|___|___|___|     69490000
                                                                        69495000
                                                                        69500000
                                                                        69505000
WORD 1:                                                                 69510000
------                                                                  69515000
                                                                        69520000
  0    1   2   3   4   5   6   7   8   9   10  11  12  13  14  15       69525000
|____|____|___|___|___|___|___|___|___|___|___|___|___|___|___|___|     69530000
|    |    |   |   |   |   |   |   |   |   |   |   |   |   |   |   |     69535000
| W  | W  |W  |W  |L  |L  |L  |L  |L  |L  |X  |X  |X  |X  |X  |X  |     69540000
|    |    |   |   |   |   |   |   |   |   |   |   |   |   |   |   |     69545000
| AL | GU |GL |CR |ANY|AC |AL |GU |GL |CR |ANY|AC |AL |GU |GL |CR |     69550000
|____|____|___|___|___|___|___|___|___|___|___|___|___|___|___|___|     69555000
                                                                        69560000
                                                                        69565000
WORD 0:                                                                 69570000
------                                                                  69575000
        .(0:1) - if set to 1, set default security (R,A,W,L,X:ANY)      69580000
        .(1:1) - if set to 1, set security to creator-only              69585000
                              (R,A,W,L,X:CR)                            69590000
                 NOTE: If both bits 0 and 1 are set, the creator-only   69595000
                       option will take precedence.                     69600000
                                                                        69605000
                       If neither of the bits is set, the matrix will   69610000
                       be set according to the remaining bits for the   69615000
                       matrix (word 0.(2:14) and word 1).  However,     69620000
                       if all the remaining bits are zero, no change    69625000
                       to the security matrix will be made (CCG will    69630000
                       be returned).                                    69635000
                                                                        69640000
       .(2:14) - Each bit represents access for a given user type.      69645000
                 Bit set to 1 enables security mode                     69650000
                 Bit set to 0 disables mode                             69655000
                                                                        69660000
                 R: Read         ANY: Any user                          69665000
                 A: Append       AC : Account member                    69670000
                 W: Write        AL : Account librarian                 69675000
                 L: Lock         GU : Group user                        69680000
                 X: Execute      GL : Group librarian                   69685000
                                 CR : Creator                           69690000
                                                                        69695000
WORD 1:                                                                 69700000
------                                                                  69705000
       .(0:16) - Same rules as for word 0 (2:14).                       69710000
                                                                        69715000
                                                                        69720000
                                                                        69725000
                                                                        69730000
**Note:  if all bits are off (word 0 (2:14) and word 1 (0:16))          69735000
         then no change will be made to security matrix.                69740000
         Also, if either default or creator-only security is            69745000
         selected, word 0.(2:14) and word 1 will be ignored.            69750000
                                                                        69755000
OUTPUT:                                                                 69760000
        OLDFLAG         - Optional integer variable.  If present,       69765000
                          FALTSEC will return the file label            69770000
                          secure flag setting (0=released,              69775000
                          1=secured) prior to any change made by        69780000
                          FALTSEC.                                      69785000
                                                                        69790000
        OLDMATRIX       - Optional two word array. If present, FALTSEC  69795000
                          will return the security information as set   69800000
                          in the file label prior to change made (if    69805000
                          any) by this call to FALTSEC.  (Same format   69810000
                          as 'NEWMATRIX' except that the first 2 bits   69815000
                          (word 0.(0:2)) are not used.)                 69820000
                                                                        69825000
                                                                        69830000
        EXCOND          - Optional integer variable.  If present,       69835000
                          and an exceptional condition occurs,          69840000
                          FALTSEC will return a number indicating       69845000
                          the nature of the exceptional condition:      69850000
                                                                        69855000
                          1:    Caller requested 'secure' but file      69860000
                                was already secured;                    69865000
                                                                        69870000
                          2:    Caller requested 'release' but file     69875000
                                was already released;                   69880000
                                                                        69885000
                          3:    Caller only requested a change to       69890000
                                the security matrix but the file        69895000
                                is currently released: matrix           69900000
                                changed as requested.                   69905000
                                                                        69910000
                          4:    'NEWMATRIX' passed by caller has        69915000
                                all zero bits; no change to security    69920000
                                was made by FALTSEC;                    69925000
                                                                        69930000
                          5:    Both the default and creator-only       69935000
                                bits were set (word 0, bits 0 and 1)    69940000
                                in the 'NEWMATRIX'; creator-only bit    69945000
                                used.                                   69950000
                                                                        69955000
                          In the event that more than one exception     69960000
                          occurs, the most serious (generally with      69965000
                          the highest number) is returned.              69970000
                                                                        69975000
        Condition code  - CCL, CCE, CCG returned as described below.    69980000
                                                                        69985000
                  CCL: An error occurred; no change was made.           69990000
                       Use FCHECK to determine the error number.        69995000
                                                                        70000000
                       An error will be returned if                     70005000
                       - DB is not set to stack              ILLDB      70010000
                       - file number is invalid or omitted   INVFN      70015000
                       - the file is not a disc file         DEVVIOL    70020000
                         or it is a spoolfile                           70025000
                       - the file is not opened exclusively  MLTIACCERR 70030000
                       - the user is not the creator         USERIDVIOL 70035000
                       - a file label IO error occurs.       LBLIOERR   70040000
                                                                        70045000
                  CCE: Change successfully made (no error).             70050000
                                                                        70055000
                  CCG: An exceptional condition occurred;               70060000
                       change was made where applicable.                70065000
                                                                        70070000
                       Examples of possible exceptional                 70075000
                       conditions are listed above (see                 70080000
                       EXCOND).                                         70085000
                                                                        70090000
                                                                        70095000
>>                                                                      70100000
   LOGICAL PARM=Q-4;                                                    70105000
   INTEGER CC';  << for condition code >>                               70110000
                                                                        70115000
   DEFINE                                                               70120000
                                                                        70125000
   NOFILENUM=PARM.(10:2)=0#,                                            70130000
   CHANGE'SECURITY=PARM.(11:2)<>0#,                                     70135000
                                                                        70140000
   SET'SECUREFLAG=PARM.(11:1)#,                                         70145000
   SET'MATRIX=PARM.(12:1)#,                                             70150000
   SELECT'MATRIX=TOS.(0:2)#,  << Word 0 of NEWMATRIX, bits 0 and 1 >>   70155000
                                                                        70160000
   RTN'OLDFLAG=PARM.(13:1)#,                                            70165000
   RTN'OLDMATRIX=PARM.(14:1)#,                                          70170000
   SET'EXCOND=PARM.(15:1)#,                                             70175000
   FILE'SECURED=LOGICAL(FLSECURE)#;                                     70180000
                                                                        70185000
   EQUATE R=6,AP=R,W=R,L=R,EX=R,                                        70190000
          CR=1,   << Bits 000001 >>                                     70195000
          ANY=32; << Bits 100000 >>                                     70200000
                                                                        70205000
   DOUBLE DEFAULTMATRIX:=[R/ANY,AP/ANY,W/ANY,L/ANY,EX/ANY]D,            70210000
          CREATORMATRIX:=[R/CR,AP/CR,W/CR,L/CR,EX/CR]D;                 70215000
                                                                        70220000
   DOUBLE POINTER NEWMATRIXDBL=NEWMATRIX,                               70225000
                  OLDMATRIXDBL=OLDMATRIX;                               70230000
                                                                        70235000
   INTEGER CRIT;        << for SETCRITICAL>>                            70240000
   INTEGER PCBGLOBLOC;                                         <<06510>>70245000
   INTEGER A := -1;    << for GETSIR >>                                 70250000
   INTEGER DADDR;                                                       70255000
                                                                        70260000
   << ACB parameters must be in order: >>                               70265000
                                                                        70270000
   INTEGER ACBMQ;                                              <<06511>>70275000
   INTEGER AFTE;        << AFT entry word 0 >>                          70280000
   DOUBLE  PACBV;       << physical ACB vector >>              <<06511>>70285000
   DOUBLE  LACBV;       << logical ACB vector >>               <<06511>>70290000
   INTEGER IOQX;                                                        70295000
   INTEGER ARRAY ACB(0:SIZEXACB-1) = Q;                                 70300000
   BUILD'ACB;                                                           70305000
   LOGICAL DSTX;        << User's DST nr. >>                            70310000
                                                                        70315000
   << File label parameters >>                                          70320000
                                                                        70325000
   DOUBLE LABADR;      << file label sector nr. >>                      70330000
   INTEGER ARRAY FLAB(0:127);  << file label buffer >>                  70335000
   DOUBLE POINTER FLABDBL = FLAB;                                       70340000
   BYTE POINTER CREATOR := @FLUSERID;                                   70345000
                                                                        70350000
   << JIT info >>                                                       70355000
                                                                        70360000
   ARRAY JITUSERID'L(0:3)=Q;                                   <<06960>>70365000
   BYTE ARRAY JITUSERID(*)=JITUSERID'L;                        <<06960>>70370000
     INTEGER POINTER AFT;       << for KSAM >>                          70375000
                                                                        70380000
                                                                        70385000
   SUBROUTINE LABELIO (RW);                                             70390000
      << Reads or writes the file label into the stack buffer.          70395000
                                                                        70400000
        INPUT VARIABLES:                                                70405000
            RW - I/O MODE                                               70410000
               0 - READ                                                 70415000
               1 - WRITE                                                70420000
                                                                        70425000
     DB must be at the stack when this subroutine is called.   >>       70430000
                                                                        70435000
   VALUE RW;                                                            70440000
   INTEGER RW;                                                          70445000
      BEGIN                                                             70450000
      X := FLABIO(DADDR,LABADR,RW,FLAB);  <<R/W LABEL>>                 70455000
      IF <> THEN                                                        70460000
         BEGIN     << Error. >>                                         70465000
         FLABIOERR(X,FILENUM);  << handle error >>                      70470000
         TOS := LBLIOERR;                                               70475000
         TOS := CCL;                                                    70480000
         GO STACKERR                                                    70485000
         END                                                            70490000
      END;        << subroutine LABELIO >>                              70495000
SUBROUTINE EXCEPTION(CONDITION);                                        70500000
VALUE CONDITION;                                                        70505000
INTEGER CONDITION;                                                      70510000
   BEGIN                                                                70515000
   CC' := CCG;                                                          70520000
   IF SET'EXCOND THEN EXCOND := CONDITION;                              70525000
   END;     << subroutine EXCEPTIION >>                                 70530000
                                                                        70535000
$  IF X0 = ON                                                           70540000
   IF MONCALLABLE THEN                                                  70545000
      BEGIN       << monitoring >>                                      70550000
      FTITLE("FALT","SEC ",0D,0D);                                      70555000
      DEBUG                                                             70560000
      END;                                                              70565000
$  IF                                                                   70570000
                                                                        70575000
   ERRORON;                                                             70580000
   CRIT := SETCRITICAL;                                                 70585000
   IF NOFILENUM THEN                                                    70590000
      BEGIN                                                             70595000
      TOS := INVFN;                                                     70600000
      TOS := CCL;                                                       70605000
      GO EXIT;                                                          70610000
      END;                                                              70615000
   GET'ACB'Q'LOC;                                              <<06511>>70620000
   LOC'ACB(0,ACBMQ,FILENUM,UMODE);                             <<06511>>70625000
   DSTX := TOS;          << DB at entry condition.  >>         <<04568>>70630000
                         << This will not affect CC >>         <<04568>>70635000
   IF < THEN                                                            70640000
      BEGIN     << Invalid file nr. >>                                  70645000
      TOS := INVFN;                                                     70650000
      TOS := CCL;                                                       70655000
      GO EXIT;                                                          70660000
   HELP;    << dummy call >>                                            70665000
      END;                                                              70670000
   IF > THEN                                                            70675000
      BEGIN      << $NULL >>                                            70680000
      TOS := 0;  << no error >>                                         70685000
      TOS := CCE;                                                       70690000
      GO EXIT                                                           70695000
      END;                                                              70700000
   IF DSTX <> 0 THEN                                                    70705000
      BEGIN       << DB not at stack. Boo! >>                           70710000
      TOS := ILLDB;                                                     70715000
      TOS := CCL;                                                       70720000
      GO ACBERR                                                         70725000
      END;                                                              70730000
   CASE FTYPE OF                                                        70735000
   BEGIN                                                                70740000
                                                                        70745000
   BEGIN    << conventional file >>                                     70750000
CONVENTIONAL:                                                  <<HM.00>>70755000
   IF ACB'FCB=0D OR ACB'SPOOLED THEN                           <<06511>>70760000
      BEGIN       << Not disk file. >>                                  70765000
      TOS := DEVVIOL;                                                   70770000
      TOS := CCL;                                                       70775000
      GO ACBERR                                                         70780000
      END;                                                              70785000
   IF NOT ACB'EXCLUSIVE AND NOT ACB'DEFAULT OR ACB'READ THEN   <<06511>>70790000
      BEGIN                                                             70795000
      TOS := MLTIACCERR;                                                70800000
      TOS := CCL;                                                       70805000
      GO ACBERR                                                         70810000
      END;                                                              70815000
   A := GETSIR(FISIR);  << Get File SIR while diddling labels >>        70820000
                                                                        70825000
   <<* * * Get label address from FCB * * *>>                           70830000
                                                                        70835000
   TOS := 0;           << for LDEV >>                                   70840000
   TOS := GETFCB'INFO (ACB'FCB, SIZEBFCB);                     <<01624>>70845000
   TOS := TOS&TASL(8)&DLSR(8);  <<separate LDEV>>                       70850000
   LABADR := TOS;      << file label sector nr. >>                      70855000
   DADDR := TOS;       << file label LDEV >>                            70860000
                                                                        70865000
   <<* * * Read file label * * *>>                                      70870000
                                                                        70875000
   LABELIO(0);      << read file label >>                               70880000
   IF FLFILECODE < 0 AND NOT PRIVMODE THEN                              70885000
      BEGIN     << Caller must be Priv if file is. >>                   70890000
      TOS := PRIVVIOL;                                                  70895000
      TOS := CCL;                                                       70900000
      GO STACKERR;                                                      70905000
      END;                                                              70910000
                                                                        70915000
   <<* * * Get information in JIT * * *>>                               70920000
                                                                        70925000
   PXGLOBAL;                                                   <<06510>>70930000
   TOS := @JITUSERID'L;                                        <<06960>>70935000
   TOS := PXG'JITDST; TOS := JITUSER;  <<JIT loc.>>            <<06960>>70940000
   TOS := 4;                                                   <<06960>>70945000
   ASSEMBLE(MFDS 4);                                                    70950000
                                                                        70955000
   << Compare user name in JIT with file label creator ID >>            70960000
                                                                        70965000
   IF JITUSERID <> CREATOR,(8) THEN                                     70970000
      BEGIN    << creator violation >>                                  70975000
      TOS := USERIDVIOL;                                                70980000
      TOS := CCL;                                                       70985000
      GO STACKERR                                                       70990000
      END;                                                              70995000
                                                                        71000000
   << Check to see if "old" security info should be returned. >>        71005000
   IF RTN'OLDFLAG THEN OLDFLAG := FLSECURE;                             71010000
   IF RTN'OLDMATRIX THEN OLDMATRIXDBL := FLSECMX;                       71015000
                                                                        71020000
   CC' := CCE;                                                          71025000
   IF SET'EXCOND THEN EXCOND := 0;                                      71030000
                                                                        71035000
   IF CHANGE'SECURITY THEN                                              71040000
      BEGIN      << Some change will be made. >>                        71045000
      IF SET'SECUREFLAG THEN    << Want to release or secure file >>    71050000
         BEGIN                                                          71055000
         IF FILE'SECURED THEN                                           71060000
            IF NEWSECUREFLAG           << Want to secure it ! >>        71065000
               THEN EXCEPTION(1)                                        71070000
               ELSE FLSECURE := 0        <<      Release it  >>         71075000
                                                                        71080000
            ELSE IF NEWSECUREFLAG   << File is currently released>>     71085000
               THEN FLSECURE := 1     << Secure it           >>         71090000
               ELSE EXCEPTION(2);   <<   Want to release it>>           71095000
         END;                                                           71100000
                                                                        71105000
      IF SET'MATRIX THEN                                                71110000
         BEGIN     << Set new file label security matrix. >>            71115000
                                                                        71120000
         IF NOT(FILE'SECURED             << Why change it for a >>      71125000
            LOR SET'SECUREFLAG)          << released file or if >>      71130000
            OR NOT NEWSECUREFLAG         << just released it?   >>      71135000
         THEN EXCEPTION(3);                                             71140000
                                                                        71145000
         TOS := NEWMATRIXDBL;   << Put new matrix on top of stack >>    71150000
         IF = THEN                                                      71155000
            BEGIN      << New matrix all zeroes; make no change. >>     71160000
            DDEL;                                                       71165000
            EXCEPTION(4);                                               71170000
            END                                                         71175000
         ELSE                                                           71180000
            BEGIN       << Want to make some change to matrix >>        71185000
            DEL;         << Leaves word 0 of NEWMATRIX on TOS >>        71190000
                                                                        71195000
            CASE SELECT'MATRIX OF  << Based on TOS bits (0:2) >>        71200000
               BEGIN                                                    71205000
              << Bits: 00 --- Use supplied matrix >>                    71210000
                BEGIN                                                   71215000
                TOS := NEWMATRIX.(2:14);                                71220000
                TOS := NEWMATRIX(1);                                    71225000
                END;                                                    71230000
             << Bits: 01 --- Use creator-only matrix >>                 71235000
                BEGIN                                                   71240000
                TOS := CREATORMATRIX;                                   71245000
                END;                                                    71250000
             << Bits: 10 --- Use default matrix >>                      71255000
                BEGIN                                                   71260000
                TOS := DEFAULTMATRIX;                                   71265000
                END;                                                    71270000
             << Bits: 11 --- Selected both! Use creator-only >>         71275000
                BEGIN                                                   71280000
                TOS := CREATORMATRIX;                                   71285000
                EXCEPTION(5);                                           71290000
                END;                                                    71295000
                END;  << CASE on SELECT'MATRIX >>                       71300000
                                                                        71305000
             FLSECMX := TOS;        << Change it (2 wds on TOS) >>      71310000
             END;  << make change to matrix >>                          71315000
                                                                        71320000
         END;     << set new matrix >>                                  71325000
                                                                        71330000
     <<* * * Write updated file label * * *>>                           71335000
                                                                        71340000
      FLLASTMOD := CALENDAR;  << update modification date >>            71345000
      LABELIO(1);     << write file label >>                            71350000
      END;                                                              71355000
                                                                        71360000
   <<* * * Measurement data on FALTSEC * * *>>                          71365000
                                                                        71370000
$  IF X3 = ON                                                           71375000
   IF MEAS'TAPE'ON THEN BEGIN                                           71380000
   MMSTAT'(EFALTSEC,FILENUM,0,0,0,0,0);  <<MEASURE EVENT>>     <<06958>>71385000
   END; << of MEAS'TAPE'ON>>                                            71390000
$  IF                                                                   71395000
                                                                        71400000
   TOS := 0;    << no error >>                                          71405000
   TOS := CC';  << either CCE or CCG at this point >>                   71410000
                                                                        71415000
STACKERR:                                                               71420000
                                                                        71425000
ACBERR:                                                                 71430000
   ACB'ERROR := S1;  << error nr. >>                                    71435000
   IF A <> -1 THEN RELSIR(FISIR,A);                                     71440000
   UNLOC'ACB(ACBMQ,0);       << release ACB >>                 <<06511>>71445000
   END;      << conventional file >>                                    71450000
                                                                        71455000
   BEGIN << remote file >>                                              71460000
   END;  << remote file >>                                              71465000
                                                                        71470000
      << dummy 2>>;                                                     71475000
      << dummy 3>>;                                                     71480000
      << dummy 4>>;                                                     71485000
      << dummy 5>>;                                                     71490000
   BEGIN    << KSAM file >>                                             71495000
   DSTX := EXCHANGEDB(0);                                               71500000
   SETAFT;                                                              71505000
   AFTFLAG := 3;      << KSAM error >>                                  71510000
   AFTERRNUM := UNIMPL;    <<"unimplemented">>                          71515000
   TOS := UNIMPL;       <<"unimplemented">>                             71520000
   TOS := CCL;                                                          71525000
   EXCHANGEDB(DSTX);                                                    71530000
   END;      <<KSAM file >>                                             71535000
   <<DUMMY 7>>;                                                <<HM.00>>71540000
   GO CONVENTIONAL;                                            <<HM.00>>71545000
   END;     << FTYPE CASE >>                                            71550000
EXIT:                                                                   71555000
   CONDCODE := TOS;  << report condition code >>                        71560000
   RESETCRITICAL(CRIT);                                                 71565000
   ERROREXIT(7,S0,0)                                                    71570000
   END;     << procedure FALTSEC >>                                     71575000
$PAGE "3000/30 FILE SYSTEM - FINTSTATE, FINTEXIT"              <<03038>>71580000
$CONTROL SEGMENT=FILESYS2                                      <<03038>>71585000
                                                               <<03038>>71590000
LOGICAL PROCEDURE FINTSTATE(NEWSTATE);                         <<03038>>71595000
VALUE NEWSTATE;                                                <<03038>>71600000
                                                               <<03038>>71605000
<<FUNCTION                                                       HM.XX  71610000
  ENABLES/DISABLES FILE SOFT INTERRUPTS AGAINST THE PROCESS.>> <<03038>>71615000
                                                               <<03038>>71620000
<<INPUT>>                                                      <<03038>>71625000
  LOGICAL                                                      <<03038>>71630000
    NEWSTATE;            <<(15:1):  0 - DISABLE FS INTERRUPTS    HM.XX  71635000
                                    1 - ENABLE FILE SYS INTS     HM.XX  71640000
                           (0:15):  IGNORED.>>                 <<03038>>71645000
<<OUTPUT                                                         HM.XX  71650000
    FINTSTATE              OLD VALUE OF THE FILE SYSTEM INT      HM.XX  71655000
                           STATE.>>                            <<03038>>71660000
                                                               <<03038>>71665000
OPTION PRIVILEGED;                                             <<03038>>71670000
                                                               <<03038>>71675000
   BEGIN                                                       <<03038>>71680000
   DEFINE                                                      <<03038>>71685000
      INTSTATEHANG= [10/24,6/1]#;                              <<03038>>71690000
                                                               <<03038>>71695000
   <<INITIALIZE>>                                              <<03038>>71700000
   ERRORON;                                                    <<03038>>71705000
   FINTSTATE:=CHANGEINTSTATE(NEWSTATE);                        <<03038>>71710000
   ERROREXIT(INTSTATEHANG,0,0);                                <<03038>>71715000
   END;  <<FINTSTATE>>                                         <<03038>>71720000
$CONTROL SEGMENT=FILESYS2                                      <<03038>>71725000
PROCEDURE FINTEXIT(NEWSTATE);                                  <<03038>>71730000
VALUE NEWSTATE;                                                <<03038>>71735000
                                                               <<03038>>71740000
<<FUNCTION                                                       HM.XX  71745000
  EXITS FROM A USER SOFT INTERRUPT PROCEDURE.>>                <<03038>>71750000
                                                               <<03038>>71755000
<<INPUT>>                                                      <<03038>>71760000
  LOGICAL                                                      <<03038>>71765000
    NEWSTATE;            <<(15:1):  0 - DISABLE FS INTERRUPTS    HM.XX  71770000
                                    1 - ENABLE FILE SYSTEM INTS  HM.XX  71775000
                           (0:15):  IGNORED.>>                 <<03038>>71780000
                                                               <<03038>>71785000
  <<OUTPUT                                                       HM.XX  71790000
    NONE.>>                                                    <<03038>>71795000
                                                               <<03038>>71800000
  <<NOTE: THE CALLING PROCEDURE'S STACK MARKER IS DELETED,       HM.XX  71805000
          CONTROL IS RETURNED TO THE INTERRUPTED PROCEDURE       HM.XX  71810000
          UNLESS:                                                HM.XX  71815000
                                                                 HM.XX  71820000
            1. THE NEWSTATE PARAMETER SPECIFIES THAT INTERRUPTS  HM.XX  71825000
               BE ENABLED,                                       HM.XX  71830000
            2. AND ONE OR MORE INTERRUPTS ARE PENDING.>>       <<03038>>71835000
                                                               <<03038>>71840000
OPTION PRIVILEGED,VARIABLE;                                    <<03038>>71845000
                                                               <<03038>>71850000
   BEGIN                                                       <<03038>>71855000
   EQUATE                                                      <<03038>>71860000
      INTEXITHANG   = [10/23,6/1];                             <<03038>>71865000
   LOGICAL                                                     <<03038>>71870000
      PMAP=Q-4,NEWSTATE'=Q+1;                                  <<03038>>71875000
   INTEGER                                                     <<03038>>71880000
      STATUS=Q-1,DELTAQ=Q-0;                                   <<03038>>71885000
   INTEGER ARRAY                                               <<03038>>71890000
      Q0ARRAY(*)=Q-0;                                          <<03038>>71895000
                                                               <<03038>>71900000
   <<INSURE THAT THE STACK MARKER IS HARMLESS>>                <<03038>>71905000
   ERRORON;                                                    <<03038>>71910000
   IF STATUS >= 0 AND Q0ARRAY(-DELTAQ-1) < 0  <<NONPRIV=>PRIV>><<03038>>71915000
   OR Q0ARRAY(-DELTAQ) < 0 THEN  <<DELTA Q GOING NEGATIVE>>    <<03038>>71920000
      ABORT(0,22,0);                                           <<03038>>71925000
                                                               <<03038>>71930000
   <<DELETE THE CALLER'S STACK MARKER>>                        <<03038>>71935000
   X:=IF PMAP THEN NEWSTATE ELSE 1;                            <<03038>>71940000
   PUSH(Q); TOS:=TOS-DELTAQ; SET(Q);                           <<03038>>71945000
   NEWSTATE':=X;                                               <<03038>>71950000
                                                               <<03038>>71955000
   <<UPDATE THE PROCESS'S INTERRUPT STATUS>>                   <<03038>>71960000
   CHANGEINTSTATE(NEWSTATE');                                  <<03038>>71965000
                                                               <<03038>>71970000
   ERROREXIT(INTEXITHANG,0,0);                                 <<03038>>71975000
   END;  <<FINTEXIT>>                                          <<03038>>71980000
$PAGE "3000/30 FILE SYSTEM - OUTER BLOCK"                      <<03038>>71985000
$CONTROL SEGMENT=FLESYS, MAP  << OUTER BLOCK >>                <<03038>>71990000
END.   << End of File System >>                                <<03038>>71995000
